-----------------------------------------------------------------------
--  mat-expressions -- Expressions for memory slot selection
--  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 Ada.Unchecked_Deallocation;

with MAT.Types;
with MAT.Memory;
with MAT.Expressions.Parser;
package body MAT.Expressions is

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Node_Type,
                                     Name   => Node_Type_Access);

   --  Destroy recursively the node, releasing the storage.
   procedure Destroy (Node : in out Node_Type_Access);

   --  ------------------------------
   --  Create a NOT expression node.
   --  ------------------------------
   function Create_Not (Expr : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_NOT,
                                    Expr        => Expr.Node);
      Util.Concurrent.Counters.Increment (Expr.Node.Ref_Counter);
      return Result;
   end Create_Not;

   --  ------------------------------
   --  Create a AND expression node.
   --  ------------------------------
   function Create_And (Left  : in Expression_Type;
                        Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_AND,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_And;

   --  ------------------------------
   --  Create a OR expression node.
   --  ------------------------------
   function Create_Or (Left  : in Expression_Type;
                       Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_OR,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_Or;

   --  ------------------------------
   --  Create an INSIDE expression node.
   --  ------------------------------
   function Create_Inside (Name : in Ada.Strings.Unbounded.Unbounded_String;
                           Kind : in Inside_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_INSIDE,
                                    Name        => Name,
                                    Inside      => Kind);
      return Result;
   end Create_Inside;

   --  ------------------------------
   --  Create an size range expression node.
   --  ------------------------------
   function Create_Size (Min : in MAT.Types.Target_Size;
                         Max : in MAT.Types.Target_Size) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_SIZE,
                                    Min_Size    => Min,
                                    Max_Size    => Max);
      return Result;
   end Create_Size;

   --  ------------------------------
   --  Create an addr range expression node.
   --  ------------------------------
   function Create_Addr (Min : in MAT.Types.Target_Addr;
                         Max : in MAT.Types.Target_Addr) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_ADDR,
                                    Min_Addr    => Min,
                                    Max_Addr    => Max);
      return Result;
   end Create_Addr;

   --  ------------------------------
   --  Create an time range expression node.
   --  ------------------------------
   function Create_Time (Min : in MAT.Types.Target_Tick_Ref;
                         Max : in MAT.Types.Target_Tick_Ref) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_TIME,
                                    Min_Time    => Min,
                                    Max_Time    => Max);
      return Result;
   end Create_Time;

   --  ------------------------------
   --  Evaluate the expression to check if the memory slot described by the
   --  context is selected.  Returns True if the memory slot is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Expression_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean is
   begin
      if Node.Node = null then
         return True;
      else
         return Is_Selected (Node.Node.all, Addr, Allocation);
      end if;
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the expression to check if the event described by the
   --  context is selected.  Returns True if the event is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Expression_Type;
                         Event      : in MAT.Events.Targets.Probe_Event_Type) return Boolean is
   begin
      return Is_Selected (Node.Node.all, Event);
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the node against the context.  Returns True if the node expression
   --  selects the memory slot defined by the context.
   --  ------------------------------
   function Is_Selected (Node       : in Node_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean is
      use type MAT.Types.Target_Size;
      use type MAT.Types.Target_Tick_Ref;
   begin
      case Node.Kind is
         when N_NOT =>
            return not Is_Selected (Node.Expr.all, Addr, Allocation);

         when N_AND =>
            return Is_Selected (Node.Left.all, Addr, Allocation)
              and then Is_Selected (Node.Right.all, Addr, Allocation);

         when N_OR =>
            return Is_Selected (Node.Left.all, Addr, Allocation)
              or else Is_Selected (Node.Right.all, Addr, Allocation);

         when N_RANGE_SIZE =>
            return Allocation.Size >= Node.Min_Size
              and Allocation.Size <= Node.Max_Size;

         when N_RANGE_ADDR =>
            return Addr >= Node.Min_Addr
              and Addr <= Node.Max_Addr;

         when N_RANGE_TIME =>
            return Allocation.Time >= Node.Min_Time
              and Allocation.Time <= Node.Max_Time;

         when others =>
            return False;

      end case;
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the expression to check if the event described by the
   --  context is selected.  Returns True if the event is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Node_Type;
                         Event      : in MAT.Events.Targets.Probe_Event_Type) return Boolean is
      use type MAT.Types.Target_Size;
      use type MAT.Types.Target_Tick_Ref;
   begin
      case Node.Kind is
         when N_NOT =>
            return not Is_Selected (Node.Expr.all, Event);

         when N_AND =>
            return Is_Selected (Node.Left.all, Event)
              and then Is_Selected (Node.Right.all, Event);

         when N_OR =>
            return Is_Selected (Node.Left.all, Event)
              or else Is_Selected (Node.Right.all, Event);

         when N_RANGE_SIZE =>
            return Event.Size >= Node.Min_Size
              and Event.Size <= Node.Max_Size;

         when N_RANGE_ADDR =>
            return Event.Addr >= Node.Min_Addr
              and Event.Addr <= Node.Max_Addr;

         when N_RANGE_TIME =>
            return Event.Time >= Node.Min_Time
              and Event.Time <= Node.Max_Time;

         when others =>
            return False;

      end case;
   end Is_Selected;

   --  ------------------------------
   --  Parse the string and return the expression tree.
   --  ------------------------------
   function Parse (Expr : in String) return Expression_Type is
   begin
      return MAT.Expressions.Parser.Parse (Expr);
   end Parse;

   --  ------------------------------
   --  Destroy recursively the node, releasing the storage.
   --  ------------------------------
   procedure Destroy (Node : in out Node_Type_Access) is
      Release : Boolean;
   begin
      if Node /= null then
         Util.Concurrent.Counters.Decrement (Node.Ref_Counter, Release);
         case Node.Kind is
            when N_NOT =>
               Destroy (Node.Expr);

            when N_AND | N_OR =>
               Destroy (Node.Left);
               Destroy (Node.Right);

            when others =>
               null;
         end case;
         if Release then
            Free (Node);
         else
            Node := null;
         end if;
      end if;
   end Destroy;

   --  ------------------------------
   --  Release the reference and destroy the expression tree if it was the last reference.
   --  ------------------------------
   overriding
   procedure Finalize (Obj : in out Expression_Type) is
   begin
      if Obj.Node /= null then
         Destroy (Obj.Node);
      end if;
   end Finalize;

   --  ------------------------------
   --  Update the reference after an assignment.
   --  ------------------------------
   overriding
   procedure Adjust (Obj : in out Expression_Type) is
   begin
      if Obj.Node /= null then
         Util.Concurrent.Counters.Increment (Obj.Node.Ref_Counter);
      end if;
   end Adjust;

end MAT.Expressions;

-----------------------------------------------------------------------
--  mat-expressions -- Expressions for memory slot selection
--  Copyright (C) 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.Unchecked_Deallocation;

