-----------------------------------------------------------------------
--  awa-workspaces-beans -- Beans for module workspaces
--  Copyright (C) 2011, 2012, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Strings.Unbounded;

with Util.Beans.Basic;
with Util.Beans.Objects;
with Util.Beans.Methods;

with AWA.Events;
with AWA.Users.Models;
with AWA.Workspaces.Models;
with AWA.Workspaces.Modules;
package AWA.Workspaces.Beans is

   type Member_Bean is new AWA.Workspaces.Models.Member_Bean with record
      Module  : AWA.Workspaces.Modules.Workspace_Module_Access := null;
   end record;
   type Member_Bean_Access is access all Member_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Member_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name
   overriding
   procedure Set_Value (Item  : in out Member_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   overriding
   procedure Load (Bean : in out Member_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   overriding
   procedure Delete (Bean : in out Member_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Member_Bean bean instance.
   function Create_Member_Bean (Module : in AWA.Workspaces.Modules.Workspace_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access;

   type Invitation_Bean is new AWA.Workspaces.Models.Invitation_Bean with record
      Module  : AWA.Workspaces.Modules.Workspace_Module_Access := null;
      Inviter : AWA.Users.Models.User_Ref;
   end record;
   type Invitation_Bean_Access is access all Invitation_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Invitation_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   overriding
   procedure Load (Bean : in out Invitation_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   overriding
   procedure Accept_Invitation (Bean    : in out Invitation_Bean;
                                Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   overriding
   procedure Send (Bean    : in out Invitation_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Invitation_Bean bean instance.
   function Create_Invitation_Bean (Module : in AWA.Workspaces.Modules.Workspace_Module_Access)
                                     return Util.Beans.Basic.Readonly_Bean_Access;

   type Workspaces_Bean is new Util.Beans.Basic.Bean
     and Util.Beans.Methods.Method_Bean with record
      Module : AWA.Workspaces.Modules.Workspace_Module_Access := null;
      Count  : Natural := 0;
   end record;
   type Workspaces_Bean_Access is access all Workspaces_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Workspaces_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Workspaces_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  This bean provides some methods that can be used in a Method_Expression
   overriding
   function Get_Method_Bindings (From : in Workspaces_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access;

   --  Event action called to create the workspace when the given event is posted.
   procedure Create (Bean  : in out Workspaces_Bean;
                     Event : in AWA.Events.Module_Event'Class);

   --  Example of action method.
   procedure Action (Bean    : in out Workspaces_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Workspaces_Bean bean instance.
   function Create_Workspaces_Bean (Module : in AWA.Workspaces.Modules.Workspace_Module_Access)
      return Util.Beans.Basic.Readonly_Bean_Access;

   type Member_List_Bean is new AWA.Workspaces.Models.Member_List_Bean with record
      Module       : AWA.Workspaces.Modules.Workspace_Module_Access;

      --  The list of workspace members.
      Members      : aliased AWA.Workspaces.Models.Member_Info_List_Bean;
      Members_Bean : Util.Beans.Basic.Readonly_Bean_Access;
   end record;
   type Member_List_Bean_Access is access all Member_List_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Member_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Load the list of members.
   overriding
   procedure Load (Into    : in out Member_List_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Member_List_Bean bean instance.
   function Create_Member_List_Bean (Module : in AWA.Workspaces.Modules.Workspace_Module_Access)
                                     return Util.Beans.Basic.Readonly_Bean_Access;

end AWA.Workspaces.Beans;

-----------------------------------------------------------------------
--  awa-workspaces-beans -- Beans for module workspaces
--  Copyright (C) 2011, 2012, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Strings.Unbounded;

with Util.Beans.Basic;
with Util.Beans.Objects;
with Util.Beans.Methods;

with AWA.Events;
with AWA.Users.Models;
with AWA.Workspaces.Models;
with AWA.Workspaces.Modules;
package AWA.Workspaces.Beans is

   type Member_Bean is new AWA.Workspaces.Models.Member_Bean with record
      Module  : AWA.Workspaces.Modules.Workspace_Module_Access := null;
   end record;
   type Member_Bean_Access is access all Member_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Member_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name
   overriding
   procedure Set_Value (Item  : in out Member_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   overriding
   procedure Load (Bean : in out Member_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   overriding
   procedure Delete (Bean : in out Member_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Member_Bean bean instance.
   function Create_Member_Bean (Module : in AWA.Workspaces.Modules.Workspace_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access;

   type Invitation_Bean is new AWA.Workspaces.Models.Invitation_Bean with record
      Module  : AWA.Workspaces.Modules.Workspace_Module_Access := null;
      Inviter : AWA.Users.Models.User_Ref;
   end record;
   type Invitation_Bean_Access is access all Invitation_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Invitation_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   overriding
   procedure Load (Bean : in out Invitation_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   overriding
   procedure Accept_Invitation (Bean    : in out Invitation_Bean;
                                Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   overriding
   procedure Send (Bean    : in out Invitation_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Invitation_Bean bean instance.
   function Create_Invitation_Bean (Module : in AWA.Workspaces.Modules.Workspace_Module_Access)
                                     return Util.Beans.Basic.Readonly_Bean_Access;

   type Workspaces_Bean is new Util.Beans.Basic.Bean
     and Util.Beans.Methods.Method_Bean with record
      Module : AWA.Workspaces.Modules.Workspace_Module_Access := null;
      Count  : Natural := 0;
   end record;
   type Workspaces_Bean_Access is access all Workspaces_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Workspaces_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Workspaces_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  This bean provides some methods that can be used in a Method_Expression
   overriding
   function Get_Method_Bindings (From : in Workspaces_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access;

   --  Event action called to create the workspace when the given event is posted.
   procedure Create (Bean  : in out Workspaces_Bean;
                     Event : in AWA.Events.Module_Event'Class);

   --  Create the Workspaces_Bean bean instance.
   function Create_Workspaces_Bean (Module : in AWA.Workspaces.Modules.Workspace_Module_Access)
      return Util.Beans.Basic.Readonly_Bean_Access;

   type Member_List_Bean is new AWA.Workspaces.Models.Member_List_Bean with record
      Module       : AWA.Workspaces.Modules.Workspace_Module_Access;

      --  The list of workspace members.
      Members      : aliased AWA.Workspaces.Models.Member_Info_List_Bean;
      Members_Bean : Util.Beans.Basic.Readonly_Bean_Access;
   end record;
   type Member_List_Bean_Access is access all Member_List_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Member_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Load the list of members.
   overriding
   procedure Load (Into    : in out Member_List_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Member_List_Bean bean instance.
   function Create_Member_List_Bean (Module : in AWA.Workspaces.Modules.Workspace_Module_Access)
                                     return Util.Beans.Basic.Readonly_Bean_Access;

end AWA.Workspaces.Beans;

Remove the Action procedure that is not used


-----------------------------------------------------------------------
--  asf-views-facelets -- Facelets representation and management
--  Copyright (C) 2009, 2010 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Calendar;
with Ada.Strings.Unbounded;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Unbounded.Hash;
with ASF.Views.Nodes;
with ASF.Contexts.Facelets;
with ASF.Factory;
with ASF.Components;
with Util.Strings;
with Ada.Finalization;

--  The ASF.Views.Facelets package contains the facelet factory
--  responsible for getting the facelet tree from a facelet name.
--  The facelets (or *.xhtml) files are loaded by the reader to form
--  a tag node tree which is cached by the factory.  The facelet factory
--  is shared by multiple requests and threads.
package ASF.Views.Facelets is

   type Facelet is private;
   type Facelet_Access is access all Facelet;

   --  Returns True if the facelet is null/empty.
   function Is_Null (F : Facelet) return Boolean;

   --  ------------------------------
   --  Facelet factory
   --  ------------------------------
   --  The facelet factory allows to retrieve the node tree to build the
   --  component tree.  The node tree can be shared by several component trees.
   --  The node tree is initialized from the XHTML view file.  It is put
   --  in a cache to avoid loading and parsing the file several times.
   type Facelet_Factory is limited private;

   --  Get the facelet identified by the given name.  If the facelet is already
   --  loaded, the cached value is returned.  The facelet file is searched in
   --  a set of directories configured in the facelet factory.
   procedure Find_Facelet (Factory : in out Facelet_Factory;
                           Name    : in String;
                           Context : in ASF.Contexts.Facelets.Facelet_Context'Class;
                           Result  : out Facelet);

   --  Create the component tree from the facelet view.
   procedure Build_View (View    : in Facelet;
                         Context : in out ASF.Contexts.Facelets.Facelet_Context'Class;
                         Root    : in ASF.Components.UIComponent_Access);

   --  Initialize the facelet factory.
   --  Set the search directories for facelet files.
   --  Set the ignore white space configuration when reading XHTML files.
   --  Set the ignore empty lines configuration when reading XHTML files.
   --  Set the escape unknown tags configuration when reading XHTML files.
   procedure Initialize (Factory             : in out Facelet_Factory;
                         Paths               : in String;
                         Ignore_White_Spaces : in Boolean;
                         Ignore_Empty_Lines  : in Boolean;
                         Escape_Unknown_Tags : in Boolean);

   --  Find the facelet file in one of the facelet directories.
   --  Returns the path to be used for reading the facelet file.
   function Find_Facelet_Path (Factory : Facelet_Factory;
                               Name    : String) return String;

   --  Register the component factory bindings in the facelet factory.
   procedure Register (Factory  : in out Facelet_Factory;
                       Bindings : in ASF.Factory.Factory_Bindings_Access);

   --  Register a module and directory where the module files are stored.
   procedure Register_Module (Factory : in out Facelet_Factory;
                              Name    : in String;
                              Paths   : in String);

   --  Clear the facelet cache
   procedure Clear_Cache (Factory : in out Facelet_Factory);

private

   use Ada.Strings.Unbounded;

   type Facelet is record
      Root        : ASF.Views.Nodes.Tag_Node_Access;
      Path        : Unbounded_String;
      File        : Util.Strings.String_Access;
      Modify_Time : Ada.Calendar.Time;
   end record;

   --  Tag library map indexed on the library namespace.
   package Facelet_Maps is new
     Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => Unbounded_String,
                                            Element_Type    => Facelet,
                                            Hash            => Ada.Strings.Unbounded.Hash,
                                            Equivalent_Keys => "=");

   use Facelet_Maps;

   --  Lock for accessing the shared cache
   protected type RW_Lock is
      entry Read;

      procedure Release_Read;

      entry Write;

      procedure Release_Write;
   private
      Readable     : Boolean := True;
      Reader_Count : Natural := 0;
   end RW_Lock;

   type Facelet_Factory is new Ada.Finalization.Limited_Controlled with record
      Paths   : Unbounded_String := To_Unbounded_String ("");
      Lock    : RW_Lock;
      Map     : Facelet_Maps.Map;

      Path_Map : Util.Strings.String_Map.Map;

      --  The component factory
      Factory  : aliased ASF.Factory.Component_Factory;

      --  Whether the unknown tags are escaped using XML escape rules.
      Escape_Unknown_Tags : Boolean := True;

      --  Whether white spaces can be ignored.
      Ignore_White_Spaces : Boolean := True;

      --  Whether empty lines should be ignored (when white spaces are kept).
      Ignore_Empty_Lines : Boolean := True;
   end record;

   --  Free the storage held by the factory cache.
   overriding
   procedure Finalize (Factory : in out Facelet_Factory);

end ASF.Views.Facelets;

-----------------------------------------------------------------------
--  asf-views-facelets -- Facelets representation and management
--  Copyright (C) 2009, 2010 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Calendar;
with Ada.Strings.Unbounded;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Unbounded.Hash;
with ASF.Views.Nodes;
with ASF.Contexts.Facelets;
with ASF.Factory;
with ASF.Components;
with Util.Strings;
with Ada.Finalization;

--  The ASF.Views.Facelets package contains the facelet factory
--  responsible for getting the facelet tree from a facelet name.
--  The facelets (or *.xhtml) files are loaded by the reader to form
--  a tag node tree which is cached by the factory.  The facelet factory
--  is shared by multiple requests and threads.
package ASF.Views.Facelets is

   type Facelet is private;
   type Facelet_Access is access all Facelet;

   --  Returns True if the facelet is null/empty.
   function Is_Null (F : Facelet) return Boolean;

   --  ------------------------------
   --  Facelet factory
   --  ------------------------------
   --  The facelet factory allows to retrieve the node tree to build the
   --  component tree.  The node tree can be shared by several component trees.
   --  The node tree is initialized from the XHTML view file.  It is put
   --  in a cache to avoid loading and parsing the file several times.
   type Facelet_Factory is limited private;

   --  Get the facelet identified by the given name.  If the facelet is already
   --  loaded, the cached value is returned.  The facelet file is searched in
   --  a set of directories configured in the facelet factory.
   procedure Find_Facelet (Factory : in out Facelet_Factory;
                           Name    : in String;
                           Context : in ASF.Contexts.Facelets.Facelet_Context'Class;
                           Result  : out Facelet);

   --  Create the component tree from the facelet view.
   procedure Build_View (View    : in Facelet;
                         Context : in out ASF.Contexts.Facelets.Facelet_Context'Class;
                         Root    : in ASF.Components.UIComponent_Access);

   --  Initialize the facelet factory.
   --  Set the search directories for facelet files.
   --  Set the ignore white space configuration when reading XHTML files.
   --  Set the ignore empty lines configuration when reading XHTML files.
   --  Set the escape unknown tags configuration when reading XHTML files.
   procedure Initialize (Factory             : in out Facelet_Factory;
                         Paths               : in String;
                         Ignore_White_Spaces : in Boolean;
                         Ignore_Empty_Lines  : in Boolean;
                         Escape_Unknown_Tags : in Boolean);

   --  Find the facelet file in one of the facelet directories.
   --  Returns the path to be used for reading the facelet file.
   function Find_Facelet_Path (Factory : Facelet_Factory;
                               Name    : String) return String;

   --  Register the component factory bindings in the facelet factory.
   procedure Register (Factory  : in out Facelet_Factory;
                       Bindings : in ASF.Factory.Factory_Bindings_Access);

   --  Register a module and directory where the module files are stored.
   procedure Register_Module (Factory : in out Facelet_Factory;
                              Name    : in String;
                              Paths   : in String);

   --  Clear the facelet cache
   procedure Clear_Cache (Factory : in out Facelet_Factory);

private

   use Ada.Strings.Unbounded;

   type Facelet is record
      Root        : ASF.Views.Nodes.Tag_Node_Access;
      Path        : Unbounded_String;
      File        : String_Access;
      Modify_Time : Ada.Calendar.Time;
   end record;

   --  Tag library map indexed on the library namespace.
   package Facelet_Maps is new
     Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => Unbounded_String,
                                            Element_Type    => Facelet,
                                            Hash            => Ada.Strings.Unbounded.Hash,
                                            Equivalent_Keys => "=");

   use Facelet_Maps;

   --  Lock for accessing the shared cache
   protected type RW_Lock is
      entry Read;

      procedure Release_Read;

      entry Write;

      procedure Release_Write;
   private
      Readable     : Boolean := True;
      Reader_Count : Natural := 0;
   end RW_Lock;

   type Facelet_Factory is new Ada.Finalization.Limited_Controlled with record
      Paths   : Unbounded_String := To_Unbounded_String ("");
      Lock    : RW_Lock;
      Map     : Facelet_Maps.Map;

      Path_Map : Util.Strings.String_Map.Map;

      --  The component factory
      Factory  : aliased ASF.Factory.Component_Factory;

      --  Whether the unknown tags are escaped using XML escape rules.
      Escape_Unknown_Tags : Boolean := True;

      --  Whether white spaces can be ignored.
      Ignore_White_Spaces : Boolean := True;

      --  Whether empty lines should be ignored (when white spaces are kept).
      Ignore_Empty_Lines : Boolean := True;
   end record;

   --  Free the storage held by the factory cache.
   overriding
   procedure Finalize (Factory : in out Facelet_Factory);

end ASF.Views.Facelets;

Use Ada String_Access

Use Ada String_Access


-----------------------------------------------------------------------
--  Ipc -- Ipc channel between profiler tool and application          --
--  Copyright (C) 2014 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Interfaces;
with System; use System;
with System.Address_To_Access_Conversions;
with System.Storage_Elements;
with Util.Log.Loggers;
with Interfaces; use Interfaces;
package body MAT.Readers.Marshaller is

   use System.Storage_Elements;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Readers.Marshaller");

   package Uint8_Access is new System.Address_To_Access_Conversions (MAT.Types.Uint8);

   package Uint32_Access is new System.Address_To_Access_Conversions (MAT.Types.Uint32);

   function Get_Raw_Uint32 (Buf : System.Address) return MAT.Types.Uint32 is
      use Uint32_Access;

      P : constant Object_Pointer := To_Pointer (Buf);
   begin
      return P.all;
   end Get_Raw_Uint32;

   --  ------------------------------
   --  Get an 8-bit value from the buffer.
   --  ------------------------------
   function Get_Uint8 (Buffer : in Buffer_Ptr) return MAT.Types.Uint8 is
      use Uint8_Access;

      P : constant Object_Pointer := To_Pointer (Buffer.Current);
   begin
      if Buffer.Size = 0 then
         Log.Error ("Not enough data to get a uint8");
         raise Buffer_Underflow_Error;
      end if;
      Buffer.Size := Buffer.Size - 1;
      Buffer.Current := Buffer.Current + Storage_Offset (1);
      return P.all;
   end Get_Uint8;

   --  ------------------------------
   --  Get a 16-bit value either from big-endian or little endian.
   --  ------------------------------
   function Get_Uint16 (Buffer : in Buffer_Ptr) return MAT.Types.Uint16 is
      use Uint8_Access;

      High : Object_Pointer;
      Low  : Object_Pointer;
   begin
      if Buffer.Size <= 1 then
         Log.Error ("Not enough data to get a uint16");
         raise Buffer_Underflow_Error;
      end if;
      if Buffer.Endian = LITTLE_ENDIAN then
         Low  := To_Pointer (Buffer.Current);
         High := To_Pointer (Buffer.Current + Storage_Offset (1));
      else
         High := To_Pointer (Buffer.Current);
         Low  := To_Pointer (Buffer.Current + Storage_Offset (1));
      end if;
      Buffer.Size := Buffer.Size - 2;
      Buffer.Current := Buffer.Current + Storage_Offset (2);
      return MAT.Types.Uint16 (High.all) * 256 + MAT.Types.Uint16 (Low.all);
   end Get_Uint16;

   --  ------------------------------
   --  Get a 32-bit value either from big-endian or little endian.
   --  ------------------------------
   function Get_Uint32 (Buffer : in Buffer_Ptr) return MAT.Types.Uint32 is
      use Uint32_Access;

      Low, High : MAT.Types.Uint16;
   begin
      if Buffer.Size < 4 then
         Log.Error ("Not enough data to get a uint32");
         raise Buffer_Underflow_Error;
      end if;
      if Buffer.Endian = LITTLE_ENDIAN then
         Low  := Get_Uint16 (Buffer);
         High := Get_Uint16 (Buffer);
      else
         High := Get_Uint16 (Buffer);
         Low  := Get_Uint16 (Buffer);
      end if;
      return Interfaces.Shift_Left (MAT.Types.Uint32 (High), 16) + MAT.Types.Uint32 (Low);
   end Get_Uint32;

   function Get_Uint64 (Buffer : in Buffer_Ptr) return MAT.Types.Uint64 is
      Val : constant MAT.Types.Uint64 := MAT.Types.Uint64 (Get_Uint32 (Buffer));
   begin
      return Val + MAT.Types.Uint64 (Get_Uint32 (Buffer)) * 2**32;
   end Get_Uint64;

   function Get_Target_Value (Msg  : in Buffer_Ptr;
                              Kind : in MAT.Events.Attribute_Type) return Target_Type is
   begin
      case Kind is
         when MAT.Events.T_UINT8 =>
            return Target_Type (Get_Uint8 (Msg));

         when MAT.Events.T_UINT16 =>
            return Target_Type (Get_Uint16 (Msg));

         when MAT.Events.T_UINT32 =>
            return Target_Type (Get_Uint32 (Msg));

         when MAT.Events.T_UINT64 =>
            return Target_Type (Get_Uint64 (Msg));

         when others =>
            Log.Error ("Invalid attribute type {0}",
                       MAT.Events.Attribute_Type'Image (Kind));
            return 0;
      end case;
   end Get_Target_Value;

   --  ------------------------------
   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   --  ------------------------------
   function Get_String (Buffer : in Buffer_Ptr) return String is
      Len    : constant MAT.Types.Uint8 := Get_Uint8 (Buffer);
      Result : String (1 .. Natural (Len));
   begin
      for I in Result'Range loop
         Result (I) := Character'Val (Get_Uint8 (Buffer));
      end loop;
      return Result;
   end Get_String;

   --  ------------------------------
   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   --  ------------------------------
   function Get_String (Msg : in Buffer_Ptr) return Ada.Strings.Unbounded.Unbounded_String is
   begin
      return Ada.Strings.Unbounded.To_Unbounded_String (Get_String (Msg));
   end Get_String;

   --  ------------------------------
   --  Skip the given number of bytes from the message.
   --  ------------------------------
   procedure Skip (Buffer : in Buffer_Ptr;
                   Size   : in Natural) is
   begin
      Buffer.Size := Buffer.Size - Size;
      Buffer.Current := Buffer.Current + Storage_Offset (Size);
   end Skip;

   function Get_Target_Size (Msg  : in Buffer_Ptr;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Size is
         function Get_Value is new Get_Target_Value (MAT.Types.Target_Size);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Size;

   function Get_Target_Addr (Msg  : in Buffer_Ptr;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Addr is
         function Get_Value is new Get_Target_Value (MAT.Types.Target_Addr);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Addr;

   function Get_Target_Uint32 (Msg  : in Buffer_Ptr;
                               Kind : in MAT.Events.Attribute_Type) return MAT.Types.Uint32 is
      function Get_Value is new Get_Target_Value (MAT.Types.Target_Addr);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Uint32;

end MAT.Readers.Marshaller;

-----------------------------------------------------------------------
--  Ipc -- Ipc channel between profiler tool and application          --
--  Copyright (C) 2014 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Interfaces;
with System; use System;
with System.Address_To_Access_Conversions;
with System.Storage_Elements;
with Util.Log.Loggers;
with Interfaces; use Interfaces;
package body MAT.Readers.Marshaller is

   use System.Storage_Elements;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Readers.Marshaller");

   package Uint8_Access is new System.Address_To_Access_Conversions (MAT.Types.Uint8);

   package Uint32_Access is new System.Address_To_Access_Conversions (MAT.Types.Uint32);

   function Get_Raw_Uint32 (Buf : System.Address) return MAT.Types.Uint32 is
      use Uint32_Access;

      P : constant Object_Pointer := To_Pointer (Buf);
   begin
      return P.all;
   end Get_Raw_Uint32;

   --  ------------------------------
   --  Get an 8-bit value from the buffer.
   --  ------------------------------
   function Get_Uint8 (Buffer : in Buffer_Ptr) return MAT.Types.Uint8 is
      use Uint8_Access;

      P : constant Object_Pointer := To_Pointer (Buffer.Current);
   begin
      if Buffer.Size = 0 then
         Log.Error ("Not enough data to get a uint8");
         raise Buffer_Underflow_Error;
      end if;
      Buffer.Size := Buffer.Size - 1;
      Buffer.Current := Buffer.Current + Storage_Offset (1);
      return P.all;
   end Get_Uint8;

   --  ------------------------------
   --  Get a 16-bit value either from big-endian or little endian.
   --  ------------------------------
   function Get_Uint16 (Buffer : in Buffer_Ptr) return MAT.Types.Uint16 is
      use Uint8_Access;

      High : Object_Pointer;
      Low  : Object_Pointer;
   begin
      if Buffer.Size <= 1 then
         Log.Error ("Not enough data to get a uint16");
         raise Buffer_Underflow_Error;
      end if;
      if Buffer.Endian = LITTLE_ENDIAN then
         Low  := To_Pointer (Buffer.Current);
         High := To_Pointer (Buffer.Current + Storage_Offset (1));
      else
         High := To_Pointer (Buffer.Current);
         Low  := To_Pointer (Buffer.Current + Storage_Offset (1));
      end if;
      Buffer.Size := Buffer.Size - 2;
      Buffer.Current := Buffer.Current + Storage_Offset (2);
      return MAT.Types.Uint16 (High.all) * 256 + MAT.Types.Uint16 (Low.all);
   end Get_Uint16;

   --  ------------------------------
   --  Get a 32-bit value either from big-endian or little endian.
   --  ------------------------------
   function Get_Uint32 (Buffer : in Buffer_Ptr) return MAT.Types.Uint32 is
      use Uint32_Access;

      Low, High : MAT.Types.Uint16;
   begin
      if Buffer.Size < 4 then
         Log.Error ("Not enough data to get a uint32");
         raise Buffer_Underflow_Error;
      end if;
      if Buffer.Endian = LITTLE_ENDIAN then
         Low  := Get_Uint16 (Buffer);
         High := Get_Uint16 (Buffer);
      else
         High := Get_Uint16 (Buffer);
         Low  := Get_Uint16 (Buffer);
      end if;
      return Interfaces.Shift_Left (MAT.Types.Uint32 (High), 16) + MAT.Types.Uint32 (Low);
   end Get_Uint32;

   --  ------------------------------
   --  Get a 64-bit value either from big-endian or little endian.
   --  ------------------------------
   function Get_Uint64 (Buffer : in Buffer_Ptr) return MAT.Types.Uint64 is
      Low : MAT.Types.Uint32;
      High : MAT.Types.Uint32;
   begin
      if Buffer.Endian = LITTLE_ENDIAN then
         Low := Get_Uint32 (Buffer);
         High := Get_Uint32 (Buffer);
      else
         High := Get_Uint32 (Buffer);
         Low  := Get_Uint32 (Buffer);
      end if;
      return Interfaces.Shift_Left (MAT.Types.Uint64 (High), 32) + MAT.Types.Uint64 (Low);
   end Get_Uint64;

   function Get_Target_Value (Msg  : in Buffer_Ptr;
                              Kind : in MAT.Events.Attribute_Type) return Target_Type is
   begin
      case Kind is
         when MAT.Events.T_UINT8 =>
            return Target_Type (Get_Uint8 (Msg));

         when MAT.Events.T_UINT16 =>
            return Target_Type (Get_Uint16 (Msg));

         when MAT.Events.T_UINT32 =>
            return Target_Type (Get_Uint32 (Msg));

         when MAT.Events.T_UINT64 =>
            return Target_Type (Get_Uint64 (Msg));

         when others =>
            Log.Error ("Invalid attribute type {0}",
                       MAT.Events.Attribute_Type'Image (Kind));
            return 0;
      end case;
   end Get_Target_Value;

   --  ------------------------------
   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   --  ------------------------------
   function Get_String (Buffer : in Buffer_Ptr) return String is
      Len    : constant MAT.Types.Uint8 := Get_Uint8 (Buffer);
      Result : String (1 .. Natural (Len));
   begin
      for I in Result'Range loop
         Result (I) := Character'Val (Get_Uint8 (Buffer));
      end loop;
      return Result;
   end Get_String;

   --  ------------------------------
   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   --  ------------------------------
   function Get_String (Msg : in Buffer_Ptr) return Ada.Strings.Unbounded.Unbounded_String is
   begin
      return Ada.Strings.Unbounded.To_Unbounded_String (Get_String (Msg));
   end Get_String;

   --  ------------------------------
   --  Skip the given number of bytes from the message.
   --  ------------------------------
   procedure Skip (Buffer : in Buffer_Ptr;
                   Size   : in Natural) is
   begin
      Buffer.Size := Buffer.Size - Size;
      Buffer.Current := Buffer.Current + Storage_Offset (Size);
   end Skip;

   function Get_Target_Size (Msg  : in Buffer_Ptr;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Size is
         function Get_Value is new Get_Target_Value (MAT.Types.Target_Size);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Size;

   function Get_Target_Addr (Msg  : in Buffer_Ptr;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Addr is
         function Get_Value is new Get_Target_Value (MAT.Types.Target_Addr);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Addr;

   function Get_Target_Uint32 (Msg  : in Buffer_Ptr;
                               Kind : in MAT.Events.Attribute_Type) return MAT.Types.Uint32 is
      function Get_Value is new Get_Target_Value (MAT.Types.Target_Addr);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Uint32;

end MAT.Readers.Marshaller;

Fix Get_Uint64 to support big and little endian formats


-----------------------------------------------------------------------
--  awa-comments-logic -- Comments management
--  Copyright (C) 2009, 2010, 2011 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with AWA.Services.Contexts;
with ADO.Sessions;
with ADO.Sessions.Entities;

with Ada.Calendar;

with Util.Log.Loggers;

package body AWA.Comments.Services is

   use Util.Log;
   use ADO.Sessions;
   use AWA.Services;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Comments.Services");

   --  ------------------------------
   --  Create a comment associated with the given database entity.
   --  The user must have permission to add comments on the given entity.
   --  ------------------------------
   procedure Create_Comment (Model   : in Comment_Service;
                             Entity  : in ADO.Objects.Object_Key;
                             Message : in String;
                             User    : in AWA.Users.Models.User_Ref'Class;
                             Result  : out ADO.Identifier) is
      pragma Unreferenced (Model);

      Ctx       : constant Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB        : Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Comment   : Comment_Ref;
      Entity_Id : constant ADO.Identifier := ADO.Objects.Get_Value (Entity);
   begin
      Log.Info ("Create comment for user {0}", String'(User.Get_Name));

   --
   --  select from asset inner join acl
   --    on asset.collection_id = acl.entity_id and acl.entity_type = :entity_type
   --    where asset.id = :entity_id and acl.user_id = :user_id
--        AWA.Permissions.Module.Check (Entity => Entity, Permission => CREATE_COMMENT);
      Ctx.Start;
      Comment.Set_Message (Message);
      Comment.Set_Entity_Id (Entity_Id);
      Comment.Set_Entity_Type (ADO.Sessions.Entities.Find_Entity_Type (DB, Entity));
      Comment.Set_User (User);
      Comment.Set_Date (Ada.Calendar.Clock);
      Comment.Save (DB);
      Ctx.Commit;
      Result := Comment.Get_Id;

      Log.Info ("Comment {0} created", ADO.Identifier'Image (Result));
   end Create_Comment;

   procedure Find_Comment (Model   : in Comment_Service;
                           Id      : in ADO.Identifier;
                           Comment : in out Comment_Ref'Class) is
   begin
      null;
   end Find_Comment;

   --  ------------------------------
   --  Delete the comment identified by the given identifier.
   --  ------------------------------
   procedure Delete_Comment (Model   : in Comment_Service;
                             Id      : in ADO.Identifier) is
      pragma Unreferenced (Model);

      Ctx       : constant Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB        : Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Comment   : Comment_Ref;
   begin
      Log.Info ("Delete comment {0}", ADO.Identifier'Image (Id));

      --        AWA.Permissions.Module.Check (Entity => Entity, Permission => CREATE_COMMENT);
      Ctx.Start;
      Comment.Set_Id (Id);
      Comment.Delete (DB);
      Ctx.Commit;
   end Delete_Comment;

end AWA.Comments.Services;

-----------------------------------------------------------------------
--  awa-comments-logic -- Comments management
--  Copyright (C) 2009, 2010, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with AWA.Services.Contexts;
with ADO.Sessions;
with ADO.Sessions.Entities;

with Ada.Calendar;

with Util.Log.Loggers;

package body AWA.Comments.Services is

   use Util.Log;
   use ADO.Sessions;
   use AWA.Services;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Comments.Services");

   --  ------------------------------
   --  Create a comment associated with the given database entity.
   --  The user must have permission to add comments on the given entity.
   --  ------------------------------
   procedure Create_Comment (Model   : in Comment_Service;
                             Entity  : in ADO.Objects.Object_Key;
                             Message : in String;
                             User    : in AWA.Users.Models.User_Ref'Class;
                             Result  : out ADO.Identifier) is
      pragma Unreferenced (Model);

      Ctx       : constant Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB        : Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Comment   : Comment_Ref;
      Entity_Id : constant ADO.Identifier := ADO.Objects.Get_Value (Entity);
   begin
      Log.Info ("Create comment for user {0}", String'(User.Get_Name));

   --
   --  select from asset inner join acl
   --    on asset.collection_id = acl.entity_id and acl.entity_type = :entity_type
   --    where asset.id = :entity_id and acl.user_id = :user_id
--        AWA.Permissions.Module.Check (Entity => Entity, Permission => CREATE_COMMENT);
      Ctx.Start;
      Comment.Set_Message (Message);
      Comment.Set_Entity_Id (Entity_Id);
      Comment.Set_Entity_Type (ADO.Sessions.Entities.Find_Entity_Type (DB, Entity));
      Comment.Set_Author (User);
      Comment.Set_Date (Ada.Calendar.Clock);
      Comment.Save (DB);
      Ctx.Commit;
      Result := Comment.Get_Id;

      Log.Info ("Comment {0} created", ADO.Identifier'Image (Result));
   end Create_Comment;

   procedure Find_Comment (Model   : in Comment_Service;
                           Id      : in ADO.Identifier;
                           Comment : in out Comment_Ref'Class) is
   begin
      null;
   end Find_Comment;

   --  ------------------------------
   --  Delete the comment identified by the given identifier.
   --  ------------------------------
   procedure Delete_Comment (Model   : in Comment_Service;
                             Id      : in ADO.Identifier) is
      pragma Unreferenced (Model);

      Ctx       : constant Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB        : Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Comment   : Comment_Ref;
   begin
      Log.Info ("Delete comment {0}", ADO.Identifier'Image (Id));

      --        AWA.Permissions.Module.Check (Entity => Entity, Permission => CREATE_COMMENT);
      Ctx.Start;
      Comment.Set_Id (Id);
      Comment.Delete (DB);
      Ctx.Commit;
   end Delete_Comment;

end AWA.Comments.Services;

Update the implementation according to the UML model


-----------------------------------------------------------------------
--  awa-blogs-beans -- Beans for blog module
--  Copyright (C) 2011, 2012, 2013, 2014, 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Strings.Unbounded;

with Util.Beans.Basic;
with Util.Beans.Objects;

with ADO;
with ADO.Objects;

with AWA.Blogs.Modules;
with AWA.Blogs.Models;
with AWA.Tags.Beans;
with AWA.Counters.Beans;

--  == Blog Beans ==
--  Several bean types are provided to represent and manage the blogs and their posts.
--  The blog module registers the bean constructors when it is initialized.
--  To use them, one must declare a bean definition in the application XML configuration.
package AWA.Blogs.Beans is

   --  Attributes exposed by Post_Bean
   BLOG_ID_ATTR      : constant String := "blogId";
   POST_ID_ATTR      : constant String := "id";
   POST_UID_ATTR     : constant String := "uid";
   POST_TITLE_ATTR   : constant String := "title";
   POST_TEXT_ATTR    : constant String := "text";
   POST_URI_ATTR     : constant String := "uri";
   POST_STATUS_ATTR  : constant String := "status";
   POST_USERNAME_ATTR : constant String := "username";
   POST_TAG_ATTR      : constant String := "tags";
   POST_ALLOW_COMMENTS_ATTR : constant String := "allow_comments";
   COUNTER_ATTR             : constant String := "counter";

   --  ------------------------------
   --  Blog Bean
   --  ------------------------------
   --  The Blog_Bean holds the information about the current blog.
   --  It allows to create the blog as well as update its primary title.
   type Blog_Bean is new AWA.Blogs.Models.Blog_Bean with record
      Module  : AWA.Blogs.Modules.Blog_Module_Access := null;
   end record;
   type Blog_Bean_Access is access all Blog_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Blog_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Create a new blog.
   overriding
   procedure Create (Bean    : in out Blog_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Blog_Bean bean instance.
   function Create_Blog_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access;

   --  ------------------------------
   --  Post Bean
   --  ------------------------------
   --  The Post_Bean is used to create or update a post associated with a blog.
   type Post_Bean is new AWA.Blogs.Models.Post_Bean with record
      Module  : AWA.Blogs.Modules.Blog_Module_Access := null;
      Blog_Id : ADO.Identifier;

      --  List of tags associated with the post.
      Tags      : aliased AWA.Tags.Beans.Tag_List_Bean;
      Tags_Bean : Util.Beans.Basic.Readonly_Bean_Access;

      --  The read post counter associated with the post.
      Counter       : aliased AWA.Counters.Beans.Counter_Bean (Of_Type => ADO.Objects.KEY_INTEGER,
                                                               Of_Class => Models.POST_TABLE);
      Counter_Bean  : Util.Beans.Basic.Readonly_Bean_Access;
   end record;
   type Post_Bean_Access is access all Post_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Post_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Post_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Load the post.
   procedure Load_Post (Post : in out Post_Bean;
                        Id   : in ADO.Identifier);

   --  Create or save the post.
   overriding
   procedure Save (Bean    : in out Post_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Delete a post.
   overriding
   procedure Delete (Bean    : in out Post_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Load the post.
   overriding
   procedure Load (Bean    : in out Post_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Post_Bean bean instance.
   function Create_Post_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access;

   --  ------------------------------
   --  Post List Bean
   --  ------------------------------
   --  The Post_List_Bean gives a list of visible posts to be displayed to users.
   --  The list can be filtered by a given tag.  The list pagination is supported.
   type Post_List_Bean is new AWA.Blogs.Models.Post_List_Bean with record
      Posts      : aliased AWA.Blogs.Models.Post_Info_List_Bean;
      Service    : Modules.Blog_Module_Access := null;
      Tags       : AWA.Tags.Beans.Entity_Tag_Map;
      Posts_Bean : AWA.Blogs.Models.Post_Info_List_Bean_Access;

      --  The read post counter associated with the post.
      Counter       : aliased AWA.Counters.Beans.Counter_Bean (Of_Type => ADO.Objects.KEY_INTEGER,
                                                               Of_Class => Models.POST_TABLE);
      Counter_Bean  : AWA.Counters.Beans.Counter_Bean_Access;
   end record;
   type Post_List_Bean_Access is access all Post_List_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Post_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Post_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   overriding
   procedure Load (From    : in out Post_List_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Load the list of posts.  If a tag was set, filter the list of posts with the tag.
   procedure Load_List (Into : in out Post_List_Bean);

   --  Create the Post_List_Bean bean instance.
   function Create_Post_List_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access;

   --  Get a select item list which contains a list of post status.
   function Create_Status_List (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access;

   type Init_Flag is (INIT_BLOG_LIST, INIT_POST_LIST, INIT_COMMENT_LIST);
   type Init_Map is array (Init_Flag) of Boolean;

   --  ------------------------------
   --  Admin List Bean
   --  ------------------------------
   --  The Blog_Admin_Bean is used for the administration of a blog.  It gives the
   --  list of posts that are created, published or not.
   type Blog_Admin_Bean is new Util.Beans.Basic.Bean with record
      Module : AWA.Blogs.Modules.Blog_Module_Access := null;

      --  The blog identifier.
      Blog_Id          : ADO.Identifier := ADO.NO_IDENTIFIER;

      --  List of blogs.
      Blog_List        : aliased AWA.Blogs.Models.Blog_Info_List_Bean;
      Blog_List_Bean   : AWA.Blogs.Models.Blog_Info_List_Bean_Access;

      --  List of posts.
      Post_List        : aliased AWA.Blogs.Models.Admin_Post_Info_List_Bean;
      Post_List_Bean   : AWA.Blogs.Models.Admin_Post_Info_List_Bean_Access;

      --  List of comments.
      Comment_List      : aliased AWA.Blogs.Models.Comment_Info_List_Bean;
      Comment_List_Bean : AWA.Blogs.Models.Comment_Info_List_Bean_Access;

      --  Initialization flags.
      Init_Flags       : aliased Init_Map := (others => False);
      Flags            : access Init_Map;
   end record;
   type Blog_Admin_Bean_Access is access all Blog_Admin_Bean;

   --  Get the blog identifier.
   function Get_Blog_Id (List : in Blog_Admin_Bean) return ADO.Identifier;

   --  Load the posts associated with the current blog.
   procedure Load_Posts (List : in Blog_Admin_Bean);

   --  Load the comments associated with the current blog.
   procedure Load_Comments (List : in Blog_Admin_Bean);

   overriding
   function Get_Value (List : in Blog_Admin_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Blog_Admin_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Load the list of blogs.
   procedure Load_Blogs (List : in Blog_Admin_Bean);

   --  Create the Blog_Admin_Bean bean instance.
   function Create_Blog_Admin_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                    return Util.Beans.Basic.Readonly_Bean_Access;

end AWA.Blogs.Beans;

-----------------------------------------------------------------------
--  awa-blogs-beans -- Beans for blog module
--  Copyright (C) 2011, 2012, 2013, 2014, 2015, 2016 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Strings.Unbounded;

with Util.Beans.Basic;
with Util.Beans.Objects;

with ADO;
with ADO.Objects;

with AWA.Blogs.Modules;
with AWA.Blogs.Models;
with AWA.Tags.Beans;
with AWA.Counters.Beans;

--  == Blog Beans ==
--  Several bean types are provided to represent and manage the blogs and their posts.
--  The blog module registers the bean constructors when it is initialized.
--  To use them, one must declare a bean definition in the application XML configuration.
package AWA.Blogs.Beans is

   --  Attributes exposed by Post_Bean
   BLOG_ID_ATTR      : constant String := "blogId";
   POST_ID_ATTR      : constant String := "id";
   POST_UID_ATTR     : constant String := "uid";
   POST_TITLE_ATTR   : constant String := "title";
   POST_TEXT_ATTR    : constant String := "text";
   POST_URI_ATTR     : constant String := "uri";
   POST_STATUS_ATTR  : constant String := "status";
   POST_USERNAME_ATTR : constant String := "username";
   POST_TAG_ATTR      : constant String := "tags";
   POST_ALLOW_COMMENTS_ATTR : constant String := "allow_comments";
   COUNTER_ATTR             : constant String := "counter";

   --  ------------------------------
   --  Blog Bean
   --  ------------------------------
   --  The Blog_Bean holds the information about the current blog.
   --  It allows to create the blog as well as update its primary title.
   type Blog_Bean is new AWA.Blogs.Models.Blog_Bean with record
      Module  : AWA.Blogs.Modules.Blog_Module_Access := null;
   end record;
   type Blog_Bean_Access is access all Blog_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Blog_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Create a new blog.
   overriding
   procedure Create (Bean    : in out Blog_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Blog_Bean bean instance.
   function Create_Blog_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access;

   --  ------------------------------
   --  Post Bean
   --  ------------------------------
   --  The Post_Bean is used to create or update a post associated with a blog.
   type Post_Bean is new AWA.Blogs.Models.Post_Bean with record
      Module  : AWA.Blogs.Modules.Blog_Module_Access := null;
      Blog_Id : ADO.Identifier;

      --  List of tags associated with the post.
      Tags      : aliased AWA.Tags.Beans.Tag_List_Bean;
      Tags_Bean : Util.Beans.Basic.Readonly_Bean_Access;

      --  The read post counter associated with the post.
      Counter       : aliased AWA.Counters.Beans.Counter_Bean (Of_Type => ADO.Objects.KEY_INTEGER,
                                                               Of_Class => Models.POST_TABLE);
      Counter_Bean  : Util.Beans.Basic.Readonly_Bean_Access;
   end record;
   type Post_Bean_Access is access all Post_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Post_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Post_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Load the post.
   procedure Load_Post (Post : in out Post_Bean;
                        Id   : in ADO.Identifier);

   --  Create or save the post.
   overriding
   procedure Save (Bean    : in out Post_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Delete a post.
   overriding
   procedure Delete (Bean    : in out Post_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Load the post.
   overriding
   procedure Load (Bean    : in out Post_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Post_Bean bean instance.
   function Create_Post_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access;

   --  ------------------------------
   --  Post List Bean
   --  ------------------------------
   --  The Post_List_Bean gives a list of visible posts to be displayed to users.
   --  The list can be filtered by a given tag.  The list pagination is supported.
   type Post_List_Bean is new AWA.Blogs.Models.Post_List_Bean with record
      Posts      : aliased AWA.Blogs.Models.Post_Info_List_Bean;
      Service    : Modules.Blog_Module_Access := null;
      Tags       : AWA.Tags.Beans.Entity_Tag_Map;
      Posts_Bean : AWA.Blogs.Models.Post_Info_List_Bean_Access;

      --  The read post counter associated with the post.
      Counter       : aliased AWA.Counters.Beans.Counter_Bean (Of_Type => ADO.Objects.KEY_INTEGER,
                                                               Of_Class => Models.POST_TABLE);
      Counter_Bean  : AWA.Counters.Beans.Counter_Bean_Access;
   end record;
   type Post_List_Bean_Access is access all Post_List_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Post_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Post_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   overriding
   procedure Load (From    : in out Post_List_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Load the list of posts.  If a tag was set, filter the list of posts with the tag.
   procedure Load_List (Into : in out Post_List_Bean);

   --  Create the Post_List_Bean bean instance.
   function Create_Post_List_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access;

   --  Get a select item list which contains a list of post status.
   function Create_Status_List (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access;

   type Init_Flag is (INIT_BLOG_LIST, INIT_POST_LIST, INIT_COMMENT_LIST);
   type Init_Map is array (Init_Flag) of Boolean;

   --  ------------------------------
   --  Admin List Bean
   --  ------------------------------
   --  The Blog_Admin_Bean is used for the administration of a blog.  It gives the
   --  list of posts that are created, published or not.
   type Blog_Admin_Bean is new Util.Beans.Basic.Bean with record
      Module : AWA.Blogs.Modules.Blog_Module_Access := null;

      --  The blog identifier.
      Blog_Id          : ADO.Identifier := ADO.NO_IDENTIFIER;

      --  List of blogs.
      Blog_List        : aliased AWA.Blogs.Models.Blog_Info_List_Bean;
      Blog_List_Bean   : AWA.Blogs.Models.Blog_Info_List_Bean_Access;

      --  List of posts.
      Post_List        : aliased AWA.Blogs.Models.Admin_Post_Info_List_Bean;
      Post_List_Bean   : AWA.Blogs.Models.Admin_Post_Info_List_Bean_Access;

      --  List of comments.
      Comment_List      : aliased AWA.Blogs.Models.Comment_Info_List_Bean;
      Comment_List_Bean : AWA.Blogs.Models.Comment_Info_List_Bean_Access;

      --  Initialization flags.
      Init_Flags       : aliased Init_Map := (others => False);
      Flags            : access Init_Map;
   end record;
   type Blog_Admin_Bean_Access is access all Blog_Admin_Bean;

   --  Get the blog identifier.
   function Get_Blog_Id (List : in Blog_Admin_Bean) return ADO.Identifier;

   --  Load the posts associated with the current blog.
   procedure Load_Posts (List : in Blog_Admin_Bean);

   --  Load the comments associated with the current blog.
   procedure Load_Comments (List : in Blog_Admin_Bean);

   overriding
   function Get_Value (List : in Blog_Admin_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Blog_Admin_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Load the list of blogs.
   procedure Load_Blogs (List : in Blog_Admin_Bean);

   --  Create the Blog_Admin_Bean bean instance.
   function Create_Blog_Admin_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                    return Util.Beans.Basic.Readonly_Bean_Access;

   --  ------------------------------
   --  Blog Statistics Bean
   --  ------------------------------
   --  The Blog_Stat_Bean is used to report various statistics about the blog or some post.
   type Blog_Stat_Bean is new AWA.Blogs.Models.Stat_List_Bean with record
      Module           : AWA.Blogs.Modules.Blog_Module_Access := null;

      Stats            : aliased AWA.Blogs.Models.Month_Stat_Info_List_Bean;
      Stats_Bean       : AWA.Blogs.Models.Month_Stat_Info_List_Bean_Access;
   end record;
   type Blog_Stat_Bean_Access is access all Blog_Stat_Bean;

   overriding
   function Get_Value (List : in Blog_Stat_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Blog_Stat_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Load the statistics information.
   overriding
   procedure Load (List    : in out Blog_Stat_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Blog_Stat_Bean bean instance.
   function Create_Blog_Stat_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                    return Util.Beans.Basic.Readonly_Bean_Access;

end AWA.Blogs.Beans;

Declare the Blog_Stat_Bean type with Get_Value, Set_Value, Load operation


-----------------------------------------------------------------------
--  security-random-tests - Tests for random package
--  Copyright (C) 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Tests;
package Security.Random.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   procedure Test_Generate (T : in out Test);

end Security.Random.Tests;

-----------------------------------------------------------------------
--  security-random-tests - Tests for random package
--  Copyright (C) 2017, 2022 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Tests;
package Security.Random.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   procedure Test_Generate (T : in out Test);

   procedure Test_Generate_String (T : in out Test);

end Security.Random.Tests;

Declare Test_Generate_String procedure

Declare Test_Generate_String procedure


-----------------------------------------------------------------------
--  druss-commands-devices -- Print information about the devices
--  Copyright (C) 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Properties;
with Bbox.API;
with Druss.Gateways;
package body Druss.Commands.Devices is

   --  ------------------------------
   --  Execute the wifi 'status' command to print the Wifi current status.
   --  ------------------------------
   procedure Do_List (Command   : in Command_Type;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Command, Args);
      procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type);

      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;

      procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type) is
         procedure Print_Device (Manager : in Util.Properties.Manager;
                                 Name    : in String);

         procedure Print_Device (Manager : in Util.Properties.Manager;
                                 Name    : in String) is
            Link : constant String := Manager.Get (Name & ".link", "");
            Kind : constant String := Manager.Get (Name & ".devicetype", "");
         begin
            if Manager.Get (Name & ".active", "") = "0" then
               return;
            end if;
            Console.Start_Row;
            Console.Print_Field (F_BBOX_IP_ADDR, Gateway.Ip);
            Console.Print_Field (F_IP_ADDR, Manager.Get (Name & ".ipaddress", ""));
            Console.Print_Field (F_ETHERNET, Manager.Get (Name & ".macaddress", ""));
            Console.Print_Field (F_HOSTNAME, Manager.Get (Name & ".hostname", ""));
            Console.Print_Field (F_ACTIVE, Manager.Get (Name & ".active", ""));
            Console.Print_Field (F_DEVTYPE, (if Kind = "STB" then "STB" else ""));
            if Link = "Ethernet" then
               Console.Print_Field (F_LINK, Link & " port "
                                    & Manager.Get (Name & ".ethernet.logicalport", ""));
            else
               Console.Print_Field (F_LINK, Link & " RSSI "
                                    & Manager.Get (Name & ".wireless.rssi0", ""));
            end if;
            Console.End_Row;
         end Print_Device;

      begin
         Gateway.Refresh;

         Bbox.API.Iterate (Gateway.Hosts, "hosts.list", Print_Device'Access);
      end Box_Status;

   begin
      Console.Start_Title;
      Console.Print_Title (F_BBOX_IP_ADDR, "Bbox IP", 16);
      Console.Print_Title (F_IP_ADDR, "Device IP", 16);
      Console.Print_Title (F_ETHERNET, "Ethernet", 20);
      Console.Print_Title (F_HOSTNAME, "Hostname", 28);
      Console.Print_Title (F_DEVTYPE, "Type", 6);
      --  Console.Print_Title (F_ACTIVE, "Active", 8);
      Console.Print_Title (F_LINK, "Link", 18);
      Console.End_Title;
      Druss.Gateways.Iterate (Context.Gateways, Gateways.ITER_ENABLE, Box_Status'Access);
   end Do_List;

   --  ------------------------------
   --  Execute a status command to report information about the Bbox.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Name);
   begin
      Command.Do_List (Args, Context);
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type) is
      pragma Unreferenced (Command);
      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;
   begin
      Console.Notice (N_HELP, "devices: Print information about the devices");
      Console.Notice (N_HELP, "Usage: devices [options]");
      Console.Notice (N_HELP, "");
   end Help;

end Druss.Commands.Devices;

-----------------------------------------------------------------------
--  druss-commands-devices -- Print information about the devices
--  Copyright (C) 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Properties;
with Bbox.API;
with Druss.Gateways;
package body Druss.Commands.Devices is

   --  ------------------------------
   --  Execute the wifi 'status' command to print the Wifi current status.
   --  ------------------------------
   procedure Do_List (Command   : in Command_Type;
                      Args      : in Argument_List'Class;
                      Selector  : in Device_Selector_Type;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Command, Args);
      procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type);

      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;

      procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type) is
         procedure Print_Device (Manager : in Util.Properties.Manager;
                                 Name    : in String);

         procedure Print_Device (Manager : in Util.Properties.Manager;
                                 Name    : in String) is
            Link : constant String := Manager.Get (Name & ".link", "");
            Kind : constant String := Manager.Get (Name & ".devicetype", "");
         begin
            case Selector is
               when DEVICE_ALL =>
                  null;

               when DEVICE_ACTIVE =>
                  if Manager.Get (Name & ".active", "") = "0" then
                     return;
                  end if;

               when DEVICE_INACTIVE =>
                  if Manager.Get (Name & ".active", "") = "1" then
                     return;
                  end if;

            end case;

            Console.Start_Row;
            Console.Print_Field (F_BBOX_IP_ADDR, Gateway.Ip);
            Console.Print_Field (F_IP_ADDR, Manager.Get (Name & ".ipaddress", ""));
            Console.Print_Field (F_ETHERNET, Manager.Get (Name & ".macaddress", ""));
            Console.Print_Field (F_HOSTNAME, Manager.Get (Name & ".hostname", ""));
            Console.Print_Field (F_ACTIVE, Manager.Get (Name & ".active", ""));
            Console.Print_Field (F_DEVTYPE, (if Kind = "STB" then "STB" else ""));
            if Link = "Ethernet" then
               Console.Print_Field (F_LINK, Link & " port "
                                    & Manager.Get (Name & ".ethernet.logicalport", ""));
            else
               Console.Print_Field (F_LINK, Link & " RSSI "
                                    & Manager.Get (Name & ".wireless.rssi0", ""));
            end if;
            Console.End_Row;
         end Print_Device;

      begin
         Gateway.Refresh;

         Bbox.API.Iterate (Gateway.Hosts, "hosts.list", Print_Device'Access);
      end Box_Status;

   begin
      Console.Start_Title;
      Console.Print_Title (F_BBOX_IP_ADDR, "Bbox IP", 16);
      Console.Print_Title (F_IP_ADDR, "Device IP", 16);
      Console.Print_Title (F_ETHERNET, "Ethernet", 20);
      Console.Print_Title (F_HOSTNAME, "Hostname", 28);
      Console.Print_Title (F_DEVTYPE, "Type", 6);
      --  Console.Print_Title (F_ACTIVE, "Active", 8);
      Console.Print_Title (F_LINK, "Link", 18);
      Console.End_Title;
      Druss.Gateways.Iterate (Context.Gateways, Gateways.ITER_ENABLE, Box_Status'Access);
   end Do_List;

   --  ------------------------------
   --  Execute a status command to report information about the Bbox.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Name);
   begin
     if Args.Get_Count > 1 then
         Context.Console.Notice (N_USAGE, "Too many arguments to the command");
         Druss.Commands.Driver.Usage (Args);
      elsif Args.Get_Count = 0 then
         Command.Do_List (Args, DEVICE_ACTIVE, Context);
      elsif Args.Get_Argument (1) = "all" then
         Command.Do_List (Args, DEVICE_ALL, Context);
      elsif Args.Get_Argument (1) = "active" then
         Command.Do_List (Args, DEVICE_ACTIVE, Context);
      elsif Args.Get_Argument (1) = "inactive" then
         Command.Do_List (Args, DEVICE_INACTIVE, Context);
      else
         Context.Console.Notice (N_USAGE, "Invalid argument: " & Args.Get_Argument (1));
         Druss.Commands.Driver.Usage (Args);
      end if;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type) is
      pragma Unreferenced (Command);
      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;
   begin
      Console.Notice (N_HELP, "devices: Print information about the devices");
      Console.Notice (N_HELP, "Usage: devices [all | active | inactive]");
      Console.Notice (N_HELP, "");
      Console.Notice (N_HELP, "  List the devices that are known by the Bbox.");
      Console.Notice (N_HELP, "");
      Console.Notice (N_HELP, "    all        List all the devices");
      Console.Notice (N_HELP, "    active     List the active devices (the default)");
      Console.Notice (N_HELP, "    inative    List the inactive devices");
   end Help;

end Druss.Commands.Devices;

Add a device selector to the do_List command List only the active, inactive or all the devices


-----------------------------------------------------------------------
--  wiki-helpers -- Helper operations for wiki parsers and renderer
--  Copyright (C) 2016, 2020, 2022 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Wide_Wide_Characters.Handling;
with Ada.Wide_Wide_Characters.Unicode;
package body Wiki.Helpers is

   --  ------------------------------
   --  Returns True if the character is a space or tab.
   --  ------------------------------
   function Is_Space (C : in Wiki.Strings.WChar) return Boolean is
   begin
      return Ada.Wide_Wide_Characters.Handling.Is_Space (C) or C = HT or C = NBSP;
   end Is_Space;

   --  ------------------------------
   --  Returns True if the character is a space, tab or a newline.
   --  ------------------------------
   function Is_Space_Or_Newline (C : in Wiki.Strings.WChar) return Boolean is
   begin
      return Is_Space (C) or Ada.Wide_Wide_Characters.Handling.Is_Line_Terminator (C);
   end Is_Space_Or_Newline;

   --  ------------------------------
   --  Returns True if the character is a punctuation character.
   --  ------------------------------
   function Is_Punctuation (C : in Wiki.Strings.WChar) return Boolean is
   begin
      return Ada.Wide_Wide_Characters.Unicode.Is_Punctuation (C);
   end Is_Punctuation;

   --  ------------------------------
   --  Returns True if the character is a line terminator.
   --  ------------------------------
   function Is_Newline (C : in Wiki.Strings.WChar) return Boolean is
   begin
      return Ada.Wide_Wide_Characters.Handling.Is_Line_Terminator (C);
   end Is_Newline;

   --  ------------------------------
   --  Returns True if the text is a valid URL
   --  ------------------------------
   function Is_Url (Text : in Wiki.Strings.WString) return Boolean is
   begin
      if Text'Length <= 9 then
         return False;
      else
         return Text (Text'First .. Text'First + 6) = "http://"
           or Text (Text'First .. Text'First + 7) = "https://";
      end if;
   end Is_Url;

   --  ------------------------------
   --  Returns True if the extension part correspond to an image.
   --  Recognized extension are: .png, .gif, .jpg, .jpeg.
   --  The extension case is ignored.
   --  ------------------------------
   function Is_Image_Extension (Ext : in Wiki.Strings.WString) return Boolean is
      S : constant Wiki.Strings.WString := Ada.Wide_Wide_Characters.Handling.To_Lower (Ext);
   begin
      return S = ".png" or S = ".jpg" or S = ".gif" or S = ".jpeg";
   end Is_Image_Extension;

   --  ------------------------------
   --  Given the current tag on the top of the stack and the new tag that will be pushed,
   --  decide whether the current tag must be closed or not.
   --  Returns True if the current tag must be closed.
   --  ------------------------------
   function Need_Close (Tag         : in Html_Tag;
                        Current_Tag : in Html_Tag) return Boolean is
   begin
      if No_End_Tag (Current_Tag) then
         return True;
      elsif Current_Tag = Tag and Tag_Omission (Current_Tag) then
         return True;
      else
         case Current_Tag is
            when DT_TAG | DD_TAG =>
               return Tag = DD_TAG or Tag = DL_TAG or Tag = DT_TAG;

            when TD_TAG =>
               return Tag = TD_TAG or Tag = TR_TAG or Tag = TH_TAG;

            when TR_TAG =>
               return False;

            when others =>
               return False;

         end case;
      end if;
   end Need_Close;

   --  ------------------------------
   --  Get the dimension represented by the string.  The string has one of the following
   --  formats:
   --    original           -> Width, Height := Natural'Last
   --    default            -> Width := 800, Height := 0
   --    upright            -> Width := 800, Height := 0
   --    <width>px          -> Width := <width>, Height := 0
   --    x<height>px        -> Width := 0, Height := <height>
   --    <width>x<height>px -> Width := <width>, Height := <height>
   --  ------------------------------
   procedure Get_Sizes (Dimension : in Wiki.Strings.WString;
                        Width     : out Natural;
                        Height    : out Natural) is
      Pos  : Natural;
      Last : Natural;
   begin
      if Dimension = "original" then
         Width  := Natural'Last;
         Height := Natural'Last;
      elsif Dimension = "default" or Dimension = "upright" then
         Width  := 800;
         Height := 0;
      else
         Pos  := Wiki.Strings.Index (Dimension, "x");
         Last := Wiki.Strings.Index (Dimension, "px");
         if Pos > Dimension'First and Last + 1 /= Pos then
            Width := Natural'Wide_Wide_Value (Dimension (Dimension'First .. Pos - 1));
         elsif Last > 0 then
            Width := Natural'Wide_Wide_Value (Dimension (Dimension'First .. Last - 1));
         else
            Width := 0;
         end if;
         if Pos < Dimension'Last then
            Height := Natural'Wide_Wide_Value (Dimension (Pos + 1 .. Last - 1));
         else
            Height := 0;
         end if;
      end if;

   exception
      when Constraint_Error =>
         Width  := 0;
         Height := 0;
   end Get_Sizes;

   --  ------------------------------
   --  Find the position of the first non space character in the text starting at the
   --  given position.  Returns Text'Last + 1 if the text only contains spaces.
   --  ------------------------------
   function Skip_Spaces (Text : in Wiki.Strings.Wstring;
                         From : in Positive) return Positive is
      Pos : Positive := From;
   begin
      while Pos <= Text'Last and then Is_Space (Text (Pos)) loop
         Pos := Pos + 1;
      end loop;
      return Pos;
   end Skip_Spaces;

   --  ------------------------------
   --  Find the position of the last non space character scanning the text backward
   --  from the given position.  Returns Text'First - 1 if the text only contains spaces.
   --  ------------------------------
   function Trim_Spaces (Text : in Wiki.Strings.Wstring;
                         From : in Positive) return Natural is
      Pos : Natural := From;
   begin
      while Pos >= Text'First and then Is_Space (Text (Pos)) loop
         Pos := Pos - 1;
      end loop;
      return Pos;
   end Trim_Spaces;

   --  ------------------------------
   --  Find the position of the given character in the string starting at the given position.
   --  ------------------------------
   function Index (Text : in Wiki.Strings.Wstring;
                   Item : in Wiki.Strings.Wchar;
                   From : in Positive) return Natural is
      Pos : Natural := From;
   begin
      while Pos <= Text'Last loop
         if Text (Pos) = Item then
            return Pos;
         end if;
         Pos := Pos + 1;
      end loop;
      return 0;
   end Index;

end Wiki.Helpers;

-----------------------------------------------------------------------
--  wiki-helpers -- Helper operations for wiki parsers and renderer
--  Copyright (C) 2016, 2020, 2022 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Wide_Wide_Characters.Handling;
with Ada.Wide_Wide_Characters.Unicode;
package body Wiki.Helpers is

   --  ------------------------------
   --  Returns True if the character is a space or tab.
   --  ------------------------------
   function Is_Space (C : in Wiki.Strings.WChar) return Boolean is
   begin
      return Ada.Wide_Wide_Characters.Handling.Is_Space (C) or C = HT or C = NBSP;
   end Is_Space;

   --  ------------------------------
   --  Returns True if the character is a space, tab or a newline.
   --  ------------------------------
   function Is_Space_Or_Newline (C : in Wiki.Strings.WChar) return Boolean is
   begin
      return Is_Space (C) or Ada.Wide_Wide_Characters.Handling.Is_Line_Terminator (C);
   end Is_Space_Or_Newline;

   --  ------------------------------
   --  Returns True if the character is a punctuation character.
   --  ------------------------------
   function Is_Punctuation (C : in Wiki.Strings.WChar) return Boolean is
   begin
      return Ada.Wide_Wide_Characters.Unicode.Is_Punctuation (C);
   end Is_Punctuation;

   --  ------------------------------
   --  Returns True if the character is a line terminator.
   --  ------------------------------
   function Is_Newline (C : in Wiki.Strings.WChar) return Boolean is
   begin
      return Ada.Wide_Wide_Characters.Handling.Is_Line_Terminator (C);
   end Is_Newline;

   --  ------------------------------
   --  Returns True if the text is a valid URL
   --  ------------------------------
   function Is_Url (Text : in Wiki.Strings.WString) return Boolean is
   begin
      if Text'Length <= 9 then
         return False;
      else
         return Text (Text'First .. Text'First + 6) = "http://"
           or Text (Text'First .. Text'First + 7) = "https://";
      end if;
   end Is_Url;

   --  ------------------------------
   --  Returns True if the extension part correspond to an image.
   --  Recognized extension are: .png, .gif, .jpg, .jpeg.
   --  The extension case is ignored.
   --  ------------------------------
   function Is_Image_Extension (Ext : in Wiki.Strings.WString) return Boolean is
      S : constant Wiki.Strings.WString := Ada.Wide_Wide_Characters.Handling.To_Lower (Ext);
   begin
      return S = ".png" or S = ".jpg" or S = ".gif" or S = ".jpeg";
   end Is_Image_Extension;

   --  ------------------------------
   --  Given the current tag on the top of the stack and the new tag that will be pushed,
   --  decide whether the current tag must be closed or not.
   --  Returns True if the current tag must be closed.
   --  ------------------------------
   function Need_Close (Tag         : in Html_Tag;
                        Current_Tag : in Html_Tag) return Boolean is
   begin
      if No_End_Tag (Current_Tag) then
         return True;
      elsif Current_Tag = Tag and Tag_Omission (Current_Tag) then
         return True;
      else
         case Current_Tag is
            when DT_TAG | DD_TAG =>
               return Tag = DD_TAG or Tag = DL_TAG or Tag = DT_TAG;

            when TD_TAG =>
               return Tag = TD_TAG or Tag = TR_TAG or Tag = TH_TAG;

            when TR_TAG =>
               return False;

            when others =>
               return False;

         end case;
      end if;
   end Need_Close;

   --  ------------------------------
   --  Get the dimension represented by the string.  The string has one of the following
   --  formats:
   --    original           -> Width, Height := Natural'Last
   --    default            -> Width := 800, Height := 0
   --    upright            -> Width := 800, Height := 0
   --    <width>px          -> Width := <width>, Height := 0
   --    x<height>px        -> Width := 0, Height := <height>
   --    <width>x<height>px -> Width := <width>, Height := <height>
   --  ------------------------------
   procedure Get_Sizes (Dimension : in Wiki.Strings.WString;
                        Width     : out Natural;
                        Height    : out Natural) is
      Pos  : Natural;
      Last : Natural;
   begin
      if Dimension = "original" then
         Width  := Natural'Last;
         Height := Natural'Last;
      elsif Dimension = "default" or Dimension = "upright" then
         Width  := 800;
         Height := 0;
      else
         Pos  := Wiki.Strings.Index (Dimension, "x");
         Last := Wiki.Strings.Index (Dimension, "px");
         if Pos > Dimension'First and Last + 1 /= Pos then
            Width := Natural'Wide_Wide_Value (Dimension (Dimension'First .. Pos - 1));
         elsif Last > 0 then
            Width := Natural'Wide_Wide_Value (Dimension (Dimension'First .. Last - 1));
         else
            Width := 0;
         end if;
         if Pos < Dimension'Last then
            Height := Natural'Wide_Wide_Value (Dimension (Pos + 1 .. Last - 1));
         else
            Height := 0;
         end if;
      end if;

   exception
      when Constraint_Error =>
         Width  := 0;
         Height := 0;
   end Get_Sizes;

   --  ------------------------------
   --  Find the position of the first non space character in the text starting at the
   --  given position.  Returns Text'Last + 1 if the text only contains spaces.
   --  ------------------------------
   function Skip_Spaces (Text : in Wiki.Strings.WString;
                         From : in Positive) return Positive is
      Pos : Positive := From;
   begin
      while Pos <= Text'Last and then Is_Space (Text (Pos)) loop
         Pos := Pos + 1;
      end loop;
      return Pos;
   end Skip_Spaces;

   --  ------------------------------
   --  Find the position of the last non space character scanning the text backward
   --  from the given position.  Returns Text'First - 1 if the text only contains spaces.
   --  ------------------------------
   function Trim_Spaces (Text : in Wiki.Strings.WString;
                         From : in Positive) return Natural is
      Pos : Natural := From;
   begin
      while Pos >= Text'First and then Is_Space_Or_Newline (Text (Pos)) loop
         Pos := Pos - 1;
      end loop;
      return Pos;
   end Trim_Spaces;

   --  ------------------------------
   --  Find the position of the given character in the string starting at the given position.
   --  ------------------------------
   function Index (Text : in Wiki.Strings.WString;
                   Item : in Wiki.Strings.WChar;
                   From : in Positive) return Natural is
      Pos : Natural := From;
   begin
      while Pos <= Text'Last loop
         if Text (Pos) = Item then
            return Pos;
         end if;
         Pos := Pos + 1;
      end loop;
      return 0;
   end Index;

end Wiki.Helpers;

Fix to also trim newlines

Fix to also trim newlines