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

   procedure Free is
      new Ada.Unchecked_Deallocation (Frame, Frame_Type);

   --  ------------------------------
   --  Return the parent frame.
   --  ------------------------------
   function Parent (Frame : in Frame_Type) return Frame_Type is
   begin
      if Frame = null then
         return null;
      else
         return Frame.Parent;
      end if;
   end Parent;

   --  ------------------------------
   --  Returns the backtrace of the current frame (up to the root).
   --  ------------------------------
   function Backtrace (Frame :  in Frame_Type) return Frame_Table is
      Pc      : Frame_Table (1 .. Frame.Depth);
      Current : Frame_Type := Frame;
      Pos     : Natural   := Current.Depth;
      New_Pos : Natural;
   begin
      while Current /= null and Pos /= 0 loop
         New_Pos := Pos - Current.Local_Depth + 1;
         Pc (New_Pos .. Pos) := Current.Calls (1 .. Current.Local_Depth);
         Pos     := New_Pos - 1;
         Current := Current.Parent;
      end loop;
      return Pc;
   end Backtrace;

   --  ------------------------------
   --  Returns the number of children in the frame.
   --  When recursive is true, compute in the sub-tree.
   --  ------------------------------
   function Count_Children (Frame     : in Frame_Type;
                            Recursive : in Boolean := False) return Natural is
      Count : Natural := 0;
      Child : Frame_Type;
   begin
      if Frame /= null then
         Child := Frame.Children;
         while Child /= null loop
            Count := Count + 1;
            if Recursive then
               declare
                  N : Natural := Count_Children (Child, True);
               begin
                  if N > 0 then
                     N := N - 1;
                  end if;
                  Count := Count + N;
               end;
            end if;
            Child := Child.Next;
         end loop;
      end if;
      return Count;
   end Count_Children;

   --  ------------------------------
   --  Returns all the direct calls made by the current frame.
   --  ------------------------------
   function Calls (Frame : in Frame_Type) return Frame_Table is
      Nb_Calls : Natural   := Count_Children (Frame);
      Pc       : Frame_Table (1 .. Nb_Calls);
   begin
      if Frame /= null then
         declare
            Child : Frame_Type := Frame.Children;
            Pos   : Natural   := 1;
         begin
            while Child /= null loop
               Pc (Pos) := Child.Calls (1);
               Pos   := Pos + 1;
               Child := Child.Next;
            end loop;
         end;
      end if;
      return Pc;
   end Calls;

   --  ------------------------------
   --  Returns the current stack depth (# of calls from the root
   --  to reach the frame).
   --  ------------------------------
   function Current_Depth (Frame : in Frame_Type) return Natural is
   begin
      if Frame = null then
         return 0;
      else
         return Frame.Depth;
      end if;
   end Current_Depth;

   --  ------------------------------
   --  Create a root for stack frame representation.
   --  ------------------------------
   function Create_Root return Frame_Type is
   begin
      return new Frame;
   end Create_Root;

   --  Destroy the frame tree recursively.
   procedure Destroy (Tree : in out Frame_Ptr) is
      F : Frame_Ptr;
   begin
      --  Destroy its children recursively.
      while Tree.Children /= null loop
         F := Tree.Children;
         Destroy (F);
      end loop;

      --  Unlink from parent list.
      if Tree.Parent /= null then
         F := Tree.Parent.Children;
         if F = Tree then
            Tree.Parent.Children := Tree.Next;
         else
            while F /= null and F.Next /= Tree loop
               F := F.Next;
            end loop;
            if F = null then
               raise Program_Error;
            end if;
            F.Next := Tree.Next;
         end if;
      end if;
      Free (Tree);
   end Destroy;

   --  Release the frame when its reference is no longer necessary.
   procedure Release (F : in Frame_Ptr) is
      Current : Frame_Ptr := F;
   begin
      --  Scan the fram until the root is reached
      --  and decrement the used counter.  Free the frames
      --  when the used counter reaches 0.
      while Current /= null loop
         if Current.Used <= 1 then
            declare
               Tree : Frame_Ptr := Current;
            begin
               Current := Current.Parent;
               Destroy (Tree);
            end;
         else
            Current.Used := Current.Used - 1;
            Current := Current.Parent;
         end if;
      end loop;
   end Release;

   --  Split the node pointed to by `F' at the position `Pos'
   --  in the caller chain.  A new parent is created for the node
   --  and the brothers of the node become the brothers of the
   --  new parent.
   --
   --  Returns in `F' the new parent node.
   procedure Split (F : in out Frame_Ptr; Pos : in Positive) is

      --  Before:                       After:
      --
      --    +-------+             +-------+
      --  /-|  P    |           /-|  P    |
      --  | +-------+           | +-------+
      --  |       ^             |       ^
      --  |   +-------+         |    +-------+
      --  ...>| node  |...      ....>|  new  |...        (0..N brothers)
      --      +-------+              +-------+
      --       |     ^              |      ^
      --       | +-------+          | +-------+
      --       ->|  c    |          ->| node  |-->0      (0 brother)
      --         +-------+            +-------+
      --                                    |
      --                                +-------+
      --                                |   c   |
      --                                +-------+
      --
      New_Parent : Frame_Ptr := new Frame '(Parent      => F.Parent,
                                            Next        => F.Next,
                                            Children    => F,
                                            Used        => F.Used,
                                            Depth       => F.Depth,
                                            Local_Depth => Pos,
                                            Calls       => (others => 0));
      Child : Frame_Ptr := F.Parent.Children;
   begin
      --  Move the PC values in the new parent.
      New_Parent.Calls (1 .. Pos) := F.Calls (1 .. Pos);
      F.Calls (1 .. F.Local_Depth - Pos) := F.Calls (Pos + 1 .. F.Local_Depth);
      F.Parent         := New_Parent;
      F.Next           := null;
      New_Parent.Depth := F.Depth - F.Local_Depth + Pos;
      F.Local_Depth    := F.Local_Depth - Pos;

      --  Remove F from its parent children list and replace if with New_Parent.
      if Child = F then
         New_Parent.Parent.Children := New_Parent;
      else
         while Child.Next /= F loop
            Child := Child.Next;
         end loop;
         Child.Next := New_Parent;
      end if;
      F := New_Parent;
   end Split;

   procedure Add_Frame (F  : in Frame_Ptr;
                        Pc : in Pc_Table;
                        Result : out Frame_Ptr) is
      Child         : Frame_Ptr := F;
      Pos           : Positive  := Pc'First;
      Current_Depth : Natural   := F.Depth;
      Cnt           : Local_Depth_Type;
   begin
      while Pos <= Pc'Last loop
         Cnt := Frame_Group_Size;
         if Pos + Cnt > Pc'Last then
            Cnt := Pc'Last - Pos + 1;
         end if;
         Current_Depth := Current_Depth + Cnt;
         Child := new Frame '(Parent      => Child,
                              Next        => Child.Children,
                              Children    => null,
                              Used        => 1,
                              Depth       => Current_Depth,
                              Local_Depth => Cnt,
                              Calls       => (others => 0));
         Child.Calls (1 .. Cnt) := Pc (Pos .. Pos + Cnt - 1);
         Pos := Pos + Cnt;
         Child.Parent.Children := Child;
      end loop;
      Result := Child;
   end Add_Frame;

   procedure Insert (F : in Frame_Ptr;
                     Pc : in Pc_Table;
                     Result : out Frame_Ptr) is
      Current : Frame_Ptr := F;
      Child   : Frame_Ptr;
      Pos     : Positive  := Pc'First;
      Lpos    : Positive  := 1;
      Addr    : Target_Addr;
   begin
      while Pos <= Pc'Last loop
         Addr := Pc (Pos);
         if Lpos <= Current.Local_Depth then
            if Addr = Current.Calls (Lpos) then
               Lpos := Lpos + 1;
               Pos  := Pos + 1;

               --  Split this node
            else
               if Lpos > 1 then
                  Split (Current, Lpos - 1);
               end if;
               Add_Frame (Current, Pc (Pos .. Pc'Last), Result);
               return;
            end if;
         else
            --  Find the first child which has the address.
            Child := Current.Children;
            while Child /= null loop
               exit when Child.Calls (1) = Addr;
               Child := Child.Next;
            end loop;
            if Child = null then
               Add_Frame (Current, Pc (Pos .. Pc'Last), Result);
               return;
            end if;
            Current := Child;
            Lpos    := 2;
            Pos     := Pos + 1;
            Current.Used := Current.Used + 1;
         end if;
      end loop;
      if Lpos <= Current.Local_Depth then
         Split (Current, Lpos - 1);
      end if;
      Result := Current;
   end Insert;

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   function Find (F : in Frame_Ptr; Pc : in Target_Addr) return Frame_Ptr is
      Child : Frame_Ptr := F.Children;
   begin
      while Child /= null loop
         if Child.Local_Depth >= 1 and then Child.Calls (1) = Pc then
            return Child;
         end if;
         Child := Child.Next;
      end loop;
      raise Not_Found;
   end Find;

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   function Find (F : in Frame_Ptr; Pc : in PC_Table) return Frame_Ptr is
      Child : Frame_Ptr := F;
      Pos   : Positive  := Pc'First;
      Lpos  : Positive;
   begin
      while Pos <= Pc'Last loop
         Child := Find (Child, Pc (Pos));
         Pos  := Pos + 1;
         Lpos := 2;
         --  All the PC of the child frame must match.
         while Pos <= Pc'Last and Lpos <= Child.Local_Depth loop
            if Child.Calls (Lpos) /= Pc (Pos) then
               raise Not_Found;
            end if;
            Lpos := Lpos + 1;
            Pos  := Pos + 1;
         end loop;
      end loop;
      return Child;
   end Find;

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   procedure Find (F       : in Frame_Ptr;
                   Pc      : in PC_Table;
                   Result  : out Frame_Ptr;
                   Last_Pc : out Natural) is
      Current : Frame_Ptr := F;
      Pos     : Positive  := Pc'First;
      Lpos    : Positive;
   begin
      Main_Search:
      while Pos <= Pc'Last loop
         declare
            Addr  : Target_Addr := Pc (Pos);
            Child : Frame_Ptr   := Current.Children;
         begin
            --  Find the child which has the corresponding PC.
            loop
               exit Main_Search when Child = null;
               exit when Child.Local_Depth >= 1 and Child.Calls (1) = Addr;
               Child := Child.Next;
            end loop;

            Current := Child;
            Pos  := Pos + 1;
            Lpos := 2;
            --  All the PC of the child frame must match.
            while Pos <= Pc'Last and Lpos <= Current.Local_Depth loop
               exit Main_Search when Current.Calls (Lpos) /= Pc (Pos);
               Lpos := Lpos + 1;
               Pos  := Pos + 1;
            end loop;
         end;
      end loop Main_Search;
      Result := Current;
      if Pos > Pc'Last then
         Last_Pc := 0;
      else
         Last_Pc := Pos;
      end if;
   end Find;

end MAT.Frames;

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

   procedure Free is
      new Ada.Unchecked_Deallocation (Frame, Frame_Type);

   --  ------------------------------
   --  Return the parent frame.
   --  ------------------------------
   function Parent (Frame : in Frame_Type) return Frame_Type is
   begin
      if Frame = null then
         return null;
      else
         return Frame.Parent;
      end if;
   end Parent;

   --  ------------------------------
   --  Returns the backtrace of the current frame (up to the root).
   --  ------------------------------
   function Backtrace (Frame :  in Frame_Type) return Frame_Table is
      Pc      : Frame_Table (1 .. Frame.Depth);
      Current : Frame_Type := Frame;
      Pos     : Natural   := Current.Depth;
      New_Pos : Natural;
   begin
      while Current /= null and Pos /= 0 loop
         New_Pos := Pos - Current.Local_Depth + 1;
         Pc (New_Pos .. Pos) := Current.Calls (1 .. Current.Local_Depth);
         Pos     := New_Pos - 1;
         Current := Current.Parent;
      end loop;
      return Pc;
   end Backtrace;

   --  ------------------------------
   --  Returns the number of children in the frame.
   --  When recursive is true, compute in the sub-tree.
   --  ------------------------------
   function Count_Children (Frame     : in Frame_Type;
                            Recursive : in Boolean := False) return Natural is
      Count : Natural := 0;
      Child : Frame_Type;
   begin
      if Frame /= null then
         Child := Frame.Children;
         while Child /= null loop
            Count := Count + 1;
            if Recursive then
               declare
                  N : Natural := Count_Children (Child, True);
               begin
                  if N > 0 then
                     N := N - 1;
                  end if;
                  Count := Count + N;
               end;
            end if;
            Child := Child.Next;
         end loop;
      end if;
      return Count;
   end Count_Children;

   --  ------------------------------
   --  Returns all the direct calls made by the current frame.
   --  ------------------------------
   function Calls (Frame : in Frame_Type) return Frame_Table is
      Nb_Calls : Natural   := Count_Children (Frame);
      Pc       : Frame_Table (1 .. Nb_Calls);
   begin
      if Frame /= null then
         declare
            Child : Frame_Type := Frame.Children;
            Pos   : Natural   := 1;
         begin
            while Child /= null loop
               Pc (Pos) := Child.Calls (1);
               Pos   := Pos + 1;
               Child := Child.Next;
            end loop;
         end;
      end if;
      return Pc;
   end Calls;

   --  ------------------------------
   --  Returns the current stack depth (# of calls from the root
   --  to reach the frame).
   --  ------------------------------
   function Current_Depth (Frame : in Frame_Type) return Natural is
   begin
      if Frame = null then
         return 0;
      else
         return Frame.Depth;
      end if;
   end Current_Depth;

   --  ------------------------------
   --  Create a root for stack frame representation.
   --  ------------------------------
   function Create_Root return Frame_Type is
   begin
      return new Frame;
   end Create_Root;

   --  ------------------------------
   --  Destroy the frame tree recursively.
   --  ------------------------------
   procedure Destroy (Frame : in out Frame_Type) is
      F : Frame_Type;
   begin
      if Frame = null then
         return;
      end if;
      --  Destroy its children recursively.
      while Frame.Children /= null loop
         F := Frame.Children;
         Destroy (F);
      end loop;

      --  Unlink from parent list.
      if Frame.Parent /= null then
         F := Frame.Parent.Children;
         if F = Frame then
            Frame.Parent.Children := Frame.Next;
         else
            while F /= null and F.Next /= Frame loop
               F := F.Next;
            end loop;
            if F = null then
               raise Program_Error;
            end if;
            F.Next := Frame.Next;
         end if;
      end if;
      Free (Frame);
   end Destroy;

   --  Release the frame when its reference is no longer necessary.
   procedure Release (F : in Frame_Ptr) is
      Current : Frame_Ptr := F;
   begin
      --  Scan the fram until the root is reached
      --  and decrement the used counter.  Free the frames
      --  when the used counter reaches 0.
      while Current /= null loop
         if Current.Used <= 1 then
            declare
               Tree : Frame_Ptr := Current;
            begin
               Current := Current.Parent;
               Destroy (Tree);
            end;
         else
            Current.Used := Current.Used - 1;
            Current := Current.Parent;
         end if;
      end loop;
   end Release;

   --  Split the node pointed to by `F' at the position `Pos'
   --  in the caller chain.  A new parent is created for the node
   --  and the brothers of the node become the brothers of the
   --  new parent.
   --
   --  Returns in `F' the new parent node.
   procedure Split (F : in out Frame_Ptr; Pos : in Positive) is

      --  Before:                       After:
      --
      --    +-------+             +-------+
      --  /-|  P    |           /-|  P    |
      --  | +-------+           | +-------+
      --  |       ^             |       ^
      --  |   +-------+         |    +-------+
      --  ...>| node  |...      ....>|  new  |...        (0..N brothers)
      --      +-------+              +-------+
      --       |     ^              |      ^
      --       | +-------+          | +-------+
      --       ->|  c    |          ->| node  |-->0      (0 brother)
      --         +-------+            +-------+
      --                                    |
      --                                +-------+
      --                                |   c   |
      --                                +-------+
      --
      New_Parent : Frame_Ptr := new Frame '(Parent      => F.Parent,
                                            Next        => F.Next,
                                            Children    => F,
                                            Used        => F.Used,
                                            Depth       => F.Depth,
                                            Local_Depth => Pos,
                                            Calls       => (others => 0));
      Child : Frame_Ptr := F.Parent.Children;
   begin
      --  Move the PC values in the new parent.
      New_Parent.Calls (1 .. Pos) := F.Calls (1 .. Pos);
      F.Calls (1 .. F.Local_Depth - Pos) := F.Calls (Pos + 1 .. F.Local_Depth);
      F.Parent         := New_Parent;
      F.Next           := null;
      New_Parent.Depth := F.Depth - F.Local_Depth + Pos;
      F.Local_Depth    := F.Local_Depth - Pos;

      --  Remove F from its parent children list and replace if with New_Parent.
      if Child = F then
         New_Parent.Parent.Children := New_Parent;
      else
         while Child.Next /= F loop
            Child := Child.Next;
         end loop;
         Child.Next := New_Parent;
      end if;
      F := New_Parent;
   end Split;

   procedure Add_Frame (F  : in Frame_Ptr;
                        Pc : in Pc_Table;
                        Result : out Frame_Ptr) is
      Child         : Frame_Ptr := F;
      Pos           : Positive  := Pc'First;
      Current_Depth : Natural   := F.Depth;
      Cnt           : Local_Depth_Type;
   begin
      while Pos <= Pc'Last loop
         Cnt := Frame_Group_Size;
         if Pos + Cnt > Pc'Last then
            Cnt := Pc'Last - Pos + 1;
         end if;
         Current_Depth := Current_Depth + Cnt;
         Child := new Frame '(Parent      => Child,
                              Next        => Child.Children,
                              Children    => null,
                              Used        => 1,
                              Depth       => Current_Depth,
                              Local_Depth => Cnt,
                              Calls       => (others => 0));
         Child.Calls (1 .. Cnt) := Pc (Pos .. Pos + Cnt - 1);
         Pos := Pos + Cnt;
         Child.Parent.Children := Child;
      end loop;
      Result := Child;
   end Add_Frame;

   procedure Insert (F : in Frame_Ptr;
                     Pc : in Pc_Table;
                     Result : out Frame_Ptr) is
      Current : Frame_Ptr := F;
      Child   : Frame_Ptr;
      Pos     : Positive  := Pc'First;
      Lpos    : Positive  := 1;
      Addr    : Target_Addr;
   begin
      while Pos <= Pc'Last loop
         Addr := Pc (Pos);
         if Lpos <= Current.Local_Depth then
            if Addr = Current.Calls (Lpos) then
               Lpos := Lpos + 1;
               Pos  := Pos + 1;

               --  Split this node
            else
               if Lpos > 1 then
                  Split (Current, Lpos - 1);
               end if;
               Add_Frame (Current, Pc (Pos .. Pc'Last), Result);
               return;
            end if;
         else
            --  Find the first child which has the address.
            Child := Current.Children;
            while Child /= null loop
               exit when Child.Calls (1) = Addr;
               Child := Child.Next;
            end loop;
            if Child = null then
               Add_Frame (Current, Pc (Pos .. Pc'Last), Result);
               return;
            end if;
            Current := Child;
            Lpos    := 2;
            Pos     := Pos + 1;
            Current.Used := Current.Used + 1;
         end if;
      end loop;
      if Lpos <= Current.Local_Depth then
         Split (Current, Lpos - 1);
      end if;
      Result := Current;
   end Insert;

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   function Find (F : in Frame_Ptr; Pc : in Target_Addr) return Frame_Ptr is
      Child : Frame_Ptr := F.Children;
   begin
      while Child /= null loop
         if Child.Local_Depth >= 1 and then Child.Calls (1) = Pc then
            return Child;
         end if;
         Child := Child.Next;
      end loop;
      raise Not_Found;
   end Find;

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   function Find (F : in Frame_Ptr; Pc : in PC_Table) return Frame_Ptr is
      Child : Frame_Ptr := F;
      Pos   : Positive  := Pc'First;
      Lpos  : Positive;
   begin
      while Pos <= Pc'Last loop
         Child := Find (Child, Pc (Pos));
         Pos  := Pos + 1;
         Lpos := 2;
         --  All the PC of the child frame must match.
         while Pos <= Pc'Last and Lpos <= Child.Local_Depth loop
            if Child.Calls (Lpos) /= Pc (Pos) then
               raise Not_Found;
            end if;
            Lpos := Lpos + 1;
            Pos  := Pos + 1;
         end loop;
      end loop;
      return Child;
   end Find;

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   procedure Find (F       : in Frame_Ptr;
                   Pc      : in PC_Table;
                   Result  : out Frame_Ptr;
                   Last_Pc : out Natural) is
      Current : Frame_Ptr := F;
      Pos     : Positive  := Pc'First;
      Lpos    : Positive;
   begin
      Main_Search:
      while Pos <= Pc'Last loop
         declare
            Addr  : Target_Addr := Pc (Pos);
            Child : Frame_Ptr   := Current.Children;
         begin
            --  Find the child which has the corresponding PC.
            loop
               exit Main_Search when Child = null;
               exit when Child.Local_Depth >= 1 and Child.Calls (1) = Addr;
               Child := Child.Next;
            end loop;

            Current := Child;
            Pos  := Pos + 1;
            Lpos := 2;
            --  All the PC of the child frame must match.
            while Pos <= Pc'Last and Lpos <= Current.Local_Depth loop
               exit Main_Search when Current.Calls (Lpos) /= Pc (Pos);
               Lpos := Lpos + 1;
               Pos  := Pos + 1;
            end loop;
         end;
      end loop Main_Search;
      Result := Current;
      if Pos > Pc'Last then
         Last_Pc := 0;
      else
         Last_Pc := Pos;
      end if;
   end Find;

end MAT.Frames;

Refactor Destroy operation

Refactor Destroy operation


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

package body MAT.Consoles.Text is

   --  ------------------------------
   --  Report an error message.
   --  ------------------------------
   overriding
   procedure Error (Console : in out Console_Type;
                    Message : in String) is
      pragma Unreferenced (Console);
   begin
      Ada.Text_IO.Put_Line (Message);
   end Error;

   --  ------------------------------
   --  Report a notice message.
   --  ------------------------------
   overriding
   procedure Notice (Console : in out Console_Type;
                     Kind    : in Notice_Type;
                     Message : in String) is
      pragma Unreferenced (Console, Kind);
   begin
      Ada.Text_IO.Put_Line (Message);
   end Notice;

   --  ------------------------------
   --  Print the field value for the given field.
   --  ------------------------------
   overriding
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String;
                          Justify : in Justify_Type := J_LEFT) is
      use type Ada.Text_IO.Count;

      Pos   : Ada.Text_IO.Count := Ada.Text_IO.Count (Console.Cols (Field));
      Size  : constant Natural := Console.Sizes (Field);
      Start : Natural := Value'First;
      Last  : Natural := Value'Last;
      Pad   : Natural := 0;
      Fill  : Natural := 0;
   begin
      case Justify is
         when J_LEFT =>
            if Value'Length < Size then
               Pad := Size - Value'Length;
            else
               Start := Last - Size + 1;
            end if;

         when J_RIGHT =>
            if Value'Length < Size then
               Fill := Size - Value'Length;
            else
               Start := Last - Size + 1;
            end if;

         when J_CENTER =>
            if Value'Length < Size then
               Pad  := (Size - Value'Length) / 2;
               Fill := Size - Value'Length - Pad;
            else
               Start := Last - Size + 1;
            end if;

         when J_RIGHT_NO_FILL =>
            if Value'Length >= Size then
               Start := Last - Size + 1;
            end if;

      end case;
      if Pad > 0 then
         Ada.Text_IO.Set_Col (Pos + Ada.Text_IO.Count (Pad));
      end if;
      Ada.Text_IO.Put (Value (Start .. Last));
      if Fill > 0 then
         Ada.Text_IO.Set_Col (Pos + Ada.Text_IO.Count (Pad + Fill + Last - Start));
      else
         Ada.Text_IO.Put (" ");
      end if;
   end Print_Field;

   --  ------------------------------
   --  Print the title for the given field.
   --  ------------------------------
   overriding
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String) is
      use type Ada.Text_IO.Count;

      Pos : constant Ada.Text_IO.Count := Ada.Text_IO.Count (Console.Cols (Field));
   begin
      if Pos > 1 then
         Ada.Text_IO.Set_Col (Pos + Ada.Text_IO.Count (Console.Sizes (Field)) - Title'Length);
      end if;
      Ada.Text_IO.Put (Title);
   end Print_Title;

   --  ------------------------------
   --  Start a new title in a report.
   --  ------------------------------
   overriding
   procedure Start_Title (Console : in out Console_Type) is
   begin
      Console.Field_Count := 0;
      Console.Sizes := (others => 0);
      Console.Cols := (others => 1);
   end Start_Title;

   --  ------------------------------
   --  Finish a new title in a report.
   --  ------------------------------
   procedure End_Title (Console : in out Console_Type) is
      pragma Unreferenced (Console);
   begin
      Ada.Text_IO.New_Line;
   end End_Title;

   --  ------------------------------
   --  Start a new row in a report.
   --  ------------------------------
   overriding
   procedure Start_Row (Console : in out Console_Type) is
      pragma Unreferenced (Console);
   begin
      null;
   end Start_Row;

   --  ------------------------------
   --  Finish a new row in a report.
   --  ------------------------------
   overriding
   procedure End_Row (Console : in out Console_Type) is
      pragma Unreferenced (Console);
   begin
      Ada.Text_IO.New_Line;
   end End_Row;

end MAT.Consoles.Text;

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

package body MAT.Consoles.Text is

   --  ------------------------------
   --  Report an error message.
   --  ------------------------------
   overriding
   procedure Error (Console : in out Console_Type;
                    Message : in String) is
      pragma Unreferenced (Console);
   begin
      Ada.Text_IO.Put_Line (Message);
   end Error;

   --  ------------------------------
   --  Report a notice message.
   --  ------------------------------
   overriding
   procedure Notice (Console : in out Console_Type;
                     Kind    : in Notice_Type;
                     Message : in String) is
      pragma Unreferenced (Console, Kind);
   begin
      Ada.Text_IO.Put_Line (Message);
   end Notice;

   --  ------------------------------
   --  Print the field value for the given field.
   --  ------------------------------
   overriding
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String;
                          Justify : in Justify_Type := J_LEFT) is
      use type Ada.Text_IO.Count;

      Pos   : Ada.Text_IO.Count := Ada.Text_IO.Count (Console.Cols (Field));
      Size  : constant Natural := Console.Sizes (Field);
      Start : Natural := Value'First;
      Last  : Natural := Value'Last;
      Pad   : Natural := 0;
      Fill  : Natural := 0;
   begin
      case Justify is
         when J_LEFT =>
            if Value'Length < Size then
               Fill := Size - Value'Length;
            else
               Start := Last - Size + 1;
            end if;

         when J_RIGHT =>
            if Value'Length < Size then
               Pad := Size - Value'Length;
            else
               Start := Last - Size + 1;
            end if;

         when J_CENTER =>
            if Value'Length < Size then
               Pad  := (Size - Value'Length) / 2;
               Fill := Size - Value'Length - Pad;
            else
               Start := Last - Size + 1;
            end if;

         when J_RIGHT_NO_FILL =>
            if Value'Length >= Size then
               Start := Last - Size + 1;
            end if;

      end case;
      if Pad > 0 then
         Ada.Text_IO.Set_Col (Pos + Ada.Text_IO.Count (Pad));
      end if;
      Ada.Text_IO.Put (Value (Start .. Last));
      if Fill > 0 then
         Ada.Text_IO.Set_Col (Pos + Ada.Text_IO.Count (Pad + Fill + Last - Start));
      else
         Ada.Text_IO.Put (" ");
      end if;
   end Print_Field;

   --  ------------------------------
   --  Print the title for the given field.
   --  ------------------------------
   overriding
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String) is
      use type Ada.Text_IO.Count;

      Pos : constant Ada.Text_IO.Count := Ada.Text_IO.Count (Console.Cols (Field));
   begin
      if Pos > 1 then
         Ada.Text_IO.Set_Col (Pos + Ada.Text_IO.Count (Console.Sizes (Field)) - Title'Length);
      end if;
      Ada.Text_IO.Put (Title);
   end Print_Title;

   --  ------------------------------
   --  Start a new title in a report.
   --  ------------------------------
   overriding
   procedure Start_Title (Console : in out Console_Type) is
   begin
      Console.Field_Count := 0;
      Console.Sizes := (others => 0);
      Console.Cols := (others => 1);
   end Start_Title;

   --  ------------------------------
   --  Finish a new title in a report.
   --  ------------------------------
   procedure End_Title (Console : in out Console_Type) is
      pragma Unreferenced (Console);
   begin
      Ada.Text_IO.New_Line;
   end End_Title;

   --  ------------------------------
   --  Start a new row in a report.
   --  ------------------------------
   overriding
   procedure Start_Row (Console : in out Console_Type) is
      pragma Unreferenced (Console);
   begin
      null;
   end Start_Row;

   --  ------------------------------
   --  Finish a new row in a report.
   --  ------------------------------
   overriding
   procedure End_Row (Console : in out Console_Type) is
      pragma Unreferenced (Console);
   begin
      Ada.Text_IO.New_Line;
   end End_Row;

end MAT.Consoles.Text;

Fix the J_LEFT and J_RIGHT justifications that were inverted


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

with MAT.Types;
with MAT.Frames;

with Interfaces;
package MAT.Memory is

   type Allocation is record
      Size   : MAT.Types.Target_Size;
      Frame  : Frames.Frame_Ptr;
      Time   : MAT.Types.Target_Tick_Ref;
      Thread : MAT.Types.Target_Thread_Ref;
   end record;

   use type MAT.Types.Target_Addr;
   package Allocation_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Addr,
                                      Element_Type => Allocation);

   --  Memory allocation objects are stored in an AVL tree sorted
   --  on the memory slot address.
--
--     subtype Allocation_Map is Allocation_Maps.Map;
--
--     subtype Allocation_Ref is Allocation_AVL.Iterator;
--     --  Type representing a reference to a memory allocation slot.
--
--     use Allocation_AVL;
--     package Allocation_Ref_Containers is new BC.Containers (Allocation_Ref);
--     package Allocation_Ref_Trees is new Allocation_Ref_Containers.Trees;
--     package Allocation_Ref_AVL is
--       new Allocation_Ref_Trees.AVL (Key => Target_Addr,
--                                     Storage => Global_Heap.Storage);
--     --  Tree of references to memory allocation objects.
--
--     subtype Allocation_Ref_Map is Allocation_Ref_AVL.AVL_Tree;
--     subtype Allocation_Ref_Ref is Allocation_Ref_AVL.Iterator;

private

end MAT.Memory;

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

with MAT.Types;
with MAT.Frames;

with Interfaces;
package MAT.Memory is

   type Allocation is record
      Size   : MAT.Types.Target_Size;
      Frame  : Frames.Frame_Ptr;
      Time   : MAT.Types.Target_Tick_Ref;
      Thread : MAT.Types.Target_Thread_Ref;
   end record;

   use type MAT.Types.Target_Addr;
   package Allocation_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Addr,
                                      Element_Type => Allocation);

   --  Memory allocation objects are stored in an AVL tree sorted
   --  on the memory slot address.
--
   subtype Allocation_Map is Allocation_Maps.Map;
--
--     subtype Allocation_Ref is Allocation_AVL.Iterator;
--     --  Type representing a reference to a memory allocation slot.
--
--     use Allocation_AVL;
--     package Allocation_Ref_Containers is new BC.Containers (Allocation_Ref);
--     package Allocation_Ref_Trees is new Allocation_Ref_Containers.Trees;
--     package Allocation_Ref_AVL is
--       new Allocation_Ref_Trees.AVL (Key => Target_Addr,
--                                     Storage => Global_Heap.Storage);
--     --  Tree of references to memory allocation objects.
--
--     subtype Allocation_Ref_Map is Allocation_Ref_AVL.AVL_Tree;
--     subtype Allocation_Ref_Ref is Allocation_Ref_AVL.Iterator;

private

end MAT.Memory;

Define Allocation_Map

Define Allocation_Map


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

with Util.Tests;
package ADO.Objects.Tests is

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

   procedure Test_Key (T : in out Test);

   procedure Test_Object_Ref (T : in out Test);

   procedure Test_Create_Object (T : in out Test);

   procedure Test_Delete_Object (T : in out Test);

   --  Test Is_Inserted and Is_Null
   procedure Test_Is_Inserted (T : in out Test);

   --  Add the tests in the test suite
   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

end ADO.Objects.Tests;

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

with Util.Tests;
package ADO.Objects.Tests is

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

   procedure Test_Key (T : in out Test);

   procedure Test_Object_Ref (T : in out Test);

   procedure Test_Create_Object (T : in out Test);

   procedure Test_Delete_Object (T : in out Test);

   --  Test Is_Inserted and Is_Null
   procedure Test_Is_Inserted (T : in out Test);

   --  Test object creation/update/load with string as key.
   procedure Test_String_Key (T : in out Test);

   --  Add the tests in the test suite
   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

end ADO.Objects.Tests;

Declare Test_String_Key procedure

Declare Test_String_Key procedure


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

with Util.Tests;

package Util.Locales.Tests is

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

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

   procedure Test_Get_Locale (T : in out Test);
   procedure Test_Hash_Locale (T : in out Test);
   procedure Test_Compare_Locale (T : in out Test);
   procedure Test_Get_Locales (T : in out Test);

end Util.Locales.Tests;

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

with Util.Tests;

package Util.Locales.Tests is

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

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

   procedure Test_Get_Locale (T : in out Test);
   procedure Test_Hash_Locale (T : in out Test);
   procedure Test_Compare_Locale (T : in out Test);
   procedure Test_Get_Locales (T : in out Test);
   procedure Test_Null_Locale (T : in out Test);

end Util.Locales.Tests;

Declare the new Test_Null_Locale procedure


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

      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;

   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;

Set the buffer pool for the local stores


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

with Util.Strings;

with Security.Auth;

--  == OAuth Server ==
--  OAuth server side is provided by the <tt>Security.OAuth.Servers</tt> package.
--  This package allows to implement the authorization framework described in RFC 6749
--  The OAuth 2.0 Authorization Framework.
--
--  The authorization method produce a <tt>Grant_Type</tt> object that contains the result
--  of the grant (successful or denied).  It is the responsibility of the caller to format
--  the result in JSON/XML and return it to the client.
--
--  Three important operations are defined for the OAuth 2.0 framework.
--
--  <tt>Authorize</tt> is used to obtain an authorization request.  This operation is
--  optional in the OAuth 2.0 framework since some authorization method directly return
--  the access token.  This operation is used by the "Authorization Code Grant" and the
--  "Implicit Grant".
--
--  <tt>Token</tt> is used to get the access token and optional refresh token.
--
--  <tt>Authenticate</tt> is used for the API request to verify the access token
--  and authenticate the API call.

--  Several grant types are supported.
--
--  === Application Manager ===
--  The application manager maintains the repository of applications which are known by
--  the server and which can request authorization.  Each application is identified by
--  a client identifier (represented by the <tt>client_id</tt> request parameter).
--  The application defines the authorization methods which are allowed as well as
--  the parameters to control and drive the authorization.  This includes the redirection
--  URI, the application secret, the expiration delay for the access token.
--
--  The application manager is implemented by the application server and it must
--  implement the <tt>Application_Manager</tt> interface with the <tt>Find_Application</tt>
--  method.  The <tt>Find_Application</tt> is one of the first call made during the
--  authenticate and token generation phases.
--
--  === Resource Owner Password Credentials Grant ===
--  The password grant is one of the easiest grant method to understand but it is also one
--  of the less secure.  In this grant method, the username and user password are passed in
--  the request parameter together with the application client identifier.  The realm verifies
--  the username and password and when they are correct it generates the access token with
--  an optional refresh token.
--
--    Realm : Security.OAuth.Servers.Manager;
--    Grant : Security.OAuth.Servers.Grant_Type;
--
--      Realm.Authorize (Params, Grant);
--
--  === Accessing Protected Resources ===
--  When accessing a protected resource, the API implementation will use the
--  <tt>Authenticate</tt> operation to verify the access token and get a security principal.
--  The security principal will identifies the resource owner as well as the application
--  that is doing the call.
--
--     Realm : Security.OAuth.Servers.Manager;
--     Auth  : Security.Principal_Access;
--     Token : String := ...;
--
--       Realm.Authenticate (Token, Auth);
--
--  When a security principal is returned, the access token was validated and the
--  request is granted for the application.
--
package Security.OAuth.Servers is

   Invalid_Application : exception;

   type Application is new Security.OAuth.Application with private;

   --  Define the status of the grant.
   type Grant_Status is (Invalid_Grant, Expired_Grant, Revoked_Grant,
                         Stealed_Grant, Valid_Grant);

   --  Define the grant type.
   type Grant_Kind is (No_Grant, Access_Grant, Code_Grant,
                       Implicit_Grant, Password_Grant, Credential_Grant,
                       Extension_Grant);

   --  The <tt>Grant_Type</tt> holds the results of the authorization.
   --  When the grant is refused, the type holds information about the refusal.
   type Grant_Type is record
      --  The request grant type.
      Request : Grant_Kind := No_Grant;

      --  The response status.
      Status  : Grant_Status := Invalid_Grant;

      --  When success, the token to return.
      Token   : Ada.Strings.Unbounded.Unbounded_String;

      --  When success, the token expiration date.
      Expires : Ada.Calendar.Time;

      --  When success, the authentication principal.
      Auth    : Security.Principal_Access;

      --  When error, the type of error to return.
      Error   : Util.Strings.Name_Access;
   end record;

   type Application_Manager is limited interface;
   type Application_Manager_Access is access all Application_Manager'Class;

   --  Find the application that correspond to the given client id.
   --  The <tt>Invalid_Application</tt> exception should be raised if there is no such application.
   function Find_Application (Realm     : in Application_Manager;
                              Client_Id : in String) return Application'Class is abstract;

   type Realm_Manager is limited interface;
   type Realm_Manager_Access is access all Realm_Manager'Class;

   --  Authenticate the token and find the associated authentication principal.
   --  The access token has been verified and the token represents the identifier
   --  of the Tuple (client_id, user, session) that describes the authentication.
   --  The <tt>Authenticate</tt> procedure should look in its database (internal
   --  or external) to find the authentication principal that was granted for
   --  the token Tuple.  When the token was not found (because it was revoked),
   --  the procedure should return a null principal.  If the authentication
   --  principal can be cached, the <tt>Cacheable</tt> value should be set.
   --  In that case, the access token and authentication  principal are inserted
   --  in a cache.
   procedure Authenticate (Realm     : in out Realm_Manager;
                           Token     : in String;
                           Auth      : out Principal_Access;
                           Cacheable : out Boolean) is abstract;

   --  Create an auth token string that identifies the given principal.  The returned
   --  token will be used by <tt>Authenticate</tt> to retrieve back the principal.  The
   --  returned token does not need to be signed.  It will be inserted in the public part
   --  of the returned access token.
   function Authorize (Realm : in Realm_Manager;
                       App   : in Application'Class;
                       Scope : in String;
                       Auth  : in Principal_Access) return String is abstract;

   procedure Verify (Realm    : in Realm_Manager;
                     Username : in String;
                     Password : in String;
                     Auth     : out Principal_Access) is abstract;

   procedure Verify (Realm : in Realm_Manager;
                     Token : in String;
                     Auth  : out Principal_Access) is abstract;

   procedure Revoke (Realm : in Realm_Manager;
                     Auth  : in Principal_Access) is abstract;

   type Auth_Manager is abstract tagged limited private;

   --  Set the auth private key.
   procedure Set_Private_Key (Manager : in out Auth_Manager;
                              Key     : in String);

   --  Set the application manager to use and and applications.
   procedure Set_Application_Manager (Manager    : in out Auth_Manager;
                                      Repository : in Application_Manager_Access);

   --  Set the realm manager to authentify users.
   procedure Set_Realm_Manager (Manager : in out Auth_Manager;
                                Realm   : in Realm_Manager_Access);

   --  Authorize the access to the protected resource by the application and for the
   --  given principal.  The resource owner has been verified and is represented by the
   --  <tt>Auth</tt> principal.  Extract from the request parameters represented by
   --  <tt>Params</tt> the application client id, the scope and the expected response type.
   --  Handle the "Authorization Code Grant" and "Implicit Grant" defined in RFC 6749.
   procedure Authorize (Realm   : in out Auth_Manager;
                        Params  : in Security.Auth.Parameters'Class;
                        Auth    : in Security.Principal_Access;
                        Grant   : out Grant_Type);

   procedure Token (Realm   : in out Auth_Manager;
                    Params  : in Security.Auth.Parameters'Class;
                    Grant   : out Grant_Type);

   --  Make the access token from the authorization code that was created by the
   --  <tt>Authorize</tt> operation.  Verify the client application, the redirect uri, the
   --  client secret and the validity of the authorization code.  Extract from the
   --  authorization code the auth principal that was used for the grant and make the
   --  access token.
   procedure Token_From_Code (Realm   : in out Auth_Manager;
                              App     : in Application'Class;
                              Params  : in Security.Auth.Parameters'Class;
                              Grant   : out Grant_Type);

   procedure Authorize_Code (Realm   : in out Auth_Manager;
                             App     : in Application'Class;
                             Params  : in Security.Auth.Parameters'Class;
                             Auth    : in Security.Principal_Access;
                             Grant   : out Grant_Type);

   procedure Authorize_Token (Realm   : in out Auth_Manager;
                              App     : in Application'Class;
                              Params  : in Security.Auth.Parameters'Class;
                              Auth    : in Security.Principal_Access;
                              Grant   : out Grant_Type);

   --  Make the access token from the resource owner password credentials.  The username,
   --  password and scope are extracted from the request and they are verified through the
   --  <tt>Verify</tt> procedure to obtain an associated principal.  When successful, the
   --  principal describes the authorization and it is used to forge the access token.
   --  This operation implements the RFC 6749: 4.3.  Resource Owner Password Credentials Grant.
   procedure Token_From_Password (Realm   : in out Auth_Manager;
                                  App     : in Application'Class;
                                  Params  : in Security.Auth.Parameters'Class;
                                  Grant   : out Grant_Type);

   --  RFC 6749: 5.  Issuing an Access Token
   procedure Create_Token (Realm  : in Auth_Manager;
                           Ident  : in String;
                           Grant  : in out Grant_Type);

   --  Authenticate the access token and get a security principal that identifies the app/user.
   --  See RFC 6749, 7.  Accessing Protected Resources.
   --  The access token is first searched in the cache.  If it was found, it means the access
   --  token was already verified in the past, it is granted and associated with a principal.
   --  Otherwise, we have to verify the token signature first, then the expiration date and
   --  we extract from the token public part the auth identification.  The <tt>Authenticate</tt>
   --  operation is then called to obtain the principal from the auth identification.
   --  When access token is invalid or authentification cannot be verified, a null principal
   --  is returned.  The <tt>Grant</tt> data will hold the result of the grant with the reason
   --  of failures (if any).
   procedure Authenticate (Realm : in out Auth_Manager;
                           Token : in String;
                           Grant : out Grant_Type);

   procedure Revoke (Realm     : in out Auth_Manager;
                     Token     : in String);

private

   use Ada.Strings.Unbounded;

   function Format_Expire (Expire : in Ada.Calendar.Time) return String;

   type Application is new Security.OAuth.Application with record
      Expire_Timeout : Duration;
   end record;

   type Cache_Entry is record
      Expire : Ada.Calendar.Time;
      Auth   : Principal_Access;
   end record;

   package Cache_Map is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Cache_Entry,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=",
                                                "="             => "=");

   --  The access token cache is used to speed up the access token verification
   --  when a request to a protected resource is made.
   protected type Token_Cache is

      procedure Authenticate (Token : in String;
                              Grant : in out Grant_Type);

      procedure Insert (Token     : in String;
                        Expire    : in Ada.Calendar.Time;
                        Principal : in Principal_Access);

      procedure Remove (Token : in String);

      procedure Timeout;

   private
      Entries : Cache_Map.Map;
   end Token_Cache;

   type Auth_Manager is abstract new Ada.Finalization.Limited_Controlled with record
      --  The repository of applications.
      Repository  : Application_Manager_Access;

      --  The realm for user authentication.
      Realm       : Realm_Manager_Access;

      --  The server private key used by the HMAC signature.
      Private_Key : Ada.Strings.Unbounded.Unbounded_String;

      --  The access token cache.
      Cache       : Token_Cache;

      --  The expiration time for the generated authorization code.
      Expire_Code : Duration := 300.0;
   end record;

   --  <expiration>.<client_id>.<auth-ident>.hmac(<public>.<private-key>)
   type Token_Validity is record
      Status       : Grant_Status := Invalid_Grant;
      Ident_Start  : Natural := 0;
      Ident_End    : Natural := 0;
      Expire       : Ada.Calendar.Time;
   end record;

   function Validate (Realm     : in Auth_Manager;
                      Client_Id : in String;
                      Token     : in String) return Token_Validity;

end Security.OAuth.Servers;

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

with Util.Strings;

with Security.Auth;
with Security.Permissions;

--  == OAuth Server ==
--  OAuth server side is provided by the <tt>Security.OAuth.Servers</tt> package.
--  This package allows to implement the authorization framework described in RFC 6749
--  The OAuth 2.0 Authorization Framework.
--
--  The authorization method produce a <tt>Grant_Type</tt> object that contains the result
--  of the grant (successful or denied).  It is the responsibility of the caller to format
--  the result in JSON/XML and return it to the client.
--
--  Three important operations are defined for the OAuth 2.0 framework.
--
--  <tt>Authorize</tt> is used to obtain an authorization request.  This operation is
--  optional in the OAuth 2.0 framework since some authorization method directly return
--  the access token.  This operation is used by the "Authorization Code Grant" and the
--  "Implicit Grant".
--
--  <tt>Token</tt> is used to get the access token and optional refresh token.
--
--  <tt>Authenticate</tt> is used for the API request to verify the access token
--  and authenticate the API call.

--  Several grant types are supported.
--
--  === Application Manager ===
--  The application manager maintains the repository of applications which are known by
--  the server and which can request authorization.  Each application is identified by
--  a client identifier (represented by the <tt>client_id</tt> request parameter).
--  The application defines the authorization methods which are allowed as well as
--  the parameters to control and drive the authorization.  This includes the redirection
--  URI, the application secret, the expiration delay for the access token.
--
--  The application manager is implemented by the application server and it must
--  implement the <tt>Application_Manager</tt> interface with the <tt>Find_Application</tt>
--  method.  The <tt>Find_Application</tt> is one of the first call made during the
--  authenticate and token generation phases.
--
--  === Resource Owner Password Credentials Grant ===
--  The password grant is one of the easiest grant method to understand but it is also one
--  of the less secure.  In this grant method, the username and user password are passed in
--  the request parameter together with the application client identifier.  The realm verifies
--  the username and password and when they are correct it generates the access token with
--  an optional refresh token.
--
--    Realm : Security.OAuth.Servers.Manager;
--    Grant : Security.OAuth.Servers.Grant_Type;
--
--      Realm.Authorize (Params, Grant);
--
--  === Accessing Protected Resources ===
--  When accessing a protected resource, the API implementation will use the
--  <tt>Authenticate</tt> operation to verify the access token and get a security principal.
--  The security principal will identifies the resource owner as well as the application
--  that is doing the call.
--
--     Realm : Security.OAuth.Servers.Manager;
--     Auth  : Security.Principal_Access;
--     Token : String := ...;
--
--       Realm.Authenticate (Token, Auth);
--
--  When a security principal is returned, the access token was validated and the
--  request is granted for the application.
--
package Security.OAuth.Servers is

   Invalid_Application : exception;

   type Application is new Security.OAuth.Application with private;

   --  Check if the application has the given permission.
   function Has_Permission (App        : in Application;
                            Permission : in Security.Permissions.Permission_Index) return Boolean;

   --  Define the status of the grant.
   type Grant_Status is (Invalid_Grant, Expired_Grant, Revoked_Grant,
                         Stealed_Grant, Valid_Grant);

   --  Define the grant type.
   type Grant_Kind is (No_Grant, Access_Grant, Code_Grant,
                       Implicit_Grant, Password_Grant, Credential_Grant,
                       Extension_Grant);

   --  The <tt>Grant_Type</tt> holds the results of the authorization.
   --  When the grant is refused, the type holds information about the refusal.
   type Grant_Type is record
      --  The request grant type.
      Request : Grant_Kind := No_Grant;

      --  The response status.
      Status  : Grant_Status := Invalid_Grant;

      --  When success, the token to return.
      Token   : Ada.Strings.Unbounded.Unbounded_String;

      --  When success, the token expiration date.
      Expires : Ada.Calendar.Time;

      --  When success, the authentication principal.
      Auth    : Security.Principal_Access;

      --  When error, the type of error to return.
      Error   : Util.Strings.Name_Access;
   end record;

   type Application_Manager is limited interface;
   type Application_Manager_Access is access all Application_Manager'Class;

   --  Find the application that correspond to the given client id.
   --  The <tt>Invalid_Application</tt> exception should be raised if there is no such application.
   function Find_Application (Realm     : in Application_Manager;
                              Client_Id : in String) return Application'Class is abstract;

   type Realm_Manager is limited interface;
   type Realm_Manager_Access is access all Realm_Manager'Class;

   --  Authenticate the token and find the associated authentication principal.
   --  The access token has been verified and the token represents the identifier
   --  of the Tuple (client_id, user, session) that describes the authentication.
   --  The <tt>Authenticate</tt> procedure should look in its database (internal
   --  or external) to find the authentication principal that was granted for
   --  the token Tuple.  When the token was not found (because it was revoked),
   --  the procedure should return a null principal.  If the authentication
   --  principal can be cached, the <tt>Cacheable</tt> value should be set.
   --  In that case, the access token and authentication  principal are inserted
   --  in a cache.
   procedure Authenticate (Realm     : in out Realm_Manager;
                           Token     : in String;
                           Auth      : out Principal_Access;
                           Cacheable : out Boolean) is abstract;

   --  Create an auth token string that identifies the given principal.  The returned
   --  token will be used by <tt>Authenticate</tt> to retrieve back the principal.  The
   --  returned token does not need to be signed.  It will be inserted in the public part
   --  of the returned access token.
   function Authorize (Realm : in Realm_Manager;
                       App   : in Application'Class;
                       Scope : in String;
                       Auth  : in Principal_Access) return String is abstract;

   procedure Verify (Realm    : in Realm_Manager;
                     Username : in String;
                     Password : in String;
                     Auth     : out Principal_Access) is abstract;

   procedure Verify (Realm : in Realm_Manager;
                     Token : in String;
                     Auth  : out Principal_Access) is abstract;

   procedure Revoke (Realm : in Realm_Manager;
                     Auth  : in Principal_Access) is abstract;

   type Auth_Manager is abstract tagged limited private;

   --  Set the auth private key.
   procedure Set_Private_Key (Manager : in out Auth_Manager;
                              Key     : in String);

   --  Set the application manager to use and and applications.
   procedure Set_Application_Manager (Manager    : in out Auth_Manager;
                                      Repository : in Application_Manager_Access);

   --  Set the realm manager to authentify users.
   procedure Set_Realm_Manager (Manager : in out Auth_Manager;
                                Realm   : in Realm_Manager_Access);

   --  Authorize the access to the protected resource by the application and for the
   --  given principal.  The resource owner has been verified and is represented by the
   --  <tt>Auth</tt> principal.  Extract from the request parameters represented by
   --  <tt>Params</tt> the application client id, the scope and the expected response type.
   --  Handle the "Authorization Code Grant" and "Implicit Grant" defined in RFC 6749.
   procedure Authorize (Realm   : in out Auth_Manager;
                        Params  : in Security.Auth.Parameters'Class;
                        Auth    : in Security.Principal_Access;
                        Grant   : out Grant_Type);

   procedure Token (Realm   : in out Auth_Manager;
                    Params  : in Security.Auth.Parameters'Class;
                    Grant   : out Grant_Type);

   --  Make the access token from the authorization code that was created by the
   --  <tt>Authorize</tt> operation.  Verify the client application, the redirect uri, the
   --  client secret and the validity of the authorization code.  Extract from the
   --  authorization code the auth principal that was used for the grant and make the
   --  access token.
   procedure Token_From_Code (Realm   : in out Auth_Manager;
                              App     : in Application'Class;
                              Params  : in Security.Auth.Parameters'Class;
                              Grant   : out Grant_Type);

   procedure Authorize_Code (Realm   : in out Auth_Manager;
                             App     : in Application'Class;
                             Params  : in Security.Auth.Parameters'Class;
                             Auth    : in Security.Principal_Access;
                             Grant   : out Grant_Type);

   procedure Authorize_Token (Realm   : in out Auth_Manager;
                              App     : in Application'Class;
                              Params  : in Security.Auth.Parameters'Class;
                              Auth    : in Security.Principal_Access;
                              Grant   : out Grant_Type);

   --  Make the access token from the resource owner password credentials.  The username,
   --  password and scope are extracted from the request and they are verified through the
   --  <tt>Verify</tt> procedure to obtain an associated principal.  When successful, the
   --  principal describes the authorization and it is used to forge the access token.
   --  This operation implements the RFC 6749: 4.3.  Resource Owner Password Credentials Grant.
   procedure Token_From_Password (Realm   : in out Auth_Manager;
                                  App     : in Application'Class;
                                  Params  : in Security.Auth.Parameters'Class;
                                  Grant   : out Grant_Type);

   --  RFC 6749: 5.  Issuing an Access Token
   procedure Create_Token (Realm  : in Auth_Manager;
                           Ident  : in String;
                           Grant  : in out Grant_Type);

   --  Authenticate the access token and get a security principal that identifies the app/user.
   --  See RFC 6749, 7.  Accessing Protected Resources.
   --  The access token is first searched in the cache.  If it was found, it means the access
   --  token was already verified in the past, it is granted and associated with a principal.
   --  Otherwise, we have to verify the token signature first, then the expiration date and
   --  we extract from the token public part the auth identification.  The <tt>Authenticate</tt>
   --  operation is then called to obtain the principal from the auth identification.
   --  When access token is invalid or authentification cannot be verified, a null principal
   --  is returned.  The <tt>Grant</tt> data will hold the result of the grant with the reason
   --  of failures (if any).
   procedure Authenticate (Realm : in out Auth_Manager;
                           Token : in String;
                           Grant : out Grant_Type);

   procedure Revoke (Realm     : in out Auth_Manager;
                     Token     : in String);

private

   use Ada.Strings.Unbounded;

   function Format_Expire (Expire : in Ada.Calendar.Time) return String;

   type Application is new Security.OAuth.Application with record
      Expire_Timeout : Duration;
      Permissions    : Security.Permissions.Permission_Index_Set := Security.Permissions.EMPTY_SET;
   end record;

   type Cache_Entry is record
      Expire : Ada.Calendar.Time;
      Auth   : Principal_Access;
   end record;

   package Cache_Map is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Cache_Entry,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=",
                                                "="             => "=");

   --  The access token cache is used to speed up the access token verification
   --  when a request to a protected resource is made.
   protected type Token_Cache is

      procedure Authenticate (Token : in String;
                              Grant : in out Grant_Type);

      procedure Insert (Token     : in String;
                        Expire    : in Ada.Calendar.Time;
                        Principal : in Principal_Access);

      procedure Remove (Token : in String);

      procedure Timeout;

   private
      Entries : Cache_Map.Map;
   end Token_Cache;

   type Auth_Manager is abstract new Ada.Finalization.Limited_Controlled with record
      --  The repository of applications.
      Repository  : Application_Manager_Access;

      --  The realm for user authentication.
      Realm       : Realm_Manager_Access;

      --  The server private key used by the HMAC signature.
      Private_Key : Ada.Strings.Unbounded.Unbounded_String;

      --  The access token cache.
      Cache       : Token_Cache;

      --  The expiration time for the generated authorization code.
      Expire_Code : Duration := 300.0;
   end record;

   --  <expiration>.<client_id>.<auth-ident>.hmac(<public>.<private-key>)
   type Token_Validity is record
      Status       : Grant_Status := Invalid_Grant;
      Ident_Start  : Natural := 0;
      Ident_End    : Natural := 0;
      Expire       : Ada.Calendar.Time;
   end record;

   function Validate (Realm     : in Auth_Manager;
                      Client_Id : in String;
                      Token     : in String) return Token_Validity;

end Security.OAuth.Servers;

Add a Permission_Index_Set to the Application record Declare the Has_Permission procedure