with MAT.Types;
with MAT.Memory;
with MAT.Expressions.Parser;
package body MAT.Expressions is

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Node_Type,
                                     Name   => Node_Type_Access);

   --  Destroy recursively the node, releasing the storage.
   procedure Destroy (Node : in out Node_Type_Access);

   --  ------------------------------
   --  Create a NOT expression node.
   --  ------------------------------
   function Create_Not (Expr : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_NOT,
                                    Expr        => Expr.Node);
      Util.Concurrent.Counters.Increment (Expr.Node.Ref_Counter);
      return Result;
   end Create_Not;

   --  ------------------------------
   --  Create a AND expression node.
   --  ------------------------------
   function Create_And (Left  : in Expression_Type;
                        Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_AND,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_And;

   --  ------------------------------
   --  Create a OR expression node.
   --  ------------------------------
   function Create_Or (Left  : in Expression_Type;
                       Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_OR,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_Or;

   --  ------------------------------
   --  Create an INSIDE expression node.
   --  ------------------------------
   function Create_Inside (Name : in Ada.Strings.Unbounded.Unbounded_String;
                           Kind : in Inside_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_INSIDE,
                                    Name        => Name,
                                    Inside      => Kind);
      return Result;
   end Create_Inside;

   --  ------------------------------
   --  Create an size range expression node.
   --  ------------------------------
   function Create_Size (Min : in MAT.Types.Target_Size;
                         Max : in MAT.Types.Target_Size) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_SIZE,
                                    Min_Size    => Min,
                                    Max_Size    => Max);
      return Result;
   end Create_Size;

   --  ------------------------------
   --  Create an addr range expression node.
   --  ------------------------------
   function Create_Addr (Min : in MAT.Types.Target_Addr;
                         Max : in MAT.Types.Target_Addr) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_ADDR,
                                    Min_Addr    => Min,
                                    Max_Addr    => Max);
      return Result;
   end Create_Addr;

   --  ------------------------------
   --  Create an time range expression node.
   --  ------------------------------
   function Create_Time (Min : in MAT.Types.Target_Tick_Ref;
                         Max : in MAT.Types.Target_Tick_Ref) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_TIME,
                                    Min_Time    => Min,
                                    Max_Time    => Max);
      return Result;
   end Create_Time;

   --  ------------------------------
   --  Create an event ID range expression node.
   --  ------------------------------
   function Create_Event (Min : in MAT.Events.Targets.Event_Id_Type;
                          Max : in MAT.Events.Targets.Event_Id_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_EVENT,
                                    Min_Event   => Min,
                                    Max_Event   => Max);
      return Result;
   end Create_Event;

   --  ------------------------------
   --  Evaluate the expression to check if the memory slot described by the
   --  context is selected.  Returns True if the memory slot is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Expression_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean is
   begin
      if Node.Node = null then
         return True;
      else
         return Is_Selected (Node.Node.all, Addr, Allocation);
      end if;
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the expression to check if the event described by the
   --  context is selected.  Returns True if the event is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Expression_Type;
                         Event      : in MAT.Events.Targets.Probe_Event_Type) return Boolean is
   begin
      return Is_Selected (Node.Node.all, Event);
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the node against the context.  Returns True if the node expression
   --  selects the memory slot defined by the context.
   --  ------------------------------
   function Is_Selected (Node       : in Node_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean is
      use type MAT.Types.Target_Size;
      use type MAT.Types.Target_Tick_Ref;
   begin
      case Node.Kind is
         when N_NOT =>
            return not Is_Selected (Node.Expr.all, Addr, Allocation);

         when N_AND =>
            return Is_Selected (Node.Left.all, Addr, Allocation)
              and then Is_Selected (Node.Right.all, Addr, Allocation);

         when N_OR =>
            return Is_Selected (Node.Left.all, Addr, Allocation)
              or else Is_Selected (Node.Right.all, Addr, Allocation);

         when N_RANGE_SIZE =>
            return Allocation.Size >= Node.Min_Size
              and Allocation.Size <= Node.Max_Size;

         when N_RANGE_ADDR =>
            return Addr >= Node.Min_Addr
              and Addr <= Node.Max_Addr;

         when N_RANGE_TIME =>
            return Allocation.Time >= Node.Min_Time
              and Allocation.Time <= Node.Max_Time;

         when others =>
            return False;

      end case;
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the expression to check if the event described by the
   --  context is selected.  Returns True if the event is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Node_Type;
                         Event      : in MAT.Events.Targets.Probe_Event_Type) return Boolean is
      use type MAT.Types.Target_Size;
      use type MAT.Types.Target_Tick_Ref;
   begin
      case Node.Kind is
         when N_NOT =>
            return not Is_Selected (Node.Expr.all, Event);

         when N_AND =>
            return Is_Selected (Node.Left.all, Event)
              and then Is_Selected (Node.Right.all, Event);

         when N_OR =>
            return Is_Selected (Node.Left.all, Event)
              or else Is_Selected (Node.Right.all, Event);

         when N_RANGE_SIZE =>
            return Event.Size >= Node.Min_Size
              and Event.Size <= Node.Max_Size;

         when N_RANGE_ADDR =>
            return Event.Addr >= Node.Min_Addr
              and Event.Addr <= Node.Max_Addr;

         when N_RANGE_TIME =>
            return Event.Time >= Node.Min_Time
              and Event.Time <= Node.Max_Time;

         when others =>
            return False;

      end case;
   end Is_Selected;

   --  ------------------------------
   --  Parse the string and return the expression tree.
   --  ------------------------------
   function Parse (Expr : in String) return Expression_Type is
   begin
      return MAT.Expressions.Parser.Parse (Expr);
   end Parse;

   --  ------------------------------
   --  Destroy recursively the node, releasing the storage.
   --  ------------------------------
   procedure Destroy (Node : in out Node_Type_Access) is
      Release : Boolean;
   begin
      if Node /= null then
         Util.Concurrent.Counters.Decrement (Node.Ref_Counter, Release);
         case Node.Kind is
            when N_NOT =>
               Destroy (Node.Expr);

            when N_AND | N_OR =>
               Destroy (Node.Left);
               Destroy (Node.Right);

            when others =>
               null;
         end case;
         if Release then
            Free (Node);
         else
            Node := null;
         end if;
      end if;
   end Destroy;

   --  ------------------------------
   --  Release the reference and destroy the expression tree if it was the last reference.
   --  ------------------------------
   overriding
   procedure Finalize (Obj : in out Expression_Type) is
   begin
      if Obj.Node /= null then
         Destroy (Obj.Node);
      end if;
   end Finalize;

   --  ------------------------------
   --  Update the reference after an assignment.
   --  ------------------------------
   overriding
   procedure Adjust (Obj : in out Expression_Type) is
   begin
      if Obj.Node /= null then
         Util.Concurrent.Counters.Increment (Obj.Node.Ref_Counter);
      end if;
   end Adjust;

end MAT.Expressions;

Implement the Create_Event function to build an expression node that checks the event ID range


--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: License.txt

with Ada.Command_Line;
with Ada.Text_IO;
with Actions;
with PortScan;
with Parameters;

procedure synth
is
   type mandate_type is (unset, status, help, configure, version, up_system,
                         up_repo, purge, everything, build, install,
                         just_build, test);

   mandate : mandate_type := unset;

   package CLI renames Ada.Command_Line;
   package TIO renames Ada.Text_IO;
   package ACT renames Actions;

begin

   if CLI.Argument_Count = 0 then
      ACT.print_version;
      return;
   end if;

   declare
      first  : constant String := CLI.Argument (1);
      comerr : constant String := "Synth command error: ";
   begin
      if first = "help" then
         mandate := help;
      elsif first = "status" then
         mandate := status;
      elsif first = "version" then
         mandate := version;
      elsif first = "configure" then
         mandate := configure;
      elsif first = "install" then
         mandate := install;
      elsif first = "build" then
         mandate := build;
      elsif first = "just-build" then
         mandate := just_build;
      elsif first = "upgrade-system" then
         mandate := up_system;
      elsif first = "update-repository" then
         mandate := up_repo;
      elsif first = "purge-distfiles" then
         mandate := purge;
      elsif first = "everything" then
         mandate := everything;
      elsif first = "test" then
         mandate := test;
      end if;

      if CLI.Argument_Count > 1 then
         case mandate is
            when unset =>
               ACT.print_version;
               TIO.Put_Line (comerr & "'" & first &
                               "' is not a valid keyword.");
               return;
            when help | configure | version | up_repo | up_system | purge |
                 everything =>
               ACT.print_version;
               TIO.Put_Line (comerr & "'" & first &
                               "' keyword uses no arguments.");
               return;
            when others => null;
         end case;

         --  TO DO: check validity of Arguments 2+

         PortScan.set_cores;
         if not Parameters.load_configuration (PortScan.cores_available)
         then
            TIO.Put_Line (comerr & "configuration failed to load.");
            return;
         end if;

         case mandate is
            when help | configure | version | up_repo | up_system | purge |
                 everything | unset =>
               --  Handled above.  Don't use "others" here;
               --  we don't want to disable full coverage
               null;
            when status =>
               TIO.Put_Line ("multi-arg STATUS to be implemented ...");
               return;
            when just_build =>
               TIO.Put_Line ("JUST-BUILD to be implemented ...");
               return;
            when build =>
               TIO.Put_Line ("BUILD to be implemented ...");
               return;
            when install =>
               TIO.Put_Line ("INSTALL to be implemented ...");
               return;
            when test =>
               TIO.Put_Line ("TEST to be implemented ...");
               return;
         end case;

      else
         --  We have exactly one argument
         case mandate is
            when build | just_build | install | test =>
               ACT.print_version;
               TIO.Put_Line (comerr & "'" & first &
                               "' requires at least one argument.");
               return;
            when version =>
               ACT.print_version;
               return;
            when help =>
               ACT.print_help;
               return;
            when unset =>
               ACT.print_version;
               TIO.Put_Line (comerr & "'" & first &
                               "' is not a valid keyword.");
               return;
            when others => null;
         end case;

         PortScan.set_cores;
         if not Parameters.load_configuration (PortScan.cores_available)
         then
            TIO.Put_Line ("Synth error: configuration failed to load.");
            return;
         end if;

         case mandate is
            when build | just_build | install | test | version | help |
                 unset =>
               --  Handled above.  Don't use "others" here;
               --  we don't want to disable full coverage
               null;
            when configure =>
               ACT.launch_configure_menu (PortScan.cores_available);
               return;
            when status =>
               TIO.Put_Line ("single STATUS to be implemented ...");
               return;
            when up_system =>
               TIO.Put_Line ("UPGRADE-SYSTEM to be implemented ...");
               return;
            when up_repo =>
               TIO.Put_Line ("UPDATE_REPO to be implemented ...");
               return;
            when purge =>
               TIO.Put_Line ("PURGE to be implemented ...");
               return;
            when everything =>
               TIO.Put_Line ("EVERYTHING to be implemented ...");
               return;
         end case;
      end if;
   end;

