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

with Util.Log.Loggers;

with ASF.Events.Phases;
with ASF.Components.Base;
with ASF.Events.Faces.Actions;

package body ASF.Components.Core.Views is

   use ASF;
   use EL.Objects;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Components.Core.Views");

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => ASF.Events.Faces.Faces_Event'Class,
                                     Name   => Faces_Event_Access);

   --  ------------------------------
   --  Get the content type returned by the view.
   --  ------------------------------
   function Get_Content_Type (UI      : in UIView;
                              Context : in Faces_Context'Class) return String is
   begin
      if Util.Beans.Objects.Is_Null (UI.Content_Type) then
         return UI.Get_Attribute (Name => "contentType", Context => Context);
      else
         return Util.Beans.Objects.To_String (UI.Content_Type);
      end if;
   end Get_Content_Type;

   --  ------------------------------
   --  Set the content type returned by the view.
   --  ------------------------------
   procedure Set_Content_Type (UI     : in out UIView;
                               Value  : in String) is
   begin
      UI.Content_Type := Util.Beans.Objects.To_Object (Value);
   end Set_Content_Type;

   --  ------------------------------
   --  Encode the begining of the view.  Set the response content type.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIView;
                           Context : in out Faces_Context'Class) is
      Content_Type : constant String := UI.Get_Content_Type (Context => Context);
   begin
      Context.Get_Response.Set_Content_Type (Content_Type);
   end Encode_Begin;

   --  ------------------------------
   --  Decode any new state of the specified component from the request contained
   --  in the specified context and store that state on the component.
   --
   --  During decoding, events may be enqueued for later processing
   --  (by event listeners that have registered an interest), by calling
   --  the Queue_Event on the associated component.
   --  ------------------------------
   overriding
   procedure Process_Decodes (UI      : in out UIView;
                              Context : in out Faces_Context'Class) is
   begin
      Base.UIComponent (UI).Process_Decodes (Context);

      --  Dispatch events queued for this phase.
      UIView'Class (UI).Broadcast (ASF.Events.Phases.APPLY_REQUEST_VALUES, Context);

      --  Drop other events if the response is to be returned.
      if Context.Get_Render_Response or Context.Get_Response_Completed then
         UIView'Class (UI).Clear_Events;
      end if;
   end Process_Decodes;

   --  ------------------------------
   --  Perform the component tree processing required by the Process Validations
   --  phase of the request processing lifecycle for all facets of this component,
   --  all children of this component, and this component itself, as follows:
   --

   --
If this component rendered property is false, skip further processing.
   --
Call the Process_Validators of all facets and children.
   --

   --  ------------------------------
   overriding
   procedure Process_Validators (UI      : in out UIView;
                                 Context : in out Faces_Context'Class) is
   begin
      Base.UIComponent (UI).Process_Validators (Context);

      --  Dispatch events queued for this phase.
      UIView'Class (UI).Broadcast (ASF.Events.Phases.PROCESS_VALIDATION, Context);

      --  Drop other events if the response is to be returned.
      if Context.Get_Render_Response or Context.Get_Response_Completed then
         UIView'Class (UI).Clear_Events;
      end if;
   end Process_Validators;

   --  ------------------------------
   --  Perform the component tree processing required by the Update Model Values
   --  phase of the request processing lifecycle for all facets of this component,
   --  all children of this component, and this component itself, as follows.
   --

   --
If this component rendered property is false, skip further processing.
   --
Call the Process_Updates/b> of all facets and children.
   --

   --  ------------------------------
   overriding
   procedure Process_Updates (UI      : in out UIView;
                              Context : in out Faces_Context'Class) is
   begin
      Base.UIComponent (UI).Process_Updates (Context);

      --  Dispatch events queued for this phase.
      UIView'Class (UI).Broadcast (ASF.Events.Phases.UPDATE_MODEL_VALUES, Context);

      --  Drop other events if the response is to be returned.
      if Context.Get_Render_Response or Context.Get_Response_Completed then
         UIView'Class (UI).Clear_Events;
      end if;
   end Process_Updates;

   --  ------------------------------
   --  Broadcast any events that have been queued for the Invoke Application
   --  phase of the request processing lifecycle and to clear out any events
   --  for later phases if the event processing for this phase caused
   --  renderResponse or responseComplete to be called.
   --  ------------------------------
   procedure Process_Application (UI      : in out UIView;
                                  Context : in out Faces_Context'Class) is
   begin
      --  Dispatch events queued for this phase.
      UIView'Class (UI).Broadcast (ASF.Events.Phases.INVOKE_APPLICATION, Context);
   end Process_Application;

   --  ------------------------------
   --  Queue an event for broadcast at the end of the current request
   --  processing lifecycle phase.  The event object
   --  will be freed after being dispatched.
   --  ------------------------------
   procedure Queue_Event (UI    : in out UIView;
                          Event : not null access ASF.Events.Faces.Faces_Event'Class) is
      use type Base.UIComponent_Access;

      Parent : constant Base.UIComponent_Access := UI.Get_Parent;
   begin
      if Parent /= null then
         Parent.Queue_Event (Event);
      else
         UI.Phase_Events (Event.Get_Phase).Append (Event.all'Access);
      end if;
   end Queue_Event;

   --  ------------------------------
   --  Broadcast the events after the specified lifecycle phase.
   --  Events that were queued will be freed.
   --  ------------------------------
   procedure Broadcast (UI      : in out UIView;
                        Phase   : in ASF.Lifecycles.Phase_Type;
                        Context : in out Faces_Context'Class) is

      Pos : Natural := 0;

      --  Broadcast the event to the component's listeners
      --  and free that event.
      procedure Broadcast (Ev : in out Faces_Event_Access);

      procedure Broadcast (Ev : in out Faces_Event_Access) is
      begin
         if Ev /= null then
            declare
               C  : constant Base.UIComponent_Access := Ev.Get_Component;
            begin
               C.Broadcast (Ev, Context);
            end;
            Free (Ev);
         end if;
      end Broadcast;

   begin
      --  Dispatch events in the order in which they were queued.
      --  More events could be queued as a result of the dispatch.
      --  After dispatching an event, it is freed but not removed
      --  from the event queue (the access will be cleared).
      loop
         exit when Pos > UI.Phase_Events (Phase).Last_Index;
         UI.Phase_Events (Phase).Update_Element (Pos, Broadcast'Access);
         Pos := Pos + 1;
      end loop;

      --  Now, clear the queue.
      UI.Phase_Events (Phase).Clear;
   end Broadcast;

   --  ------------------------------
   --  Clear the events that were queued.
   --  ------------------------------
   procedure Clear_Events (UI : in out UIView) is
   begin
      for Phase in UI.Phase_Events'Range loop
         for I in 0 .. UI.Phase_Events (Phase).Last_Index loop
            declare
               Ev : Faces_Event_Access := UI.Phase_Events (Phase).Element (I);
            begin
               Free (Ev);
            end;
         end loop;
         UI.Phase_Events (Phase).Clear;
      end loop;
   end Clear_Events;

   --  ------------------------------
   --  Set the metadata facet on the UIView component.
   --  ------------------------------
   procedure Set_Metadata (UI    : in out UIView;
                           Meta  : in UIViewMetaData_Access;
                           Tag   : access ASF.Views.Nodes.Tag_Node'Class) is
   begin
      if UI.Meta /= null then
         UI.Log_Error ("A <f:metadata> component was already registered.");
--           Delete (UI.Meta);
      end if;
      Meta.Root := UI'Unchecked_Access;
      UI.Meta := Meta;
      UI.Add_Facet (METADATA_FACET_NAME, Meta.all'Access, Tag);
   end Set_Metadata;

   --  ------------------------------
   --  Decode the request and prepare for the execution for the view action.
   --  ------------------------------
   overriding
   procedure Process_Decodes (UI      : in out UIViewAction;
                              Context : in out Faces_Context'Class) is
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;
      begin
         ASF.Events.Faces.Actions.Post_Event (UI     => UI,
                                              Method => UI.Get_Action_Expression (Context));

      exception
         when EL.Expressions.Invalid_Expression =>
            null;
      end;
   end Process_Decodes;

   --  ------------------------------
   --  Start encoding the UIComponent.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIViewMetaData;
                           Context : in out Faces_Context'Class) is
   begin
      UI.Root.Encode_Begin (Context);
   end Encode_Begin;

   --  ------------------------------
   --  Encode the children of this component.
   --  ------------------------------
   overriding
   procedure Encode_Children (UI      : in UIViewMetaData;
                              Context : in out Faces_Context'Class) is
   begin
      UI.Root.Encode_Children (Context);
   end Encode_Children;

   --  ------------------------------
   --  Finish encoding the component.
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIViewMetaData;
                         Context : in out Faces_Context'Class) is
   begin
      UI.Root.Encode_Begin (Context);
   end Encode_End;

   --  ------------------------------
   --  Queue an event for broadcast at the end of the current request
   --  processing lifecycle phase.  The event object
   --  will be freed after being dispatched.
   --  ------------------------------
   overriding
   procedure Queue_Event (UI    : in out UIViewMetaData;
                          Event : not null access ASF.Events.Faces.Faces_Event'Class) is
   begin
      UI.Root.Queue_Event (Event);
   end Queue_Event;

   --  Broadcast the events after the specified lifecycle phase.
   --  Events that were queued will be freed.
   overriding
   procedure Broadcast (UI      : in out UIViewMetaData;
                        Phase   : in ASF.Lifecycles.Phase_Type;
                        Context : in out Faces_Context'Class) is
   begin
      UI.Root.Broadcast (Phase, Context);
   end Broadcast;

   --  Clear the events that were queued.
   overriding
   procedure Clear_Events (UI : in out UIViewMetaData) is
   begin
      UI.Root.Clear_Events;
   end Clear_Events;

end ASF.Components.Core.Views;

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

with Util.Log.Loggers;

with ASF.Events.Phases;
with ASF.Components.Base;
with ASF.Events.Faces.Actions;

package body ASF.Components.Core.Views is

   use ASF;
   use EL.Objects;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Components.Core.Views");

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => ASF.Events.Faces.Faces_Event'Class,
                                     Name   => Faces_Event_Access);

   --  ------------------------------
   --  Get the content type returned by the view.
   --  ------------------------------
   function Get_Content_Type (UI      : in UIView;
                              Context : in Faces_Context'Class) return String is
   begin
      if Util.Beans.Objects.Is_Null (UI.Content_Type) then
         return UI.Get_Attribute (Name => "contentType", Context => Context);
      else
         return Util.Beans.Objects.To_String (UI.Content_Type);
      end if;
   end Get_Content_Type;

   --  ------------------------------
   --  Set the content type returned by the view.
   --  ------------------------------
   procedure Set_Content_Type (UI     : in out UIView;
                               Value  : in String) is
   begin
      UI.Content_Type := Util.Beans.Objects.To_Object (Value);
   end Set_Content_Type;

   --  ------------------------------
   --  Encode the begining of the view.  Set the response content type.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIView;
                           Context : in out Faces_Context'Class) is
      Content_Type : constant String := UI.Get_Content_Type (Context => Context);
   begin
      Context.Get_Response.Set_Content_Type (Content_Type);
   end Encode_Begin;

   --  ------------------------------
   --  Decode any new state of the specified component from the request contained
   --  in the specified context and store that state on the component.
   --
   --  During decoding, events may be enqueued for later processing
   --  (by event listeners that have registered an interest), by calling
   --  the Queue_Event on the associated component.
   --  ------------------------------
   overriding
   procedure Process_Decodes (UI      : in out UIView;
                              Context : in out Faces_Context'Class) is
   begin
      Base.UIComponent (UI).Process_Decodes (Context);

      --  Dispatch events queued for this phase.
      UIView'Class (UI).Broadcast (ASF.Events.Phases.APPLY_REQUEST_VALUES, Context);

      --  Drop other events if the response is to be returned.
      if Context.Get_Render_Response or Context.Get_Response_Completed then
         UIView'Class (UI).Clear_Events;
      end if;
   end Process_Decodes;

   --  ------------------------------
   --  Perform the component tree processing required by the Process Validations
   --  phase of the request processing lifecycle for all facets of this component,
   --  all children of this component, and this component itself, as follows:
   --

   --
If this component rendered property is false, skip further processing.
   --
Call the Process_Validators of all facets and children.
   --

   --  ------------------------------
   overriding
   procedure Process_Validators (UI      : in out UIView;
                                 Context : in out Faces_Context'Class) is
   begin
      Base.UIComponent (UI).Process_Validators (Context);

      --  Dispatch events queued for this phase.
      UIView'Class (UI).Broadcast (ASF.Events.Phases.PROCESS_VALIDATION, Context);

      --  Drop other events if the response is to be returned.
      if Context.Get_Render_Response or Context.Get_Response_Completed then
         UIView'Class (UI).Clear_Events;
      end if;
   end Process_Validators;

   --  ------------------------------
   --  Perform the component tree processing required by the Update Model Values
   --  phase of the request processing lifecycle for all facets of this component,
   --  all children of this component, and this component itself, as follows.
   --

   --
If this component rendered property is false, skip further processing.
   --
Call the Process_Updates/b> of all facets and children.
   --

   --  ------------------------------
   overriding
   procedure Process_Updates (UI      : in out UIView;
                              Context : in out Faces_Context'Class) is
   begin
      Base.UIComponent (UI).Process_Updates (Context);

      --  Dispatch events queued for this phase.
      UIView'Class (UI).Broadcast (ASF.Events.Phases.UPDATE_MODEL_VALUES, Context);

      --  Drop other events if the response is to be returned.
      if Context.Get_Render_Response or Context.Get_Response_Completed then
         UIView'Class (UI).Clear_Events;
      end if;
   end Process_Updates;

   --  ------------------------------
   --  Broadcast any events that have been queued for the Invoke Application
   --  phase of the request processing lifecycle and to clear out any events
   --  for later phases if the event processing for this phase caused
   --  renderResponse or responseComplete to be called.
   --  ------------------------------
   procedure Process_Application (UI      : in out UIView;
                                  Context : in out Faces_Context'Class) is
   begin
      --  Dispatch events queued for this phase.
      UIView'Class (UI).Broadcast (ASF.Events.Phases.INVOKE_APPLICATION, Context);
   end Process_Application;

   --  ------------------------------
   --  Queue an event for broadcast at the end of the current request
   --  processing lifecycle phase.  The event object
   --  will be freed after being dispatched.
   --  ------------------------------
   procedure Queue_Event (UI    : in out UIView;
                          Event : not null access ASF.Events.Faces.Faces_Event'Class) is
      use type Base.UIComponent_Access;

      Parent : constant Base.UIComponent_Access := UI.Get_Parent;
   begin
      if Parent /= null then
         Parent.Queue_Event (Event);
      else
         UI.Phase_Events (Event.Get_Phase).Append (Event.all'Access);
      end if;
   end Queue_Event;

   --  ------------------------------
   --  Broadcast the events after the specified lifecycle phase.
   --  Events that were queued will be freed.
   --  ------------------------------
   procedure Broadcast (UI      : in out UIView;
                        Phase   : in ASF.Lifecycles.Phase_Type;
                        Context : in out Faces_Context'Class) is

      Pos : Natural := 0;

      --  Broadcast the event to the component's listeners
      --  and free that event.
      procedure Broadcast (Ev : in out Faces_Event_Access);

      procedure Broadcast (Ev : in out Faces_Event_Access) is
      begin
         if Ev /= null then
            declare
               C  : constant Base.UIComponent_Access := Ev.Get_Component;
            begin
               C.Broadcast (Ev, Context);
            end;
            Free (Ev);
         end if;
      end Broadcast;

      use type Base.UIComponent_Access;

      Parent : constant Base.UIComponent_Access := UI.Get_Parent;
   begin
      if Parent /= null then
         UIView'Class (Parent.all).Broadcast (Phase, Context);
      else
         --  Dispatch events in the order in which they were queued.
         --  More events could be queued as a result of the dispatch.
         --  After dispatching an event, it is freed but not removed
         --  from the event queue (the access will be cleared).
         loop
            exit when Pos > UI.Phase_Events (Phase).Last_Index;
            UI.Phase_Events (Phase).Update_Element (Pos, Broadcast'Access);
            Pos := Pos + 1;
         end loop;

         --  Now, clear the queue.
         UI.Phase_Events (Phase).Clear;
      end if;
   end Broadcast;

   --  ------------------------------
   --  Clear the events that were queued.
   --  ------------------------------
   procedure Clear_Events (UI : in out UIView) is
   begin
      for Phase in UI.Phase_Events'Range loop
         for I in 0 .. UI.Phase_Events (Phase).Last_Index loop
            declare
               Ev : Faces_Event_Access := UI.Phase_Events (Phase).Element (I);
            begin
               Free (Ev);
            end;
         end loop;
         UI.Phase_Events (Phase).Clear;
      end loop;
   end Clear_Events;

   --  ------------------------------
   --  Set the metadata facet on the UIView component.
   --  ------------------------------
   procedure Set_Metadata (UI    : in out UIView;
                           Meta  : in UIViewMetaData_Access;
                           Tag   : access ASF.Views.Nodes.Tag_Node'Class) is
   begin
      if UI.Meta /= null then
         UI.Log_Error ("A <f:metadata> component was already registered.");
--           Delete (UI.Meta);
      end if;
      Meta.Root := UI'Unchecked_Access;
      UI.Meta := Meta;
      UI.Add_Facet (METADATA_FACET_NAME, Meta.all'Access, Tag);
   end Set_Metadata;

   --  ------------------------------
   --  Decode the request and prepare for the execution for the view action.
   --  ------------------------------
   overriding
   procedure Process_Decodes (UI      : in out UIViewAction;
                              Context : in out Faces_Context'Class) is
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;
      begin
         ASF.Events.Faces.Actions.Post_Event (UI     => UI,
                                              Method => UI.Get_Action_Expression (Context));

      exception
         when EL.Expressions.Invalid_Expression =>
            null;
      end;
   end Process_Decodes;

   --  ------------------------------
   --  Start encoding the UIComponent.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIViewMetaData;
                           Context : in out Faces_Context'Class) is
   begin
      UI.Root.Encode_Begin (Context);
   end Encode_Begin;

   --  ------------------------------
   --  Encode the children of this component.
   --  ------------------------------
   overriding
   procedure Encode_Children (UI      : in UIViewMetaData;
                              Context : in out Faces_Context'Class) is
   begin
      UI.Root.Encode_Children (Context);
   end Encode_Children;

   --  ------------------------------
   --  Finish encoding the component.
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIViewMetaData;
                         Context : in out Faces_Context'Class) is
   begin
      UI.Root.Encode_Begin (Context);
   end Encode_End;

   --  ------------------------------
   --  Queue an event for broadcast at the end of the current request
   --  processing lifecycle phase.  The event object
   --  will be freed after being dispatched.
   --  ------------------------------
   overriding
   procedure Queue_Event (UI    : in out UIViewMetaData;
                          Event : not null access ASF.Events.Faces.Faces_Event'Class) is
   begin
      UI.Root.Queue_Event (Event);
   end Queue_Event;

   --  Broadcast the events after the specified lifecycle phase.
   --  Events that were queued will be freed.
   overriding
   procedure Broadcast (UI      : in out UIViewMetaData;
                        Phase   : in ASF.Lifecycles.Phase_Type;
                        Context : in out Faces_Context'Class) is
   begin
      UI.Root.Broadcast (Phase, Context);
   end Broadcast;

   --  Clear the events that were queued.
   overriding
   procedure Clear_Events (UI : in out UIViewMetaData) is
   begin
      UI.Root.Clear_Events;
   end Clear_Events;

end ASF.Components.Core.Views;

Fix broadcast phase events - propagate the broadcast to the parent component until the root is reached


-----------------------------------------------------------------------
--  mat-types -- Global types
--  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.
-----------------------------------------------------------------------
package body MAT.Types is

   --  ------------------------------
   --  Return an hexadecimal string representation of the value.
   --  ------------------------------
   function Hex_Image (Value  : in Uint32;
                       Length : in Positive := 8) return String is
      use type Interfaces.Unsigned_32;

      Conversion : constant String (1 .. 16) := "0123456789ABCDEF";
      S : String (1 .. Length) := (others => '0');
      P : Uint32 := Value;
      N : Uint32;
      I : Positive := Length;
   begin
      while P /= 0 loop
         N := P mod 16;
         P := P / 16;
         S (I) := Conversion (Natural (N + 1));
         exit when I = 1;
         I := I - 1;
      end loop;
      return S;
   end Hex_Image;

end MAT.Types;

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

   --  ------------------------------
   --  Return an hexadecimal string representation of the value.
   --  ------------------------------
   function Hex_Image (Value  : in Uint32;
                       Length : in Positive := 8) return String is
      use type Interfaces.Unsigned_32;

      Conversion : constant String (1 .. 16) := "0123456789ABCDEF";
      S : String (1 .. Length) := (others => '0');
      P : Uint32 := Value;
      N : Uint32;
      I : Positive := Length;
   begin
      while P /= 0 loop
         N := P mod 16;
         P := P / 16;
         S (I) := Conversion (Natural (N + 1));
         exit when I = 1;
         I := I - 1;
      end loop;
      return S;
   end Hex_Image;

   --  ------------------------------
   --  Format the target time to a printable representation.
   --  ------------------------------
   function Tick_Image (Value : in Target_Tick_Ref) return String is
      use type Interfaces.Unsigned_64;

      Sec  : Interfaces.Unsigned_32 := Interfaces.Unsigned_32 (Interfaces.Shift_Right (Value, 32));
      Usec : Interfaces.Unsigned_32 := Interfaces.Unsigned_32 (Value and 16#0ffffffff#);
   begin
      return Interfaces.Unsigned_32'Image (Sec) & "." & Interfaces.Unsigned_32'Image (Usec);
   end Tick_Image;

end MAT.Types;

Implement the Tick_Image procedure

Implement the Tick_Image procedure


with Interfaces.C; use Interfaces.C;
with System;

package Mysql.My_list is

   pragma Pure;

   --  arg-macro: function list_rest (a)
   --    return (a).next;
   --  arg-macro: function list_push (a, b)
   --    return a):=list_cons((b),(a);
   --  Copyright (C) 2000 MySQL AB
   --   This program is free software; you can redistribute it and/or modify
   --   it under the terms of the GNU General Public License as published by
   --   the Free Software Foundation; version 2 of the License.
   --   This program is distributed in the hope that it will be useful,
   --   but WITHOUT ANY WARRANTY; without even the implied warranty of
   --   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   --   GNU General Public License for more details.
   --   You should have received a copy of the GNU General Public License
   --   along with this program; if not, write to the Free Software
   --   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   --  /usr/include/mysql/my_list.h:24:19
   type st_list is record
      prev : access st_list;
      next : access st_list;
      data : System.Address;
   end record;
   pragma Convention (C, st_list);

   subtype LIST is st_list;

   type List_Walk_Action is
     access function (arg1 : System.Address; arg2 : System.Address) return int;

   function list_add (arg1 : access st_list; arg2 : access st_list) return access st_list;
   pragma Import (C, list_add, "list_add");

   function list_delete (arg1 : access st_list; arg2 : access st_list) return access st_list;
   pragma Import (C, list_delete, "list_delete");

   function list_cons (arg1 : System.Address; arg2 : access st_list) return access st_list;
   pragma Import (C, list_cons, "list_cons");

   function list_reverse (arg1 : access st_list) return access st_list;
   pragma Import (C, list_reverse, "list_reverse");

   procedure list_free (arg1 : access st_list; arg2 : unsigned);
   pragma Import (C, list_free, "list_free");

   function list_length (arg1 : access st_list) return unsigned;
   pragma Import (C, list_length, "list_length");

end Mysql.My_list;

with Interfaces.C; use Interfaces.C;
with System;

package Mysql.My_list is

   pragma Preelaborate;

   --  arg-macro: function list_rest (a)
   --    return (a).next;
   --  arg-macro: function list_push (a, b)
   --    return a):=list_cons((b),(a);
   --  Copyright (C) 2000 MySQL AB
   --   This program is free software; you can redistribute it and/or modify
   --   it under the terms of the GNU General Public License as published by
   --   the Free Software Foundation; version 2 of the License.
   --   This program is distributed in the hope that it will be useful,
   --   but WITHOUT ANY WARRANTY; without even the implied warranty of
   --   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   --   GNU General Public License for more details.
   --   You should have received a copy of the GNU General Public License
   --   along with this program; if not, write to the Free Software
   --   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   --  /usr/include/mysql/my_list.h:24:19
   type st_list is record
      prev : access st_list;
      next : access st_list;
      data : System.Address;
   end record;
   pragma Convention (C, st_list);

   subtype LIST is st_list;

   type List_Walk_Action is
     access function (arg1 : System.Address; arg2 : System.Address) return int;

   function list_add (arg1 : access st_list; arg2 : access st_list) return access st_list;
   pragma Import (C, list_add, "list_add");

   function list_delete (arg1 : access st_list; arg2 : access st_list) return access st_list;
   pragma Import (C, list_delete, "list_delete");

   function list_cons (arg1 : System.Address; arg2 : access st_list) return access st_list;
   pragma Import (C, list_cons, "list_cons");

   function list_reverse (arg1 : access st_list) return access st_list;
   pragma Import (C, list_reverse, "list_reverse");

   procedure list_free (arg1 : access st_list; arg2 : unsigned);
   pragma Import (C, list_free, "list_free");

   function list_length (arg1 : access st_list) return unsigned;
   pragma Import (C, list_length, "list_length");

end Mysql.My_list;

Change to pragma Preelaborate to avoid a Pure warning for imported functions (use of pragma Pure_Function would be incorrect for the imported functions)


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

package body Wiki.Attributes is

   use Ada.Characters;

   --  ------------------------------
   --  Get the attribute name.
   --  ------------------------------
   function Get_Name (Position : in Cursor) return String is
      Attr : constant Attribute_Access := Attribute_Vectors.Element (Position.Pos);
   begin
      return Attr.Name;
   end Get_Name;

   --  ------------------------------
   --  Get the attribute value.
   --  ------------------------------
   function Get_Value (Position : in Cursor) return String is
      Attr : constant Attribute_Access := Attribute_Vectors.Element (Position.Pos);
   begin
      return Ada.Characters.Conversions.To_String (Attr.Value);
   end Get_Value;

   --  ------------------------------
   --  Get the attribute wide value.
   --  ------------------------------
   function Get_Wide_Value (Position : in Cursor) return Wide_Wide_String is
      Attr : constant Attribute_Access := Attribute_Vectors.Element (Position.Pos);
   begin
      return Attr.Value;
   end Get_Wide_Value;

   --  ------------------------------
   --  Get the attribute wide value.
   --  ------------------------------
   function Get_Unbounded_Wide_Value (Position : in Cursor) return Unbounded_Wide_Wide_String is
      Attr : constant Attribute_Access := Attribute_Vectors.Element (Position.Pos);
   begin
      return To_Unbounded_Wide_Wide_String (Attr.Value);
   end Get_Unbounded_Wide_Value;

   --  ------------------------------
   --  Returns True if the cursor has a valid attribute.
   --  ------------------------------
   function Has_Element (Position : in Cursor) return Boolean is
   begin
      return Attribute_Vectors.Has_Element (Position.Pos);
   end Has_Element;

   --  ------------------------------
   --  Move the cursor to the next attribute.
   --  ------------------------------
   procedure Next (Position : in out Cursor) is
   begin
      Attribute_Vectors.Next (Position.Pos);
   end Next;

   --  ------------------------------
   --  Find the attribute with the given name.
   --  ------------------------------
   function Find (List : in Attribute_List_Type;
                  Name : in String) return Cursor is
      Iter : Attribute_Vectors.Cursor := List.List.First;
   begin
      while Attribute_Vectors.Has_Element (Iter) loop
         declare
            Attr : constant Attribute_Access := Attribute_Vectors.Element (Iter);
         begin
            if Attr.Name = Name then
               return Cursor '(Pos => Iter);
            end if;
         end;
         Attribute_Vectors.Next (Iter);
      end loop;
      return Cursor '(Pos => Iter);
   end Find;

   --  ------------------------------
   --  Find the attribute with the given name and return its value.
   --  ------------------------------
   function Get_Attribute (List : in Attribute_List_Type;
                           Name : in String) return Unbounded_Wide_Wide_String is
      Attr : constant Cursor := Find (List, Name);
   begin
      if Has_Element (Attr) then
         return Get_Unbounded_Wide_Value (Attr);
      else
         return Null_Unbounded_Wide_Wide_String;
      end if;
   end Get_Attribute;

   --  ------------------------------
   --  Append the attribute to the attribute list.
   --  ------------------------------
   procedure Append (List  : in out Attribute_List_Type;
                     Name  : in Wide_Wide_String;
                     Value : in Wide_Wide_String) is
      Attr : constant Attribute_Access
        := new Attribute '(Name_Length  => Name'Length,
                           Value_Length => Value'Length,
                           Name         => Conversions.To_String (Name),
                           Value        => Value);
   begin
      List.List.Append (Attr);
   end Append;

   --  ------------------------------
   --  Append the attribute to the attribute list.
   --  ------------------------------
   procedure Append (List  : in out Attribute_List_Type;
                     Name  : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;
                     Value : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) is
   begin
      Append (List, Ada.Strings.Wide_Wide_Unbounded.To_Wide_Wide_String (Name),
              Ada.Strings.Wide_Wide_Unbounded.To_Wide_Wide_String (Value));
   end Append;

   --  ------------------------------
   --  Append the attribute to the attribute list.
   --  ------------------------------
   procedure Append (List  : in out Attribute_List_Type;
                     Name  : in String;
                     Value : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) is
      Val : constant Wide_Wide_String
        := To_Wide_Wide_String (Value);
      Attr : constant Attribute_Access
        := new Attribute '(Name_Length  => Name'Length,
                           Value_Length => Val'Length,
                           Name         => Name,
                           Value        => Val);
   begin
      List.List.Append (Attr);
   end Append;

   --  ------------------------------
   --  Get the cursor to get access to the first attribute.
   --  ------------------------------
   function First (List : in Attribute_List_Type) return Cursor is
   begin
      return Cursor '(Pos => List.List.First);
   end First;

   --  ------------------------------
   --  Get the number of attributes in the list.
   --  ------------------------------
   function Length (List : in Attribute_List_Type) return Natural is
   begin
      return Natural (List.List.Length);
   end Length;

   --  ------------------------------
   --  Clear the list and remove all existing attributes.
   --  ------------------------------
   procedure Clear (List : in out Attribute_List_Type) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Attribute,
                                        Name   => Attribute_Access);
      Item : Attribute_Access;
   begin
      while not List.List.Is_Empty loop
         Item := List.List.Last_Element;
         List.List.Delete_Last;
         Free (Item);
      end loop;
   end Clear;

   --  ------------------------------
   --  Iterate over the list attributes and call the <tt>Process</tt> procedure.
   --  ------------------------------
   procedure Iterate (List    : in Attribute_List_Type;
                      Process : not null access procedure (Name : in String;
                                                           Value : in Wide_Wide_String)) is
      Iter : Attribute_Vectors.Cursor := List.List.First;
      Item : Attribute_Access;
   begin
      while Attribute_Vectors.Has_Element (Iter) loop
         Item := Attribute_Vectors.Element (Iter);
         Process (Item.Name, Item.Value);
         Attribute_Vectors.Next (Iter);
      end loop;
   end Iterate;

   --  ------------------------------
   --  Finalize the attribute list releasing any storage.
   --  ------------------------------
   overriding
   procedure Finalize (List : in out Attribute_List_Type) is
   begin
      List.Clear;
   end Finalize;

end Wiki.Attributes;

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

package body Wiki.Attributes is

   use Ada.Characters;

   --  ------------------------------
   --  Get the attribute name.
   --  ------------------------------
   function Get_Name (Position : in Cursor) return String is
      Attr : constant Attribute_Ref := Attribute_Vectors.Element (Position.Pos);
   begin
      return Attr.Value.Name;
   end Get_Name;

   --  ------------------------------
   --  Get the attribute value.
   --  ------------------------------
   function Get_Value (Position : in Cursor) return String is
      Attr : constant Attribute_Ref := Attribute_Vectors.Element (Position.Pos);
   begin
      return Ada.Characters.Conversions.To_String (Attr.Value.Value);
   end Get_Value;

   --  ------------------------------
   --  Get the attribute wide value.
   --  ------------------------------
   function Get_Wide_Value (Position : in Cursor) return Wide_Wide_String is
      Attr : constant Attribute_Ref := Attribute_Vectors.Element (Position.Pos);
   begin
      return Attr.Value.Value;
   end Get_Wide_Value;

   --  ------------------------------
   --  Get the attribute wide value.
   --  ------------------------------
   function Get_Unbounded_Wide_Value (Position : in Cursor) return Unbounded_Wide_Wide_String is
      Attr : constant Attribute_Ref := Attribute_Vectors.Element (Position.Pos);
   begin
      return To_Unbounded_Wide_Wide_String (Attr.Value.Value);
   end Get_Unbounded_Wide_Value;

   --  ------------------------------
   --  Returns True if the cursor has a valid attribute.
   --  ------------------------------
   function Has_Element (Position : in Cursor) return Boolean is
   begin
      return Attribute_Vectors.Has_Element (Position.Pos);
   end Has_Element;

   --  ------------------------------
   --  Move the cursor to the next attribute.
   --  ------------------------------
   procedure Next (Position : in out Cursor) is
   begin
      Attribute_Vectors.Next (Position.Pos);
   end Next;

   --  ------------------------------
   --  Find the attribute with the given name.
   --  ------------------------------
   function Find (List : in Attribute_List_Type;
                  Name : in String) return Cursor is
      Iter : Attribute_Vectors.Cursor := List.List.First;
   begin
      while Attribute_Vectors.Has_Element (Iter) loop
         declare
            Attr : constant Attribute_Ref := Attribute_Vectors.Element (Iter);
         begin
            if Attr.Value.Name = Name then
               return Cursor '(Pos => Iter);
            end if;
         end;
         Attribute_Vectors.Next (Iter);
      end loop;
      return Cursor '(Pos => Iter);
   end Find;

   --  ------------------------------
   --  Find the attribute with the given name and return its value.
   --  ------------------------------
   function Get_Attribute (List : in Attribute_List_Type;
                           Name : in String) return Unbounded_Wide_Wide_String is
      Attr : constant Cursor := Find (List, Name);
   begin
      if Has_Element (Attr) then
         return Get_Unbounded_Wide_Value (Attr);
      else
         return Null_Unbounded_Wide_Wide_String;
      end if;
   end Get_Attribute;

   --  ------------------------------
   --  Append the attribute to the attribute list.
   --  ------------------------------
   procedure Append (List  : in out Attribute_List_Type;
                     Name  : in Wide_Wide_String;
                     Value : in Wide_Wide_String) is
      Attr : constant Attribute_Access
        := new Attribute '(Util.Refs.Ref_Entity with
                           Name_Length  => Name'Length,
                           Value_Length => Value'Length,
                           Name         => Conversions.To_String (Name),
                           Value        => Value);
   begin
      List.List.Append (Attribute_Refs.Create (Attr));
   end Append;

   --  ------------------------------
   --  Append the attribute to the attribute list.
   --  ------------------------------
   procedure Append (List  : in out Attribute_List_Type;
                     Name  : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;
                     Value : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) is
   begin
      Append (List, Ada.Strings.Wide_Wide_Unbounded.To_Wide_Wide_String (Name),
              Ada.Strings.Wide_Wide_Unbounded.To_Wide_Wide_String (Value));
   end Append;

   --  ------------------------------
   --  Append the attribute to the attribute list.
   --  ------------------------------
   procedure Append (List  : in out Attribute_List_Type;
                     Name  : in String;
                     Value : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) is
      Val : constant Wide_Wide_String
        := To_Wide_Wide_String (Value);
      Attr : constant Attribute_Access
        := new Attribute '(Util.Refs.Ref_Entity with
                           Name_Length  => Name'Length,
                           Value_Length => Val'Length,
                           Name         => Name,
                           Value        => Val);
   begin
      List.List.Append (Attribute_Refs.Create (Attr));
   end Append;

   --  ------------------------------
   --  Get the cursor to get access to the first attribute.
   --  ------------------------------
   function First (List : in Attribute_List_Type) return Cursor is
   begin
      return Cursor '(Pos => List.List.First);
   end First;

   --  ------------------------------
   --  Get the number of attributes in the list.
   --  ------------------------------
   function Length (List : in Attribute_List_Type) return Natural is
   begin
      return Natural (List.List.Length);
   end Length;

   --  ------------------------------
   --  Clear the list and remove all existing attributes.
   --  ------------------------------
   procedure Clear (List : in out Attribute_List_Type) is
--        procedure Free is
--          new Ada.Unchecked_Deallocation (Object => Attribute,
--                                          Name   => Attribute_Access);
--        Item : Attribute_Access;
   begin
--        while not List.List.Is_Empty loop
--           Item := List.List.Last_Element;
--           List.List.Delete_Last;
--           Free (Item);
--        end loop;
      List.List.Clear;
   end Clear;

   --  ------------------------------
   --  Iterate over the list attributes and call the <tt>Process</tt> procedure.
   --  ------------------------------
   procedure Iterate (List    : in Attribute_List_Type;
                      Process : not null access procedure (Name : in String;
                                                           Value : in Wide_Wide_String)) is
      Iter : Attribute_Vectors.Cursor := List.List.First;
      Item : Attribute_Ref;
   begin
      while Attribute_Vectors.Has_Element (Iter) loop
         Item := Attribute_Vectors.Element (Iter);
         Process (Item.Value.Name, Item.Value.Value);
         Attribute_Vectors.Next (Iter);
      end loop;
   end Iterate;

   --  ------------------------------
   --  Finalize the attribute list releasing any storage.
   --  ------------------------------
   overriding
   procedure Finalize (List : in out Attribute_List_Type) is
   begin
      List.Clear;
   end Finalize;

end Wiki.Attributes;

Use the reference for attributes

Use the reference for attributes


-----------------------------------------------------------------------
--  wiki-attributes -- Wiki document attributes
--  Copyright (C) 2015, 2016 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Wide_Wide_Unbounded;
private with Ada.Containers.Vectors;
private with Ada.Finalization;
private with Util.Refs;

--  === Attributes ===
--  The  <tt>Attributes</tt> package defines a simple management of attributes for
--  the wiki document parser.  Attribute lists are described by the <tt>Attribute_List</tt>
--  with some operations to append or query for an attribute.
package Wiki.Attributes is

   pragma Preelaborate;

   use Ada.Strings.Wide_Wide_Unbounded;

   type Cursor is private;

   --  Get the attribute name.
   function Get_Name (Position : in Cursor) return String;

   --  Get the attribute value.
   function Get_Value (Position : in Cursor) return String;

   --  Get the attribute wide value.
   function Get_Wide_Value (Position : in Cursor) return Wide_Wide_String;

   --  Get the attribute wide value.
   function Get_Unbounded_Wide_Value (Position : in Cursor) return Unbounded_Wide_Wide_String;

   --  Returns True if the cursor has a valid attribute.
   function Has_Element (Position : in Cursor) return Boolean;

   --  Move the cursor to the next attribute.
   procedure Next (Position : in out Cursor);

   --  A list of attributes.
   type Attribute_List is private;

   --  Find the attribute with the given name.
   function Find (List : in Attribute_List;
                  Name : in String) return Cursor;

   --  Find the attribute with the given name and return its value.
   function Get_Attribute (List : in Attribute_List;
                           Name : in String) return Unbounded_Wide_Wide_String;

   --  Find the attribute with the given name and return its value.
   function Get_Attribute (List : in Attribute_List;
                           Name : in String) return Wide_Wide_String;

   --  Append the attribute to the attribute list.
   procedure Append (List  : in out Attribute_List;
                     Name  : in Wide_Wide_String;
                     Value : in Wide_Wide_String);

   --  Append the attribute to the attribute list.
   procedure Append (List  : in out Attribute_List;
                     Name  : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;
                     Value : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String);

   --  Append the attribute to the attribute list.
   procedure Append (List  : in out Attribute_List;
                     Name  : in String;
                     Value : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String);

   --  Get the cursor to get access to the first attribute.
   function First (List : in Attribute_List) return Cursor;

   --  Get the number of attributes in the list.
   function Length (List : in Attribute_List) return Natural;

   --  Clear the list and remove all existing attributes.
   procedure Clear (List : in out Attribute_List);

   --  Iterate over the list attributes and call the <tt>Process</tt> procedure.
   procedure Iterate (List    : in Attribute_List;
                      Process : not null access procedure (Name : in String;
                                                           Value : in Wide_Wide_String));

private

   type Attribute (Name_Length, Value_Length : Natural) is limited
   new Util.Refs.Ref_Entity with record
      Name   : String (1 .. Name_Length);
      Value  : Wide_Wide_String (1 .. Value_Length);
   end record;
   type Attribute_Access is access all Attribute;

   package Attribute_Refs is new Util.Refs.Indefinite_References (Attribute, Attribute_Access);

   use Attribute_Refs;

   subtype Attribute_Ref is Attribute_Refs.Ref;

   package Attribute_Vectors is
     new Ada.Containers.Vectors (Index_Type   => Positive,
                                 Element_Type => Attribute_Ref);

   subtype Attribute_Vector is Attribute_Vectors.Vector;

   type Cursor is record
      Pos : Attribute_Vectors.Cursor;
   end record;

   type Attribute_List is new Ada.Finalization.Controlled with record
      List    : Attribute_Vector;
   end record;

   --  Finalize the attribute list releasing any storage.
   overriding
   procedure Finalize (List : in out Attribute_List);

end Wiki.Attributes;

-----------------------------------------------------------------------
--  wiki-attributes -- Wiki document attributes
--  Copyright (C) 2015, 2016 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Wide_Wide_Unbounded;
with Wiki.Strings;
private with Ada.Containers.Vectors;
private with Ada.Finalization;
private with Util.Refs;

--  === Attributes ===
--  The  <tt>Attributes</tt> package defines a simple management of attributes for
--  the wiki document parser.  Attribute lists are described by the <tt>Attribute_List</tt>
--  with some operations to append or query for an attribute.
package Wiki.Attributes is

   pragma Preelaborate;

   use Ada.Strings.Wide_Wide_Unbounded;

   type Cursor is private;

   --  Get the attribute name.
   function Get_Name (Position : in Cursor) return String;

   --  Get the attribute value.
   function Get_Value (Position : in Cursor) return String;

   --  Get the attribute wide value.
   function Get_Wide_Value (Position : in Cursor) return Wiki.Strings.WString;

   --  Get the attribute wide value.
   function Get_Unbounded_Wide_Value (Position : in Cursor) return Unbounded_Wide_Wide_String;

   --  Returns True if the cursor has a valid attribute.
   function Has_Element (Position : in Cursor) return Boolean;

   --  Move the cursor to the next attribute.
   procedure Next (Position : in out Cursor);

   --  A list of attributes.
   type Attribute_List is private;

   --  Find the attribute with the given name.
   function Find (List : in Attribute_List;
                  Name : in String) return Cursor;

   --  Find the attribute with the given name and return its value.
   function Get_Attribute (List : in Attribute_List;
                           Name : in String) return Unbounded_Wide_Wide_String;

   --  Find the attribute with the given name and return its value.
   function Get_Attribute (List : in Attribute_List;
                           Name : in String) return Wiki.Strings.WString;

   --  Append the attribute to the attribute list.
   procedure Append (List  : in out Attribute_List;
                     Name  : in Wiki.Strings.WString;
                     Value : in Wiki.Strings.WString);

   --  Append the attribute to the attribute list.
   procedure Append (List  : in out Attribute_List;
                     Name  : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;
                     Value : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String);

   --  Append the attribute to the attribute list.
   procedure Append (List  : in out Attribute_List;
                     Name  : in String;
                     Value : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String);

   --  Get the cursor to get access to the first attribute.
   function First (List : in Attribute_List) return Cursor;

   --  Get the number of attributes in the list.
   function Length (List : in Attribute_List) return Natural;

   --  Clear the list and remove all existing attributes.
   procedure Clear (List : in out Attribute_List);

   --  Iterate over the list attributes and call the <tt>Process</tt> procedure.
   procedure Iterate (List    : in Attribute_List;
                      Process : not null access procedure (Name  : in String;
                                                           Value : in Wiki.Strings.WString));

private

   type Attribute (Name_Length, Value_Length : Natural) is limited
   new Util.Refs.Ref_Entity with record
      Name   : String (1 .. Name_Length);
      Value  : Wiki.Strings.WString (1 .. Value_Length);
   end record;
   type Attribute_Access is access all Attribute;

   package Attribute_Refs is new Util.Refs.Indefinite_References (Attribute, Attribute_Access);

   use Attribute_Refs;

   subtype Attribute_Ref is Attribute_Refs.Ref;

   package Attribute_Vectors is
     new Ada.Containers.Vectors (Index_Type   => Positive,
                                 Element_Type => Attribute_Ref);

   subtype Attribute_Vector is Attribute_Vectors.Vector;

   type Cursor is record
      Pos : Attribute_Vectors.Cursor;
   end record;

   type Attribute_List is new Ada.Finalization.Controlled with record
      List    : Attribute_Vector;
   end record;

   --  Finalize the attribute list releasing any storage.
   overriding
   procedure Finalize (List : in out Attribute_List);

end Wiki.Attributes;

Use the Wiki.Strings.WString type

Use the Wiki.Strings.WString type


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

with Util.Tests;
with Ada.Strings.Unbounded;

package AWA.Commands.Tests is

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

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

   --  Test start and stop command.
   procedure Test_Start_Stop (T : in out Test);

   procedure Execute (T       : in out Test;
                      Command : in String;
                      Input   : in String;
                      Output  : in String;
                      Result  : out Ada.Strings.Unbounded.Unbounded_String;
                      Status  : in Natural := 0);

end AWA.Commands.Tests;

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

with Util.Tests;
with Ada.Strings.Unbounded;

package AWA.Commands.Tests is

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

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

   --  Test start and stop command.
   procedure Test_Start_Stop (T : in out Test);

   procedure Test_List_Tables (T : in out Test);

   procedure Execute (T       : in out Test;
                      Command : in String;
                      Input   : in String;
                      Output  : in String;
                      Result  : out Ada.Strings.Unbounded.Unbounded_String;
                      Status  : in Natural := 0);

end AWA.Commands.Tests;

Declare the Test_List_Tables procedure to test the 'list -t' command


-----------------------------------------------------------------------
--  components -- Component tree
--  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.
-----------------------------------------------------------------------

--  The <bASF.Components describes the components that form the
--  tree view.  Each component has attributes and children.  Children
--  represent sub-components and attributes control the rendering and
--  behavior of the component.
--
--  The component tree is created from the ASF.Views tag nodes
--  for each request.  Unlike tag nodes, the component tree is not shared.
with Ada.Strings.Unbounded;
with EL.Objects;
with EL.Expressions;
limited with ASF.Views.Nodes;
package ASF.Components is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Attribute of a component
   --  ------------------------------
   type UIAttribute is private;

private

   type UIAttribute_Access is access all UIAttribute;

   type UIAttribute is record
      Definition : access ASF.Views.Nodes.Tag_Attribute;
      Name       : Unbounded_String;
      Value      : EL.Objects.Object;
      Expr       : EL.Expressions.Expression;
      Next_Attr  : UIAttribute_Access;
   end record;

end ASF.Components;

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

--  The <bASF.Components describes the components that form the
--  tree view.  Each component has attributes and children.  Children
--  represent sub-components and attributes control the rendering and
--  behavior of the component.
--
--  The component tree is created from the ASF.Views tag nodes
--  for each request.  Unlike tag nodes, the component tree is not shared.
with Ada.Strings.Unbounded;
with EL.Objects;
with EL.Expressions;
limited with ASF.Views.Nodes;
package ASF.Components is

   use Ada.Strings.Unbounded;

   --  Flag indicating whether or not this component should be rendered
   --  (during Render Response Phase), or processed on any subsequent form submit.
   --  The default value for this property is true.
   RENDERED_NAME          : constant String := "rendered";

   --  A localized user presentable name for the component.
   LABEL_NAME             : constant String := "label";

   --  Converter instance registered with the component.
   CONVERTER_NAME         : constant String := "converter";

   --  A ValueExpression enabled attribute that, if present, will be used as the text
   --  of the converter message, replacing any message that comes from the converter.
   CONVERTER_MESSAGE_NAME : constant String := "converterMessage";

   --  A ValueExpression enabled attribute that, if present, will be used as the text
   --  of the validator message, replacing any message that comes from the validator.
   VALIDATOR_MESSAGE_NAME : constant String := "validatorMessage";

   --  Flag indicating that the user is required to provide a submitted value for
   --  the input component.
   REQUIRED_NAME          : constant String := "required";

   --  A ValueExpression enabled attribute that, if present, will be used as the
   --  text of the validation message for the "required" facility, if the "required"
   --  facility is used.
   REQUIRED_MESSAGE_NAME  : constant String := "requiredMessage";

   --  ------------------------------
   --  Attribute of a component
   --  ------------------------------
   type UIAttribute is private;

private

   type UIAttribute_Access is access all UIAttribute;

   type UIAttribute is record
      Definition : access ASF.Views.Nodes.Tag_Attribute;
      Name       : Unbounded_String;
      Value      : EL.Objects.Object;
      Expr       : EL.Expressions.Expression;
      Next_Attr  : UIAttribute_Access;
   end record;

end ASF.Components;

Define the name of commonly used attributes


-----------------------------------------------------------------------
--  serialize -- JSON serialization
--  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.Text_IO;
with Util.Serialize.IO.JSON;
with Util.Streams.Texts;
with Util.Streams.Buffered;
procedure Serialize is
   Output : aliased Util.Streams.Texts.Print_Stream;
   Stream : Util.Serialize.IO.JSON.Output_Stream;
begin
   Output.Initialize (Size => 10000);
   Stream.Initialize (Output => Output'Unchecked_Access);
   Stream.Start_Document;
   Stream.Start_Entity ("person");
   Stream.Write_Entity ("name", "Harry Potter");
   Stream.Write_Entity ("gender", "male");
   Stream.Write_Entity ("age", 17);
   Stream.End_Entity ("person");
   Stream.End_Document;
   Ada.Text_IO.Put_Line (Util.Streams.Texts.To_String (Output));
end Serialize;

-----------------------------------------------------------------------
--  serialize -- JSON serialization
--  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.Text_IO;
with Util.Serialize.IO.JSON;
with Util.Streams.Texts;
procedure Serialize is
   Output : aliased Util.Streams.Texts.Print_Stream;
   Stream : Util.Serialize.IO.JSON.Output_Stream;
begin
   Output.Initialize (Size => 10000);
   Stream.Initialize (Output => Output'Unchecked_Access);
   Stream.Start_Document;
   Stream.Start_Entity ("person");
   Stream.Write_Entity ("name", "Harry Potter");
   Stream.Write_Entity ("gender", "male");
   Stream.Write_Entity ("age", 17);
   Stream.End_Entity ("person");
   Stream.End_Document;
   Ada.Text_IO.Put_Line (Util.Streams.Texts.To_String (Output));
end Serialize;

Remove unecessary with clause for Util.Streams.Buffered


-----------------------------------------------------------------------
--  Security testsuite - Ada Security Test suite
--  Copyright (C) 2011, 2012, 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 Security.OpenID.Tests;
with Security.Permissions.Tests;
with Security.Policies.Tests;
with Security.OAuth.JWT.Tests;
package body Security.Testsuite is

   Tests : aliased Util.Tests.Test_Suite;

   function Suite return Util.Tests.Access_Test_Suite is
      Ret : constant Util.Tests.Access_Test_Suite := Tests'Access;
   begin
      Security.OAuth.JWT.Tests.Add_Tests (Ret);
      Security.OpenID.Tests.Add_Tests (Ret);
      Security.Permissions.Tests.Add_Tests (Ret);
      Security.Policies.Tests.Add_Tests (Ret);
      return Ret;
   end Suite;

end Security.Testsuite;

-----------------------------------------------------------------------
--  Security testsuite - Ada Security Test suite
--  Copyright (C) 2011, 2012, 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 Security.OpenID.Tests;
with Security.Permissions.Tests;
with Security.Policies.Tests;
with Security.OAuth.JWT.Tests;
with Security.OAuth.Clients.Tests;
package body Security.Testsuite is

   Tests : aliased Util.Tests.Test_Suite;

   function Suite return Util.Tests.Access_Test_Suite is
      Ret : constant Util.Tests.Access_Test_Suite := Tests'Access;
   begin
      Security.OAuth.JWT.Tests.Add_Tests (Ret);
      Security.OpenID.Tests.Add_Tests (Ret);
      Security.Permissions.Tests.Add_Tests (Ret);
      Security.Policies.Tests.Add_Tests (Ret);
      Security.OAuth.Clients.Tests.Add_Tests (Ret);
      return Ret;
   end Suite;

end Security.Testsuite;

Add the new unit tests

Add the new unit tests


-----------------------------------------------------------------------
--  ADO Tests -- Database sequence generator
--  Copyright (C) 2009, 2010, 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 ADO.Sessions.Sources;
with ADO.Sessions.Factory;

package body Regtests is

   Factory    : aliased ADO.Sessions.Factory.Session_Factory;
   Controller : aliased ADO.Sessions.Sources.Data_Source;

   --  ------------------------------
   --  Get the database manager to be used for the unit tests
   --  ------------------------------
   function Get_Controller return ADO.Sessions.Sources.Data_Source'Class is
   begin
      return Controller;
   end Get_Controller;

   --  ------------------------------
   --  Get the readonly connection database to be used for the unit tests
   --  ------------------------------
   function Get_Database return ADO.Sessions.Session is
   begin
      return Factory.Get_Session;
   end Get_Database;

   --  ------------------------------
   --  Get the writeable connection database to be used for the unit tests
   --  ------------------------------
   function Get_Master_Database return ADO.Sessions.Master_Session is
   begin
      return Factory.Get_Master_Session;
   end Get_Master_Database;

   --  ------------------------------
   --  Initialize the test database
   --  ------------------------------
   procedure Initialize (Name : in String) is
   begin
      Controller.Set_Connection (Name);
      Factory.Create (Controller);
   end Initialize;

end Regtests;

-----------------------------------------------------------------------
--  ADO Tests -- Database sequence generator
--  Copyright (C) 2009, 2010, 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 ADO.Sessions.Factory;

package body Regtests is

   Factory    : aliased ADO.Sessions.Factory.Session_Factory;
   Controller : aliased ADO.Sessions.Sources.Data_Source;

   --  ------------------------------
   --  Get the database manager to be used for the unit tests
   --  ------------------------------
   function Get_Controller return ADO.Sessions.Sources.Data_Source'Class is
   begin
      return Controller;
   end Get_Controller;

   --  ------------------------------
   --  Get the readonly connection database to be used for the unit tests
   --  ------------------------------
   function Get_Database return ADO.Sessions.Session is
   begin
      return Factory.Get_Session;
   end Get_Database;

   --  ------------------------------
   --  Get the writeable connection database to be used for the unit tests
   --  ------------------------------
   function Get_Master_Database return ADO.Sessions.Master_Session is
   begin
      return Factory.Get_Master_Session;
   end Get_Master_Database;

   --  ------------------------------
   --  Initialize the test database
   --  ------------------------------
   procedure Initialize (Name : in String) is
   begin
      Controller.Set_Connection (Name);
      Factory.Create (Controller);
   end Initialize;

end Regtests;

Fix compilation warning detected by GNAT 2017


with GNAT.Command_Line;  use GNAT.Command_Line;
with GNAT.IO;  use GNAT.IO;
with GNAT.Traceback.Symbolic;
with Ada.Exceptions;
with Ada.Command_Line;
with Ada.Text_IO;
with Babel;
with Babel.Files;
with Ada.Directories;
with Ada.Strings.Unbounded;
with Util.Encoders;
with Util.Encoders.Base16;
with Util.Log.Loggers;
with Babel.Filters;
with Babel.Files.Buffers;
with Babel.Files.Queues;
with Babel.Stores.Local;
with Babel.Strategies.Default;
with Babel.Strategies.Workers;
with Babel.Base.Text;
with Babel.Base.Users;
with Babel.Streams;
with Babel.Streams.XZ;
with Babel.Streams.Cached;
with Babel.Streams.Files;
with Tar;
procedure babel_main is

   use Ada.Strings.Unbounded;

   Out_Dir     : Ada.Strings.Unbounded.Unbounded_String;
   Dir         : Babel.Files.Directory_Type;
   Hex_Encoder : Util.Encoders.Base16.Encoder;
   Exclude     : aliased Babel.Filters.Exclude_Directory_Filter_Type;
   Local       : aliased Babel.Stores.Local.Local_Store_Type;
   Backup      : aliased Babel.Strategies.Default.Default_Strategy_Type;
   Buffers     : aliased Babel.Files.Buffers.Buffer_Pool;
   Store       : aliased Babel.Stores.Local.Local_Store_Type;
   Database    : aliased Babel.Base.Text.Text_Database;
   Queue       : aliased Babel.Files.Queues.File_Queue;
   Debug       : Boolean := False;
   Task_Count  : Positive := 2;

   --
--     procedure Print_Sha (Path : in String;
--                          File : in out Babel.Files.File) is
--        Sha : constant String := Hex_Encoder.Transform (File.SHA1);
--     begin
--        Put_Line (Path & "/" & To_String (File.Name) & " => " & Sha);
--     end Print_Sha;

   procedure Usage is
   begin
      Ada.Text_IO.Put_Line ("babel [-d] [-t count] {command} [options]");
      Ada.Text_IO.Put_Line (" -d        Debug mode");
      Ada.Text_IO.Put_Line (" -t count  Number of tasks to create");
      Ada.Text_IO.New_Line;
      Ada.Text_IO.Put_Line ("Commands:");
      Ada.Text_IO.Put_Line (" copy <dst-dir> <src-dir>");
      Ada.Text_IO.Put_Line (" scan <src-dir>");
      Ada.Command_Line.Set_Exit_Status (2);
   end Usage;

   procedure Configure (Strategy : in out Babel.Strategies.Default.Default_Strategy_Type) is
   begin
      Strategy.Set_Filters (Exclude'Unchecked_Access);
      Strategy.Set_Stores (Read => Local'Unchecked_Access, Write => Store'Unchecked_Access);
      Strategy.Set_Buffers (Buffers'Unchecked_Access);
      Strategy.Set_Database (Database'Unchecked_Access);
      Strategy.Set_Queue (Queue'Unchecked_Access);
   end Configure;

   package Backup_Workers is
      new Babel.Strategies.Workers (Babel.Strategies.Default.Default_Strategy_Type);

   procedure Do_Backup (Count : in Positive) is
      Workers   : Backup_Workers.Worker_Type (Count);
      Container : Babel.Files.Default_Container;
      Queue     : Babel.Files.Queues.Directory_Queue;
   begin
      Babel.Files.Queues.Add_Directory (Queue, Dir);
      Configure (Backup);
      Backup_Workers.Configure (Workers, Configure'Access);
      Backup_Workers.Start (Workers);
      Backup.Scan (Queue, Container);
      Backup_Workers.Finish (Workers, Database);
   end Do_Backup;

   procedure Do_Copy is
      Dst : constant String := GNAT.Command_Line.Get_Argument;
      Src : constant String := GNAT.Command_Line.Get_Argument;
   begin
      Dir := Babel.Files.Allocate (Name => Src,
                                   Dir  => Babel.Files.NO_DIRECTORY);
      --  Exclude.Add_Exclude (".svn");
      --  Exclude.Add_Exclude ("obj");
      Babel.Files.Buffers.Create_Pool (Into => Buffers, Count => 10, Size => 20_000_000);
      Store.Set_Root_Directory (Dst);
      Local.Set_Root_Directory ("");
      Store.Set_Buffers (Buffers'Unchecked_Access);
      Local.Set_Buffers (Buffers'Unchecked_Access);

      Do_Backup (Task_Count);
      Database.Save ("database.txt");
   end Do_Copy;

   procedure Do_Scan is
      Src : constant String := GNAT.Command_Line.Get_Argument;
   begin
      Dir := Babel.Files.Allocate (Name => Src,
                                   Dir  => Babel.Files.NO_DIRECTORY);
      Exclude.Add_Exclude (".svn");
      Exclude.Add_Exclude ("obj");
      Babel.Files.Buffers.Create_Pool (Into => Buffers, Count => 10, Size => 1_000_000);
      Local.Set_Root_Directory (Src);

      Do_Backup (Task_Count);
      Database.Save ("database.txt");
   end Do_Scan;

begin
   Util.Log.Loggers.Initialize ("babel.properties");
   Initialize_Option_Scan (Stop_At_First_Non_Switch => True, Section_Delimiters => "targs");

   --  Parse the command line
   loop
      case Getopt ("* v o: t:") is
         when ASCII.NUL =>
            exit;

         when 'o' =>
            Out_Dir := To_Unbounded_String (Parameter & "/");

         when 'd' =>
            Debug := True;

         when 't' =>
            Task_Count := Positive'Value (Parameter);

         when '*' =>
            exit;

         when others =>
            null;
      end case;
   end loop;
   if Ada.Command_Line.Argument_Count = 0 then
      Usage;
      return;
   end if;
   declare
      Cmd_Name  : constant String := Full_Switch;
   begin
      if Cmd_Name = "copy" then
         Do_Copy;
      elsif Cmd_Name = "scan" then
         Do_Scan;
      else
         Usage;
      end if;
   end;

exception
   when E : Invalid_Switch =>
      Ada.Text_IO.Put_Line ("Invalid option: " & Ada.Exceptions.Exception_Message (E));
      Usage;

   when E : others =>
      Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Message (E));
      Ada.Text_IO.Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E));
      Ada.Command_Line.Set_Exit_Status (1);

end babel_main;

with GNAT.Command_Line;  use GNAT.Command_Line;
with GNAT.IO;  use GNAT.IO;
with GNAT.Traceback.Symbolic;
with Ada.Exceptions;
with Ada.Command_Line;
with Ada.Text_IO;
with Babel;
with Babel.Files;
with Ada.Directories;
with Ada.Strings.Unbounded;
with Util.Encoders;
with Util.Encoders.Base16;
with Util.Log.Loggers;
with Babel.Filters;
with Babel.Files.Buffers;
with Babel.Files.Queues;
with Babel.Stores.Local;
with Babel.Strategies.Default;
with Babel.Strategies.Workers;
with Babel.Base.Text;
with Babel.Base.Users;
with Babel.Streams;
with Babel.Streams.XZ;
with Babel.Streams.Cached;
with Babel.Streams.Files;
with Tar;
procedure babel_main is

   use Ada.Strings.Unbounded;

   Out_Dir     : Ada.Strings.Unbounded.Unbounded_String;
   Dir         : Babel.Files.Directory_Type;
   Hex_Encoder : Util.Encoders.Base16.Encoder;
   Exclude     : aliased Babel.Filters.Exclude_Directory_Filter_Type;
   Local       : aliased Babel.Stores.Local.Local_Store_Type;
   Backup      : aliased Babel.Strategies.Default.Default_Strategy_Type;
   Buffers     : aliased Babel.Files.Buffers.Buffer_Pool;
   Store       : aliased Babel.Stores.Local.Local_Store_Type;
   Database    : aliased Babel.Base.Text.Text_Database;
   Queue       : aliased Babel.Files.Queues.File_Queue;
   Debug       : Boolean := False;
   Task_Count  : Positive := 2;

   --
--     procedure Print_Sha (Path : in String;
--                          File : in out Babel.Files.File) is
--        Sha : constant String := Hex_Encoder.Transform (File.SHA1);
--     begin
--        Put_Line (Path & "/" & To_String (File.Name) & " => " & Sha);
--     end Print_Sha;

   procedure Usage is
   begin
      Ada.Text_IO.Put_Line ("babel [-d] [-t count] {command} [options]");
      Ada.Text_IO.Put_Line (" -d        Debug mode");
      Ada.Text_IO.Put_Line (" -t count  Number of tasks to create");
      Ada.Text_IO.New_Line;
      Ada.Text_IO.Put_Line ("Commands:");
      Ada.Text_IO.Put_Line (" copy <dst-dir> <src-dir>");
      Ada.Text_IO.Put_Line (" scan <src-dir>");
      Ada.Command_Line.Set_Exit_Status (2);
   end Usage;

   package Backup_Workers is
      new Babel.Strategies.Workers (Babel.Strategies.Default.Default_Strategy_Type);

   procedure Do_Backup (Count : in Positive) is
      Workers   : Backup_Workers.Worker_Type (Count);
      Container : Babel.Files.Default_Container;
      Dir_Queue : Babel.Files.Queues.Directory_Queue;

      procedure Configure (Strategy : in out Babel.Strategies.Default.Default_Strategy_Type) is
      begin
         Strategy.Set_Filters (Exclude'Unchecked_Access);
         Strategy.Set_Stores (Read => Local'Unchecked_Access, Write => Store'Unchecked_Access);
         Strategy.Set_Buffers (Buffers'Unchecked_Access);
         Strategy.Set_Queue (Queue'Unchecked_Access);
      end Configure;

   begin
      Babel.Files.Queues.Add_Directory (Dir_Queue, Dir);
      Configure (Backup);
      Backup_Workers.Configure (Workers, Configure'Access);
      Backup_Workers.Start (Workers);
      Backup.Scan (Dir_Queue, Container);
      Backup_Workers.Finish (Workers, Database);
   end Do_Backup;

   procedure Do_Copy is
      Dst : constant String := GNAT.Command_Line.Get_Argument;
      Src : constant String := GNAT.Command_Line.Get_Argument;
   begin
      Dir := Babel.Files.Allocate (Name => Src,
                                   Dir  => Babel.Files.NO_DIRECTORY);

      Store.Set_Root_Directory (Dst);
      Local.Set_Root_Directory ("");

      Do_Backup (Task_Count);
      Database.Save ("database.txt");
   end Do_Copy;

   procedure Do_Scan is
      Src       : constant String := GNAT.Command_Line.Get_Argument;
      Workers   : Backup_Workers.Worker_Type (Task_Count);
      Container : Babel.Files.Default_Container;
      Dir_Queue : Babel.Files.Queues.Directory_Queue;

      procedure Configure (Strategy : in out Babel.Strategies.Default.Default_Strategy_Type) is
      begin
         Strategy.Set_Filters (Exclude'Unchecked_Access);
         Strategy.Set_Stores (Read => Local'Unchecked_Access, Write => null);
         Strategy.Set_Buffers (Buffers'Unchecked_Access);
         Strategy.Set_Queue (Queue'Unchecked_Access);
      end Configure;

   begin
      Dir := Babel.Files.Allocate (Name => Src,
                                   Dir  => Babel.Files.NO_DIRECTORY);

      Local.Set_Root_Directory ("");
      Babel.Files.Queues.Add_Directory (Dir_Queue, Dir);
      Configure (Backup);
      Backup_Workers.Configure (Workers, Configure'Access);
      Backup_Workers.Start (Workers);
      Backup.Scan (Dir_Queue, Container);
      Backup_Workers.Finish (Workers, Database);
      Database.Save ("database-scan.txt");
   end Do_Scan;

begin
   Util.Log.Loggers.Initialize ("babel.properties");
   Initialize_Option_Scan (Stop_At_First_Non_Switch => True, Section_Delimiters => "targs");

   --  Parse the command line
   loop
      case Getopt ("* v o: t:") is
         when ASCII.NUL =>
            exit;

         when 'o' =>
            Out_Dir := To_Unbounded_String (Parameter & "/");

         when 'd' =>
            Debug := True;

         when 't' =>
            Task_Count := Positive'Value (Parameter);

         when '*' =>
            exit;

         when others =>
            null;
      end case;
   end loop;
   if Ada.Command_Line.Argument_Count = 0 then
      Usage;
      return;
   end if;
   Babel.Files.Buffers.Create_Pool (Into => Buffers, Count => 100, Size => 64 * 1024);
   Store.Set_Buffers (Buffers'Unchecked_Access);
   Local.Set_Buffers (Buffers'Unchecked_Access);
   declare
      Cmd_Name  : constant String := Full_Switch;
   begin
      if Cmd_Name = "copy" then
         Do_Copy;
      elsif Cmd_Name = "scan" then
         Do_Scan;
      else
         Usage;
      end if;
   end;

exception
   when E : Invalid_Switch =>
      Ada.Text_IO.Put_Line ("Invalid option: " & Ada.Exceptions.Exception_Message (E));
      Usage;

   when E : others =>
      Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Message (E));
      Ada.Text_IO.Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E));
      Ada.Command_Line.Set_Exit_Status (1);

end babel_main;

Update for the scan command to only scan and build the SHA1 signatures


-----------------------------------------------------------------------
--  Security-policies-tests - Unit tests for Security.Permissions
--  Copyright (C) 2011, 2012, 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 Util.Tests;
with Util.Strings;

with Security.Policies.Roles;

package Security.Policies.Tests is

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

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

   --  Test Create_Role and Get_Role_Name
   procedure Test_Create_Role (T : in out Test);

   --  Test Set_Roles
   procedure Test_Set_Roles (T : in out Test);

   --  Test Set_Roles on an invalid role name
   procedure Test_Set_Invalid_Roles (T : in out Test);

   --  Test the Get_Policy, Get_Role_Policy and Add_Policy operations.
   procedure Test_Get_Role_Policy (T : in out Test);

   --  Test Has_Permission
   procedure Test_Has_Permission (T : in out Test);

   --  Test reading an empty policy file
   procedure Test_Read_Empty_Policy (T : in out Test);

   --  Test reading policy files
   procedure Test_Read_Policy (T : in out Test);

   --  Test reading policy files and using the <role-permission> controller
   procedure Test_Role_Policy (T : in out Test);

   --  Test anonymous users and permissions.
   procedure Test_Anonymous_Permission (T : in out Test);

      --  Read the policy file <b>File</b> and perform a test on the given URI
   --  with a user having the given role.
   procedure Check_Policy (T         : in out Test;
                           File      : in String;
                           Role      : in String;
                           URL       : in String;
                           Anonymous : in Boolean := False;
                           Granted   : in Boolean := True);

   type Test_Principal is new Principal and Roles.Role_Principal_Context with record
      Name  : Util.Strings.String_Ref;
      Roles : Security.Policies.Roles.Role_Map := (others => False);
   end record;

   --  Get the roles assigned to the user.
   overriding
   function Get_Roles (User : in Test_Principal) return Roles.Role_Map;

   --  Get the principal name.
   function Get_Name (From : in Test_Principal) return String;

end Security.Policies.Tests;

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

with Util.Tests;
with Util.Strings;

with Security.Policies.Roles;

package Security.Policies.Tests is

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

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

   --  Test Create_Role and Get_Role_Name
   procedure Test_Create_Role (T : in out Test);

   --  Test Set_Roles
   procedure Test_Set_Roles (T : in out Test);

   --  Test Set_Roles on an invalid role name
   procedure Test_Set_Invalid_Roles (T : in out Test);

   --  Test the Get_Policy, Get_Role_Policy and Add_Policy operations.
   procedure Test_Get_Role_Policy (T : in out Test);

   --  Test Has_Permission
   procedure Test_Has_Permission (T : in out Test);

   --  Test reading an empty policy file
   procedure Test_Read_Empty_Policy (T : in out Test);

   --  Test reading policy files
   procedure Test_Read_Policy (T : in out Test);

   --  Test reading policy files and using the <role-permission> controller
   procedure Test_Role_Policy (T : in out Test);

   --  Test the Get_Grants operation.
   procedure Test_Grants (T : in out Test);

   --  Test anonymous users and permissions.
   procedure Test_Anonymous_Permission (T : in out Test);

      --  Read the policy file <b>File</b> and perform a test on the given URI
   --  with a user having the given role.
   procedure Check_Policy (T         : in out Test;
                           File      : in String;
                           Role      : in String;
                           URL       : in String;
                           Anonymous : in Boolean := False;
                           Granted   : in Boolean := True);

   type Test_Principal is new Principal and Roles.Role_Principal_Context with record
      Name  : Util.Strings.String_Ref;
      Roles : Security.Policies.Roles.Role_Map := (others => False);
   end record;

   --  Get the roles assigned to the user.
   overriding
   function Get_Roles (User : in Test_Principal) return Roles.Role_Map;

   --  Get the principal name.
   function Get_Name (From : in Test_Principal) return String;

end Security.Policies.Tests;

Declare the Test_Grants procedure

Declare the Test_Grants procedure