--     pid : PortScan.port_id;
--     good_scan : Boolean;
--     pkg_good  : Boolean;
--     package T   renames Ada.Text_IO;
--     package OPS renames PortScan.Ops;
--     use type PortScan.port_id;
--
--  begin
--
--
--     Replicant.initialize;
--  --     Replicant.launch_slave (3);
--  --     Replicant.launch_slave (12);
--  --     delay 35.0;
--  --     Replicant.destroy_slave (3);
--  --     Replicant.destroy_slave (12);
--  --   return;
--
--     --  needs to read environment or make -C <anyport> -V PORTSDIR
--  --     good_scan := PortScan.scan_entire_ports_tree (portsdir => "/usr/xports");
--
--     good_scan := PortScan.scan_single_port
--       (portsdir => USS (Parameters.configuration.dir_portsdir),
--        catport => "ports-mgmt/pkg",
--        repository => USS (Parameters.configuration.dir_repository));
--
--     if good_scan then
--        PortScan.set_build_priority;
--     else
--        T.Put_Line ("pkg(8) scan failure, exiting");
--        Replicant.finalize;
--        return;
--     end if;
--
--     PortScan.Packages.limited_sanity_check
--       (repository => USS (Parameters.configuration.dir_repository));
--
--     if not PortScan.Packages.queue_is_empty then
--        PortScan.Buildcycle.initialize (False);
--        pid := PortScan.Ops.top_buildable_port;
--        T.Put_Line ("Rebuilding pkg(8) First ...");
--
--        Replicant.launch_slave (id => 1);
--        pkg_good := PortScan.Buildcycle.build_package
--          (id => 1, sequence_id => pid);
--        Replicant.destroy_slave (id => 1);
--        if not pkg_good then
--           T.Put_Line ("Failed to build pkg(8), exiting");
--           Replicant.finalize;
--           return;
--        end if;
--     end if;
--
--     PortScan.reset_ports_tree;
--
--     good_scan := PortScan.scan_single_port
--       (portsdir => USS (Parameters.configuration.dir_portsdir),
--        catport => "editors/joe",
--        repository => USS (Parameters.configuration.dir_repository));
--
--
--
--  --     good_scan := PortScan.scan_single_port
--  --       (portsdir => USS (Parameters.configuration.dir_portsdir),
--  --        catport => "mail/thunderbird",
--  --        repository => USS (Parameters.configuration.dir_repository));
--
--     if good_scan then
--        PortScan.set_build_priority;
--     else
--        Replicant.finalize;
--        return;
--     end if;
--
--
--     PortScan.Packages.limited_sanity_check
--       (repository => USS (Parameters.configuration.dir_repository));
--
--     --  return;
--
--     T.Put_Line ("");
--     T.Put_Line ("Initial Queue length is" & OPS.queue_length'Img);
--     loop
--        pid := OPS.next_ignored_port;
--        if pid = PortScan.port_match_failed then
--           exit;
--        end if;
--        T.Put_Line (OPS.port_name (pid) & " has been ignored: " &
--                    (OPS.ignore_reason (pid)));
--        OPS.cascade_failed_build (pid);
--     end loop;
--     T.Put_Line ("Final Queue length is" & OPS.queue_length'Img);
--     if PortScan.Packages.queue_is_empty then
--        T.Put_Line ("Everything is Ok, there's nothing to do.");
--     else
--        if OPS.integrity_intact then
--           T.Put_Line ("Integrity intact");
--        else
--           T.Put_Line ("Integrity lost !!!!");
--        end if;
--
--        T.Put_Line ("Starting build simulation");
--        PortScan.Buildcycle.initialize (True);
--        OPS.parallel_bulk_run
--          (num_builders => Parameters.configuration.num_builders);
--     end if;
--     Replicant.finalize;
--
--
--  --     PortScan.release_ports_tree;

end synth;

--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: License.txt

with Ada.Command_Line;
with Ada.Text_IO;
with Actions;
with PortScan;
with Parameters;

procedure synth
is
   type mandate_type is (unset, status, help, configure, version, up_system,
                         up_repo, purge, everything, build, install, force,
                         just_build, test);

   mandate : mandate_type := unset;

   package CLI renames Ada.Command_Line;
   package TIO renames Ada.Text_IO;
   package ACT renames Actions;

begin

   if CLI.Argument_Count = 0 then
      ACT.print_version;
      return;
   end if;

   declare
      first  : constant String := CLI.Argument (1);
      comerr : constant String := "Synth command error: ";
   begin
      if first = "help" then
         mandate := help;
      elsif first = "status" then
         mandate := status;
      elsif first = "version" then
         mandate := version;
      elsif first = "configure" then
         mandate := configure;
      elsif first = "install" then
         mandate := install;
      elsif first = "build" then
         mandate := build;
      elsif first = "force" then
         mandate := force;
      elsif first = "just-build" then
         mandate := just_build;
      elsif first = "upgrade-system" then
         mandate := up_system;
      elsif first = "update-repository" then
         mandate := up_repo;
      elsif first = "purge-distfiles" then
         mandate := purge;
      elsif first = "everything" then
         mandate := everything;
      elsif first = "test" then
         mandate := test;
      end if;

      if CLI.Argument_Count > 1 then
         case mandate is
            when unset =>
               ACT.print_version;
               TIO.Put_Line (comerr & "'" & first &
                               "' is not a valid keyword.");
               return;
            when help | configure | version | up_repo | up_system | purge |
                 everything =>
               ACT.print_version;
               TIO.Put_Line (comerr & "'" & first &
                               "' keyword uses no arguments.");
               return;
            when others => null;
         end case;

         --  TO DO: check validity of Arguments 2+

         PortScan.set_cores;
         if not Parameters.load_configuration (PortScan.cores_available)
         then
            TIO.Put_Line (comerr & "configuration failed to load.");
            return;
         end if;

         case mandate is
            when help | configure | version | up_repo | up_system | purge |
                 everything | unset =>
               --  Handled above.  Don't use "others" here;
               --  we don't want to disable full coverage
               null;
            when status =>
               TIO.Put_Line ("multi-arg STATUS to be implemented ...");
               return;
            when just_build =>
               TIO.Put_Line ("JUST-BUILD to be implemented ...");
               return;
            when build =>
               TIO.Put_Line ("BUILD to be implemented ...");
               return;
            when force =>
               TIO.Put_Line ("FORCE to be implemented ...");
               return;
            when install =>
               TIO.Put_Line ("INSTALL to be implemented ...");
               return;
            when test =>
               TIO.Put_Line ("TEST to be implemented ...");
               return;
         end case;

      else
         --  We have exactly one argument
         case mandate is
            when build | force | just_build | install | test =>
               ACT.print_version;
               TIO.Put_Line (comerr & "'" & first &
                               "' requires at least one argument.");
               return;
            when version =>
               ACT.print_version;
               return;
            when help =>
               ACT.print_help;
               return;
            when unset =>
               ACT.print_version;
               TIO.Put_Line (comerr & "'" & first &
                               "' is not a valid keyword.");
               return;
            when others => null;
         end case;

         PortScan.set_cores;
         if not Parameters.load_configuration (PortScan.cores_available)
         then
            TIO.Put_Line ("Synth error: configuration failed to load.");
            return;
         end if;

         case mandate is
            when build | just_build | install | test | version | help |
                 force | unset =>
               --  Handled above.  Don't use "others" here;
               --  we don't want to disable full coverage
               null;
            when configure =>
               ACT.launch_configure_menu (PortScan.cores_available);
               return;
            when status =>
               TIO.Put_Line ("single STATUS to be implemented ...");
               return;
            when up_system =>
               TIO.Put_Line ("UPGRADE-SYSTEM to be implemented ...");
               return;
            when up_repo =>
               TIO.Put_Line ("UPDATE_REPO to be implemented ...");
               return;
            when purge =>
               TIO.Put_Line ("PURGE to be implemented ...");
               return;
            when everything =>
               TIO.Put_Line ("EVERYTHING to be implemented ...");
               return;
         end case;
      end if;
   end;

--     pid : PortScan.port_id;
--     good_scan : Boolean;
--     pkg_good  : Boolean;
--     package T   renames Ada.Text_IO;
--     package OPS renames PortScan.Ops;
--     use type PortScan.port_id;
--
--  begin
--
--
--     Replicant.initialize;
--  --     Replicant.launch_slave (3);
--  --     Replicant.launch_slave (12);
--  --     delay 35.0;
--  --     Replicant.destroy_slave (3);
--  --     Replicant.destroy_slave (12);
--  --   return;
--
--     --  needs to read environment or make -C <anyport> -V PORTSDIR
--  --     good_scan := PortScan.scan_entire_ports_tree (portsdir => "/usr/xports");
--
--     good_scan := PortScan.scan_single_port
--       (portsdir => USS (Parameters.configuration.dir_portsdir),
--        catport => "ports-mgmt/pkg",
--        repository => USS (Parameters.configuration.dir_repository));
--
--     if good_scan then
--        PortScan.set_build_priority;
--     else
--        T.Put_Line ("pkg(8) scan failure, exiting");
--        Replicant.finalize;
--        return;
--     end if;
--
--     PortScan.Packages.limited_sanity_check
--       (repository => USS (Parameters.configuration.dir_repository));
--
--     if not PortScan.Packages.queue_is_empty then
--        PortScan.Buildcycle.initialize (False);
--        pid := PortScan.Ops.top_buildable_port;
--        T.Put_Line ("Rebuilding pkg(8) First ...");
--
--        Replicant.launch_slave (id => 1);
--        pkg_good := PortScan.Buildcycle.build_package
--          (id => 1, sequence_id => pid);
--        Replicant.destroy_slave (id => 1);
--        if not pkg_good then
--           T.Put_Line ("Failed to build pkg(8), exiting");
--           Replicant.finalize;
--           return;
--        end if;
--     end if;
--
--     PortScan.reset_ports_tree;
--
--     good_scan := PortScan.scan_single_port
--       (portsdir => USS (Parameters.configuration.dir_portsdir),
--        catport => "editors/joe",
--        repository => USS (Parameters.configuration.dir_repository));
--
--
--
--  --     good_scan := PortScan.scan_single_port
--  --       (portsdir => USS (Parameters.configuration.dir_portsdir),
--  --        catport => "mail/thunderbird",
--  --        repository => USS (Parameters.configuration.dir_repository));
--
--     if good_scan then
--        PortScan.set_build_priority;
--     else
--        Replicant.finalize;
--        return;
--     end if;
--
--
--     PortScan.Packages.limited_sanity_check
--       (repository => USS (Parameters.configuration.dir_repository));
--
--     --  return;
--
--     T.Put_Line ("");
--     T.Put_Line ("Initial Queue length is" & OPS.queue_length'Img);
--     loop
--        pid := OPS.next_ignored_port;
--        if pid = PortScan.port_match_failed then
--           exit;
--        end if;
--        T.Put_Line (OPS.port_name (pid) & " has been ignored: " &
--                    (OPS.ignore_reason (pid)));
--        OPS.cascade_failed_build (pid);
--     end loop;
--     T.Put_Line ("Final Queue length is" & OPS.queue_length'Img);
--     if PortScan.Packages.queue_is_empty then
--        T.Put_Line ("Everything is Ok, there's nothing to do.");
--     else
--        if OPS.integrity_intact then
--           T.Put_Line ("Integrity intact");
--        else
--           T.Put_Line ("Integrity lost !!!!");
--        end if;
--
--        T.Put_Line ("Starting build simulation");
--        PortScan.Buildcycle.initialize (True);
--        OPS.parallel_bulk_run
--          (num_builders => Parameters.configuration.num_builders);
--     end if;
--     Replicant.finalize;
--
--
--  --     PortScan.release_ports_tree;

end synth;

Add forgotten "force" command (still to be implemented)


-----------------------------------------------------------------------
--  security-oauth-jwt -- OAuth Java Web Token
--  Copyright (C) 2013 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 Util.Properties;

--  === JSON Web Token ===
--  JSON Web Token (JWT) is a compact URL-safe means of representing claims to be transferred
--  between two parties.  A JWT token is returned by an authorization server.  It contains
--  useful information that allows to verify the authentication and identify the user.
--
--  The <tt>Security.OAuth.JWT</tt> package implements the decoding part of JWT defined in:
--  JSON Web Token (JWT), http://tools.ietf.org/html/draft-ietf-oauth-json-web-token-07
--
--  A list of pre-defined ID tokens are returned in the JWT token claims and used for
--  the OpenID Connect.  This is specified in
--  OpenID Connect Basic Client Profile 1.0 - draft 26,
--  http://openid.net/specs/openid-connect-basic-1_0.html
--
package Security.OAuth.JWT is

   --  Exception raised if the encoded token is invalid or cannot be decoded.
   Invalid_Token : exception;

   type Token is private;

   --  Get the issuer claim from the token (the "iss" claim).
   function Get_Issuer (From : in Token) return String;

   --  Get the subject claim from the token (the "sub" claim).
   function Get_Subject (From : in Token) return String;

   --  Get the audience claim from the token (the "aud" claim).
   function Get_Audience (From : in Token) return String;

   --  Get the expiration claim from the token (the "exp" claim).
   function Get_Expiration (From : in Token) return Ada.Calendar.Time;

   --  Get the not before claim from the token (the "nbf" claim).
   function Get_Not_Before (From : in Token) return Ada.Calendar.Time;

   --  Get the issued at claim from the token (the "iat" claim).
   --  This is the time when the JWT was issued.
   function Get_Issued_At (From : in Token) return Ada.Calendar.Time;

   --  Get the authentication time claim from the token (the "auth_time" claim).
   function Get_Authentication_Time (From : in Token) return Ada.Calendar.Time;

   --  Get the JWT ID claim from the token (the "jti" claim).
   function Get_JWT_ID (From : in Token) return String;

   --  Get the authorized clients claim from the token (the "azp" claim).
   function Get_Authorized_Presenters (From : in Token) return String;

   --  Get the claim with the given name from the token.
   function Get_Claim (From : in Token;
                       Name : in String) return String;

   --  Decode a string representing an encoded JWT token according to the JWT specification:
   --
   --    Section 7.  Rules for Creating and Validating a JWT
   --
   --  The JWT token is composed of 3 parts encoded in Base64url and separated by '.' .
   --  The first part represents the header, the second part the claims and the last part
   --  the signature.  The <tt>Decode</tt> operation splits the parts, decodes them,
   --  parses the JSON content represented by the header and the claims.
   --  The <tt>Decode</tt> operation does not verify the signature (yet!).
   --
   --  Return the decoded token or raise an exception.
   function Decode (Content : in String) return Token;

private

   type Claims is new Util.Properties.Manager with null record;

   type Token is record
      Header : Util.Properties.Manager;
      Claims : Util.Properties.Manager;
   end record;

end Security.OAuth.JWT;

-----------------------------------------------------------------------
--  security-oauth-jwt -- OAuth Java Web Token
--  Copyright (C) 2013 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 Util.Properties;

--  === JSON Web Token ===
--  JSON Web Token (JWT) is a compact URL-safe means of representing claims to be transferred
--  between two parties.  A JWT token is returned by an authorization server.  It contains
--  useful information that allows to verify the authentication and identify the user.
--
--  The <tt>Security.OAuth.JWT</tt> package implements the decoding part of JWT defined in:
--  JSON Web Token (JWT), http://tools.ietf.org/html/draft-ietf-oauth-json-web-token-07
--
--  A list of pre-defined ID tokens are returned in the JWT token claims and used for
--  the OpenID Connect.  This is specified in
--  OpenID Connect Basic Client Profile 1.0 - draft 26,
--  http://openid.net/specs/openid-connect-basic-1_0.html
--
package Security.OAuth.JWT is

   --  Exception raised if the encoded token is invalid or cannot be decoded.
   Invalid_Token : exception;

   type Token is private;

   --  Get the issuer claim from the token (the "iss" claim).
   function Get_Issuer (From : in Token) return String;

   --  Get the subject claim from the token (the "sub" claim).
   function Get_Subject (From : in Token) return String;

   --  Get the audience claim from the token (the "aud" claim).
   function Get_Audience (From : in Token) return String;

   --  Get the expiration claim from the token (the "exp" claim).
   function Get_Expiration (From : in Token) return Ada.Calendar.Time;

   --  Get the not before claim from the token (the "nbf" claim).
   function Get_Not_Before (From : in Token) return Ada.Calendar.Time;

   --  Get the issued at claim from the token (the "iat" claim).
   --  This is the time when the JWT was issued.
   function Get_Issued_At (From : in Token) return Ada.Calendar.Time;

   --  Get the authentication time claim from the token (the "auth_time" claim).
   function Get_Authentication_Time (From : in Token) return Ada.Calendar.Time;

   --  Get the JWT ID claim from the token (the "jti" claim).
   function Get_JWT_ID (From : in Token) return String;

   --  Get the authorized clients claim from the token (the "azp" claim).
   function Get_Authorized_Presenters (From : in Token) return String;

   --  Get the claim with the given name from the token.
   function Get_Claim (From    : in Token;
                       Name    : in String;
                       Default : in String := "") return String;

   --  Decode a string representing an encoded JWT token according to the JWT specification:
   --
   --    Section 7.  Rules for Creating and Validating a JWT
   --
   --  The JWT token is composed of 3 parts encoded in Base64url and separated by '.' .
   --  The first part represents the header, the second part the claims and the last part
   --  the signature.  The <tt>Decode</tt> operation splits the parts, decodes them,
   --  parses the JSON content represented by the header and the claims.
   --  The <tt>Decode</tt> operation does not verify the signature (yet!).
   --
   --  Return the decoded token or raise an exception.
   function Decode (Content : in String) return Token;

private

   type Claims is new Util.Properties.Manager with null record;

   type Token is record
      Header : Util.Properties.Manager;
      Claims : Util.Properties.Manager;
   end record;

end Security.OAuth.JWT;

Update Get_Claim to add a default value returned if the claim does not exist


-----------------------------------------------------------------------
--  Util -- Unit tests for properties
--  Copyright (C) 2009, 2010, 2011, 2014, 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.Test_Caller;

with Ada.Text_IO;

with Util.Properties;
with Util.Properties.Basic;

package body Util.Properties.Tests is

   use Ada.Text_IO;
   use type Ada.Containers.Count_Type;
   use Util.Properties.Basic;
   use Util;

   --  Test
   --    Properties.Set
   --    Properties.Exists
   --    Properties.Get
   procedure Test_Property (T : in out Test) is
      Props : Properties.Manager;
   begin
      T.Assert (Exists (Props, "test") = False,
                "Invalid properties");
      Props.Set ("test", "toto");
      T.Assert (Exists (Props, "test"),
                "Property was not inserted");
      declare
         V : constant String := Props.Get ("test");
      begin

         T.Assert (V = "toto",
                   "Property was not set correctly");
      end;
   end Test_Property;

   --  Test basic properties
   --     Get
   --     Set
   procedure Test_Integer_Property (T : in out Test) is
      Props : Properties.Manager;
      V     : Integer := 23;
   begin
      Integer_Property.Set (Props, "test-integer", V);
      T.Assert (Props.Exists ("test-integer"), "Invalid properties");

      V := Integer_Property.Get (Props, "test-integer");
      T.Assert (V = 23, "Property was not inserted");

      Integer_Property.Set (Props, "test-integer", 24);
      V := Integer_Property.Get (Props, "test-integer");
      T.Assert (V = 24, "Property was not inserted");

      V := Integer_Property.Get (Props, "unknown", 25);
      T.Assert (V = 25, "Default value must be returned for a Get");
   end Test_Integer_Property;

   --  Test loading of property files
   procedure Test_Load_Property (T : in out Test) is
      Props : Properties.Manager;
      F : File_Type;
   begin
      Open (F, In_File, "regtests/test.properties");
      Load_Properties (Props, F);
      Close (F);

      declare
         Names : Util.Strings.Vectors.Vector;
      begin
         Props.Get_Names (Names);
         T.Assert (Names.Length > 30,
                   "Loading the test properties returned too few properties");

         T.Assert (To_String (Props.Get ("root.dir")) = ".",
                   "Invalid property 'root.dir'");
         T.Assert (To_String (Props.Get ("console.lib")) = "${dist.lib.dir}/console.jar",
                   "Invalid property 'console.lib'");
      end;
   exception
      when Ada.Text_IO.Name_Error =>
         Ada.Text_IO.Put_Line ("Cannot find test file: regtests/test.properties");
         raise;
   end Test_Load_Property;

   --  ------------------------------
   --  Test loading of property files
   --  ------------------------------
   procedure Test_Load_Strip_Property (T : in out Test) is
      Props : Properties.Manager;
      F : File_Type;
   begin
      --  Load, filter and strip properties
      Open (F, In_File, "regtests/test.properties");
      Load_Properties (Props, F, "tomcat.", True);
      Close (F);

      declare
         Names : Util.Strings.Vectors.Vector;
      begin
         Props.Get_Names (Names);
         T.Assert (Names.Length > 3,
                   "Loading the test properties returned too few properties");

         T.Assert (To_String (Props.Get ("version")) = "0.6",
                   "Invalid property 'root.dir'");
      end;
   exception
      when Ada.Text_IO.Name_Error =>
         Ada.Text_IO.Put_Line ("Cannot find test file: regtests/test.properties");
         raise;
   end Test_Load_Strip_Property;

   --  ------------------------------
   --  Test copy of properties
   --  ------------------------------
   procedure Test_Copy_Property (T : in out Test) is
      Props : Properties.Manager;
   begin
      Props.Set ("prefix.one", "1");
      Props.Set ("prefix.two", "2");
      Props.Set ("prefix", "Not copied");
      Props.Set ("prefix.", "Copied");
      declare
         Copy : Properties.Manager;
      begin
         Copy.Copy (From   => Props,
                    Prefix => "prefix.",
                    Strip  => True);
         T.Assert (Copy.Exists ("one"), "Property one not found");
         T.Assert (Copy.Exists ("two"), "Property two not found");
         T.Assert (Copy.Exists (""), "Property '' does not exist.");
      end;
   end Test_Copy_Property;

   procedure Test_Set_Preserve_Original (T : in out Test) is
      Props1 : Properties.Manager;
   begin
      Props1.Set ("a", "b");
      Props1.Set ("c", "d");
      declare
         Props2 : Properties.Manager;
      begin
         Props2 := Props1;
         T.Assert (Props2.Exists ("a"), "Property a not found in props2 after assignment");
         T.Assert (Props2.Exists ("c"), "Property b not found in props2 after assignment");
         Util.Tests.Assert_Equals (T, "b", String '(Props2.Get ("a")), "Invalid property a");
         Props1.Set ("a", "d");
         Util.Tests.Assert_Equals (T, "d", String '(Props1.Get ("a")),
                                   "Wrong property a in props1");
         Util.Tests.Assert_Equals (T, "b", String '(Props2.Get ("a")),
                                   "Wrong property a in props2");
         Props2 := Props1;
         Util.Tests.Assert_Equals (T, "d", String '(Props2.Get ("a")),
                                   "Wrong property a in props2");
         Props2.Set ("e", "f");
         Props2.Set ("c", "g");
         Props1 := Props2;

         --  Release Props2 but the property manager is internally shared so the Props1 is
         --  not changed.
      end;
      T.Assert (Props1.Exists ("e"), "Property e not found in props1 after assignment");
      T.Assert (Props1.Exists ("c"), "Property c not found in props1 after assignment");
      Util.Tests.Assert_Equals (T, "g", String '(Props1.Get ("c")),
                                "Wrong property c in props1");
   end Test_Set_Preserve_Original;

   procedure Test_Remove_Preserve_Original (T : in out Test) is
      Props1 : Properties.Manager;
   begin
      Props1.Set ("a", "b");
      Props1.Set ("c", "d");
      declare
         Props2 : Properties.Manager;
      begin
         Props2 := Props1;
         T.Assert (Props2.Exists ("a"), "Property a not found in props2 after assignment");
         T.Assert (Props2.Exists ("c"), "Property b not found in props2 after assignment");
         Props1.Remove ("a");
         T.Assert (not Props1.Exists ("a"), "Property a was not removed from props1");
         T.Assert (Props2.Exists ("a"), "Property a was removed from props2");
         Props1 := Props2;

         --  Release Props2 but the property manager is internally shared so the Props1 is
         --  not changed.
      end;
      Util.Tests.Assert_Equals (T, "b", String '(Props1.Get ("a")),
                                "Wrong property a in props1");
   end Test_Remove_Preserve_Original;

   procedure Test_Missing_Property (T : in out Test) is
      Props  : Properties.Manager;
      V      : Unbounded_String;
   begin
      T.Assert (Util.Beans.Objects.Is_Null (Props.Get_Value ("missing")),
                "The Get_Value operation must return a null object");
      begin
         V := Props.Get ("missing");
         T.Fail ("Exception NO_PROPERTY was not raised");

      exception
         when NO_PROPERTY =>
            null;
      end;

      Props.Set ("a", "b");
      T.Assert (Util.Beans.Objects.Is_Null (Props.Get_Value ("missing")),
                "The Get_Value operation must return a null object");
      begin
         V := Props.Get ("missing");
         T.Fail ("Exception NO_PROPERTY was not raised");

      exception
         when NO_PROPERTY =>
            null;
      end;
   end Test_Missing_Property;

   procedure Test_Load_Ini_Property (T : in out Test) is
      Props : Properties.Manager;
      F : File_Type;
   begin
      Open (F, In_File, "regtests/files/my.cnf");
      Load_Properties (Props, F);
      Close (F);

      declare
         V : Util.Properties.Value;
         P : Properties.Manager;
      begin
         V := Props.Get_Value ("mysqld");
         T.Assert (Util.Properties.Is_Manager (V),
                   "Value 'mysqld' must be a property manager");
         P := Util.Properties.To_Manager (V);
         T.Assert (P.Exists ("user"),
                   "The [mysqld] property manager should contain a 'user' property");

         V := Props.Get_Value ("mysqld_safe");
         T.Assert (Util.Properties.Is_Manager (V),
                   "Value 'mysqld_safe' must be a property manager");
         P := Util.Properties.To_Manager (V);
         T.Assert (P.Exists ("socket"),
                   "The [mysqld] property manager should contain a 'socket' property");

      end;

   exception
      when Ada.Text_IO.Name_Error =>
         Ada.Text_IO.Put_Line ("Cannot find test file: regtests/files/my.cnf");
         raise;

   end Test_Load_Ini_Property;

   package Caller is new Util.Test_Caller (Test, "Properties");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Properties.Set",
                       Test_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Get",
                       Test_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Exists",
                       Test_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Get (NO_PROPERTY)",
                       Test_Missing_Property'Access);

      Caller.Add_Test (Suite, "Test Util.Properties.Discrete.Get",
                       Test_Integer_Property'Access);

      Caller.Add_Test (Suite, "Test Util.Properties.Discrete.Set",
                       Test_Integer_Property'Access);

      Caller.Add_Test (Suite, "Test Util.Properties.Load_Properties",
                       Test_Load_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Load_Properties (INI)",
                       Test_Load_Ini_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Load_Strip_Properties",
                       Test_Load_Strip_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Copy",
                       Test_Copy_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Set+Assign",
                       Test_Set_Preserve_Original'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Set+Assign+Remove",
                       Test_Remove_Preserve_Original'Access);
   end Add_Tests;

end Util.Properties.Tests;

-----------------------------------------------------------------------
--  Util -- Unit tests for properties
--  Copyright (C) 2009, 2010, 2011, 2014, 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.Test_Caller;

with Ada.Text_IO;

with Util.Properties;
with Util.Properties.Basic;

package body Util.Properties.Tests is

   use Ada.Text_IO;
   use type Ada.Containers.Count_Type;
   use Util.Properties.Basic;
   use Util;

   --  Test
   --    Properties.Set
   --    Properties.Exists
   --    Properties.Get
   procedure Test_Property (T : in out Test) is
      Props : Properties.Manager;
   begin
      T.Assert (Exists (Props, "test") = False,
                "Invalid properties");
      Props.Set ("test", "toto");
      T.Assert (Exists (Props, "test"),
                "Property was not inserted");
      declare
         V : constant String := Props.Get ("test");
      begin

         T.Assert (V = "toto",
                   "Property was not set correctly");
      end;
   end Test_Property;

   --  Test basic properties
   --     Get
   --     Set
   procedure Test_Integer_Property (T : in out Test) is
      Props : Properties.Manager;
      V     : Integer := 23;
   begin
      Integer_Property.Set (Props, "test-integer", V);
      T.Assert (Props.Exists ("test-integer"), "Invalid properties");

      V := Integer_Property.Get (Props, "test-integer");
      T.Assert (V = 23, "Property was not inserted");

      Integer_Property.Set (Props, "test-integer", 24);
      V := Integer_Property.Get (Props, "test-integer");
      T.Assert (V = 24, "Property was not inserted");

      V := Integer_Property.Get (Props, "unknown", 25);
      T.Assert (V = 25, "Default value must be returned for a Get");
   end Test_Integer_Property;

   --  Test loading of property files
   procedure Test_Load_Property (T : in out Test) is
      Props : Properties.Manager;
      F : File_Type;
   begin
      Open (F, In_File, "regtests/test.properties");
      Load_Properties (Props, F);
      Close (F);

      declare
         Names : Util.Strings.Vectors.Vector;
      begin
         Props.Get_Names (Names);
         T.Assert (Names.Length > 30,
                   "Loading the test properties returned too few properties");

         T.Assert (To_String (Props.Get ("root.dir")) = ".",
                   "Invalid property 'root.dir'");
         T.Assert (To_String (Props.Get ("console.lib")) = "${dist.lib.dir}/console.jar",
                   "Invalid property 'console.lib'");
      end;
   exception
      when Ada.Text_IO.Name_Error =>
         Ada.Text_IO.Put_Line ("Cannot find test file: regtests/test.properties");
         raise;
   end Test_Load_Property;

   --  ------------------------------
   --  Test loading of property files
   --  ------------------------------
   procedure Test_Load_Strip_Property (T : in out Test) is
      Props : Properties.Manager;
      F : File_Type;
   begin
      --  Load, filter and strip properties
      Open (F, In_File, "regtests/test.properties");
      Load_Properties (Props, F, "tomcat.", True);
      Close (F);

      declare
         Names : Util.Strings.Vectors.Vector;
      begin
         Props.Get_Names (Names);
         T.Assert (Names.Length > 3,
                   "Loading the test properties returned too few properties");

         T.Assert (To_String (Props.Get ("version")) = "0.6",
                   "Invalid property 'root.dir'");
      end;
   exception
      when Ada.Text_IO.Name_Error =>
         Ada.Text_IO.Put_Line ("Cannot find test file: regtests/test.properties");
         raise;
   end Test_Load_Strip_Property;

   --  ------------------------------
   --  Test copy of properties
   --  ------------------------------
   procedure Test_Copy_Property (T : in out Test) is
      Props : Properties.Manager;
   begin
      Props.Set ("prefix.one", "1");
      Props.Set ("prefix.two", "2");
      Props.Set ("prefix", "Not copied");
      Props.Set ("prefix.", "Copied");
      declare
         Copy : Properties.Manager;
      begin
         Copy.Copy (From   => Props,
                    Prefix => "prefix.",
                    Strip  => True);
         T.Assert (Copy.Exists ("one"), "Property one not found");
         T.Assert (Copy.Exists ("two"), "Property two not found");
         T.Assert (Copy.Exists (""), "Property '' does not exist.");
      end;
   end Test_Copy_Property;

   procedure Test_Set_Preserve_Original (T : in out Test) is
      Props1 : Properties.Manager;
   begin
      Props1.Set ("a", "b");
      Props1.Set ("c", "d");
      declare
         Props2 : Properties.Manager;
      begin
         Props2 := Props1;
         T.Assert (Props2.Exists ("a"), "Property a not found in props2 after assignment");
         T.Assert (Props2.Exists ("c"), "Property b not found in props2 after assignment");
         Util.Tests.Assert_Equals (T, "b", String '(Props2.Get ("a")), "Invalid property a");
         Props1.Set ("a", "d");
         Util.Tests.Assert_Equals (T, "d", String '(Props1.Get ("a")),
                                   "Wrong property a in props1");
         Util.Tests.Assert_Equals (T, "b", String '(Props2.Get ("a")),
                                   "Wrong property a in props2");
         Props2 := Props1;
         Util.Tests.Assert_Equals (T, "d", String '(Props2.Get ("a")),
                                   "Wrong property a in props2");
         Props2.Set ("e", "f");
         Props2.Set ("c", "g");
         Props1 := Props2;

         --  Release Props2 but the property manager is internally shared so the Props1 is
         --  not changed.
      end;
      T.Assert (Props1.Exists ("e"), "Property e not found in props1 after assignment");
      T.Assert (Props1.Exists ("c"), "Property c not found in props1 after assignment");
      Util.Tests.Assert_Equals (T, "g", String '(Props1.Get ("c")),
                                "Wrong property c in props1");
   end Test_Set_Preserve_Original;

   procedure Test_Remove_Preserve_Original (T : in out Test) is
      Props1 : Properties.Manager;
   begin
      Props1.Set ("a", "b");
      Props1.Set ("c", "d");
      declare
         Props2 : Properties.Manager;
      begin
         Props2 := Props1;
         T.Assert (Props2.Exists ("a"), "Property a not found in props2 after assignment");
         T.Assert (Props2.Exists ("c"), "Property b not found in props2 after assignment");
         Props1.Remove ("a");
         T.Assert (not Props1.Exists ("a"), "Property a was not removed from props1");
         T.Assert (Props2.Exists ("a"), "Property a was removed from props2");
         Props1 := Props2;

         --  Release Props2 but the property manager is internally shared so the Props1 is
         --  not changed.
      end;
      Util.Tests.Assert_Equals (T, "b", String '(Props1.Get ("a")),
                                "Wrong property a in props1");
   end Test_Remove_Preserve_Original;

   procedure Test_Missing_Property (T : in out Test) is
      Props  : Properties.Manager;
      V      : Unbounded_String;
   begin
      T.Assert (Util.Beans.Objects.Is_Null (Props.Get_Value ("missing")),
                "The Get_Value operation must return a null object");
      begin
         V := Props.Get ("missing");
         T.Fail ("Exception NO_PROPERTY was not raised");

      exception
         when NO_PROPERTY =>
            null;
      end;
      T.Assert (Ada.Strings.Unbounded.Length (V) = 0, "Variable get's corrupted");

      Props.Set ("a", "b");
      T.Assert (Util.Beans.Objects.Is_Null (Props.Get_Value ("missing")),
                "The Get_Value operation must return a null object");
      begin
         V := Props.Get ("missing");
         T.Fail ("Exception NO_PROPERTY was not raised");

      exception
         when NO_PROPERTY =>
            null;
      end;
   end Test_Missing_Property;

   procedure Test_Load_Ini_Property (T : in out Test) is
      Props : Properties.Manager;
      F : File_Type;
   begin
      Open (F, In_File, "regtests/files/my.cnf");
      Load_Properties (Props, F);
      Close (F);

      declare
         V : Util.Properties.Value;
         P : Properties.Manager;
      begin
         V := Props.Get_Value ("mysqld");
         T.Assert (Util.Properties.Is_Manager (V),
                   "Value 'mysqld' must be a property manager");
         P := Util.Properties.To_Manager (V);
         T.Assert (P.Exists ("user"),
                   "The [mysqld] property manager should contain a 'user' property");

         V := Props.Get_Value ("mysqld_safe");
         T.Assert (Util.Properties.Is_Manager (V),
                   "Value 'mysqld_safe' must be a property manager");
         P := Util.Properties.To_Manager (V);
         T.Assert (P.Exists ("socket"),
                   "The [mysqld] property manager should contain a 'socket' property");

      end;

   exception
      when Ada.Text_IO.Name_Error =>
         Ada.Text_IO.Put_Line ("Cannot find test file: regtests/files/my.cnf");
         raise;

   end Test_Load_Ini_Property;

   package Caller is new Util.Test_Caller (Test, "Properties");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Properties.Set",
                       Test_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Get",
                       Test_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Exists",
                       Test_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Get (NO_PROPERTY)",
                       Test_Missing_Property'Access);

      Caller.Add_Test (Suite, "Test Util.Properties.Discrete.Get",
                       Test_Integer_Property'Access);

      Caller.Add_Test (Suite, "Test Util.Properties.Discrete.Set",
                       Test_Integer_Property'Access);

      Caller.Add_Test (Suite, "Test Util.Properties.Load_Properties",
                       Test_Load_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Load_Properties (INI)",
                       Test_Load_Ini_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Load_Strip_Properties",
                       Test_Load_Strip_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Copy",
                       Test_Copy_Property'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Set+Assign",
                       Test_Set_Preserve_Original'Access);
      Caller.Add_Test (Suite, "Test Util.Properties.Set+Assign+Remove",
                       Test_Remove_Preserve_Original'Access);
   end Add_Tests;

end Util.Properties.Tests;

Fix compilation warning

Fix compilation warning


-----------------------------------------------------------------------
--  ASF testsuite - Ada Server Faces Test suite
--  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 AUnit.Assertions;
with ASF.Contexts.Writer.Tests;
with ASF.Views.Facelets.Tests;
with ASF.Applications.Views.Tests;
with ASF.Sessions.Tests;

with AUnit.Reporter.Text;
with AUnit.Run;
package body ASF.Testsuite is

   use AUnit.Assertions;
   procedure Run is
      Ret : aliased Test_Suite;

      function Get_Suite return Access_Test_Suite;

      function Get_Suite return Access_Test_Suite is
      begin
         return Ret'Unchecked_Access;
      end Get_Suite;

      procedure Runner is new AUnit.Run.Test_Runner (Get_Suite);
      Reporter : AUnit.Reporter.Text.Text_Reporter;
   begin
      ASF.Contexts.Writer.Tests.Add_Tests (Ret'Unchecked_Access);
      ASF.Views.Facelets.Tests.Add_Tests (Ret'Unchecked_Access);
      ASF.Applications.Views.Tests.Add_Tests (Ret'Unchecked_Access);

      Runner (Reporter);
   end Run;

   Tests : aliased Test_Suite;

   function Suite return Access_Test_Suite is
      Ret : constant Access_Test_Suite := Tests'Access;
   begin
      ASF.Contexts.Writer.Tests.Add_Tests (Ret);
      ASF.Views.Facelets.Tests.Add_Tests (Ret);
      ASF.Applications.Views.Tests.Add_Tests (Ret);
      ASF.Sessions.Tests.Add_Tests (Ret);
      return Ret;
   end Suite;

end ASF.Testsuite;

-----------------------------------------------------------------------
--  ASF testsuite - Ada Server Faces Test suite
--  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 AUnit.Assertions;
with ASF.Contexts.Writer.Tests;
with ASF.Views.Facelets.Tests;
with ASF.Applications.Views.Tests;
with ASF.Sessions.Tests;
with ASF.Servlets.Tests;

with AUnit.Reporter.Text;
with AUnit.Run;
package body ASF.Testsuite is

   use AUnit.Assertions;
   procedure Run is
      Ret : aliased Test_Suite;

      function Get_Suite return Access_Test_Suite;

      function Get_Suite return Access_Test_Suite is
      begin
         return Ret'Unchecked_Access;
      end Get_Suite;

      procedure Runner is new AUnit.Run.Test_Runner (Get_Suite);
      Reporter : AUnit.Reporter.Text.Text_Reporter;
   begin
      ASF.Contexts.Writer.Tests.Add_Tests (Ret'Unchecked_Access);
      ASF.Views.Facelets.Tests.Add_Tests (Ret'Unchecked_Access);
      ASF.Applications.Views.Tests.Add_Tests (Ret'Unchecked_Access);

      Runner (Reporter);
   end Run;

   Tests : aliased Test_Suite;

   function Suite return Access_Test_Suite is
      Ret : constant Access_Test_Suite := Tests'Access;
   begin
      ASF.Contexts.Writer.Tests.Add_Tests (Ret);
      ASF.Views.Facelets.Tests.Add_Tests (Ret);
      ASF.Applications.Views.Tests.Add_Tests (Ret);
      ASF.Sessions.Tests.Add_Tests (Ret);
      ASF.Servlets.Tests.Add_Tests (Ret);
      return Ret;
   end Suite;

end ASF.Testsuite;

Add servlet tests

Add servlet tests


-----------------------------------------------------------------------
--  awa-blogs-beans -- Beans for blog module
--  Copyright (C) 2011, 2012, 2013, 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 Ada.Strings.Unbounded;

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

with ADO;

with AWA.Blogs.Modules;
with AWA.Blogs.Models;
with AWA.Tags.Beans;
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";

   --  ------------------------------
   --  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;

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

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

   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;
   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 Blog_Bean bean instance.
   function Create_Blog_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access;

   --  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;

   --  List of posts visible to anybody.
   type Post_List_Bean is limited new Util.Beans.Basic.Bean with record
      Posts      : aliased AWA.Blogs.Models.Post_Info_List_Bean;
      Service    : Modules.Blog_Module_Access := null;
      Tag        : Ada.Strings.Unbounded.Unbounded_String;
      Tags       : AWA.Tags.Beans.Entity_Tag_Map;
      Posts_Bean : AWA.Blogs.Models.Post_Info_List_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);

   --  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;

   --  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;

   --  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;

   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);

end AWA.Blogs.Beans;

-----------------------------------------------------------------------
--  awa-blogs-beans -- Beans for blog module
--  Copyright (C) 2011, 2012, 2013, 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 Ada.Strings.Unbounded;

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

with ADO;

with AWA.Blogs.Modules;
with AWA.Blogs.Models;
with AWA.Tags.Beans;
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";

   --  ------------------------------
   --  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;

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

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

   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;
   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 Blog_Bean bean instance.
   function Create_Blog_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access;

   --  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;

   --  List of posts visible to anybody.
   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;
   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;

   --  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;

   --  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;

   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);

end AWA.Blogs.Beans;

Use the UML Post_List_Bean type and override the Load operation


-----------------------------------------------------------------------
--  util-encoders-aes -- AES encryption and decryption
--  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 Ada.Streams;
with Interfaces;

--  The Util.Encodes.SHA1 package generates SHA-1 hash according to
--  RFC3174 or [FIPS-180-1].
package Util.Encoders.AES is

   type Key_Type is private;

   --  ------------------------------
   --  ------------------------------
   subtype Block_Type is Ada.Streams.Stream_Element_Array (1 .. 16);

   procedure Set_Encrypt_Key (Key  : out Key_Type;
                              Data : in Ada.Streams.Stream_Element_Array);

   procedure Set_Decrypt_Key (Key  : out Key_Type;
                              Data : in Ada.Streams.Stream_Element_Array);

   procedure Encrypt (Input  : in Block_Type;
                      Output : out Block_Type;
                      Key    : in Key_Type);

   procedure Encrypt (Input  : in Ada.Streams.Stream_Element_Array;
                      Output : out Ada.Streams.Stream_Element_Array;
                      Last   : out Ada.Streams.Stream_Element_Offset;
                      Key    : in Key_Type);

   procedure Decrypt (Input  : in Block_Type;
                      Output : out Block_Type;
                      Key    : in Key_Type);

   --  ------------------------------
   --  AES encoder
   --  ------------------------------
   --  This Encoder translates the (binary) input stream into
   --  an SHA1 hexadecimal stream.  The encoding alphabet is: 0123456789ABCDEF.
   type Encoder is new Util.Encoders.Transformer with private;

   --  Encodes the binary input stream represented by Data into
   --  an SHA-1 hash output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   overriding
   procedure Transform (E       : in Encoder;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset);

private

   type Encoder is new Util.Encoders.Transformer with null record;

   use Interfaces;

   type Block_Key is array (0 .. 59) of Unsigned_32;

   type Key_Type is record
      Key    : Block_Key;
      Rounds : Natural := 0;
   end record;

end Util.Encoders.AES;

-----------------------------------------------------------------------
--  util-encoders-aes -- AES encryption and decryption
--  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 Ada.Streams;
with Interfaces;

--  The Util.Encodes.SHA1 package generates SHA-1 hash according to
--  RFC3174 or [FIPS-180-1].
package Util.Encoders.AES is

   type Key_Type is private;

   --  ------------------------------
   --  ------------------------------
   subtype Block_Type is Ada.Streams.Stream_Element_Array (1 .. 16);

   procedure Set_Encrypt_Key (Key  : out Key_Type;
                              Data : in Ada.Streams.Stream_Element_Array);

   procedure Set_Decrypt_Key (Key  : out Key_Type;
                              Data : in Ada.Streams.Stream_Element_Array);

   procedure Encrypt (Input  : in Block_Type;
                      Output : out Block_Type;
                      Key    : in Key_Type);

   procedure Encrypt (Input  : in Ada.Streams.Stream_Element_Array;
                      Output : out Ada.Streams.Stream_Element_Array;
                      Last   : out Ada.Streams.Stream_Element_Offset;
                      Key    : in Key_Type);

   procedure Decrypt (Input  : in Block_Type;
                      Output : out Block_Type;
                      Key    : in Key_Type);

   --  ------------------------------
   --  AES encoder
   --  ------------------------------
   --  This Encoder translates the (binary) input stream into
   --  an SHA1 hexadecimal stream.  The encoding alphabet is: 0123456789ABCDEF.
   type Encoder is new Util.Encoders.Transformer with private;

   --  Encodes the binary input stream represented by Data into
   --  an SHA-1 hash output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   overriding
   procedure Transform (E       : in out Encoder;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset);

private

   type Encoder is new Util.Encoders.Transformer with null record;

   use Interfaces;

   type Block_Key is array (0 .. 59) of Unsigned_32;

   type Key_Type is record
      Key    : Block_Key;
      Rounds : Natural := 0;
   end record;

end Util.Encoders.AES;

Change the Transformer interface to accept in out parameter for the Transformer