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

   use MAT.Events.Targets;

   ITERATE_COUNT : constant MAT.Events.Event_Id_Type := 10_000;

   procedure Extract (Target : in out MAT.Events.Targets.Target_Events'Class;
                      Into   : in out Timeline_Info_Vector) is
      use type MAT.Types.Target_Time;
      use type MAT.Types.Target_Size;
      procedure Collect (Event : in MAT.Events.Target_Event_Type);

      First_Event : MAT.Events.Target_Event_Type;
      Last_Event  : MAT.Events.Target_Event_Type;
      Prev_Event  : MAT.Events.Target_Event_Type;
      Info        : Timeline_Info;
      First_Id    : MAT.Events.Event_Id_Type;

      procedure Collect (Event : in MAT.Events.Target_Event_Type) is
         Dt : constant MAT.Types.Target_Time := Event.Time - Prev_Event.Time;
      begin
         if Dt > 500_000 then
            Into.Append (Info);
            Info.Malloc_Count := 0;
            Info.Realloc_Count := 0;
            Info.Free_Count := 0;
            Info.First_Event := Event;
            Info.Free_Size := 0;
            Info.Alloc_Size := 0;
            Prev_Event := Event;
         end if;
         Info.Last_Event := Event;
         if Event.Event = 2 then
            Info.Malloc_Count := Info.Malloc_Count + 1;
            Info.Alloc_Size := Info.Alloc_Size + Event.Size;
         elsif Event.Event = 3 then
            Info.Realloc_Count := Info.Realloc_Count + 1;
            Info.Alloc_Size := Info.Alloc_Size + Event.Size;
            Info.Free_Size := Info.Free_Size + Event.Old_Size;
         elsif Event.Event = 4 then
            Info.Free_Count := Info.Free_Count + 1;
            Info.Free_Size := Info.Free_Size + Event.Size;
         end if;
      end Collect;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      Prev_Event      := First_Event;
      Info.First_Event := First_Event;
      First_Id := First_Event.Id;
      while First_Id < Last_Event.Id loop
         Target.Iterate (Start   => First_Id,
                         Finish  => First_Id + ITERATE_COUNT,
                         Process => Collect'Access);
         First_Id := First_Id + ITERATE_COUNT;
      end loop;
   end Extract;

   --  ------------------------------
   --  Find in the events stream the events which are associated with a given event.
   --  When the <tt>Event</tt> is a memory allocation, find the associated reallocation
   --  and free events.  When the event is a free, find the associated allocations.
   --  Collect at most <tt>Max</tt> events.
   --  ------------------------------
   procedure Find_Related (Target : in out MAT.Events.Targets.Target_Events'Class;
                           Event  : in MAT.Events.Target_Event_Type;
                           Max    : in Positive;
                           List   : in out MAT.Events.Tools.Target_Event_Vector) is

      procedure Collect_Free (Event : in MAT.Events.Target_Event_Type);
      procedure Collect_Alloc (Event : in MAT.Events.Target_Event_Type);

      First_Id    : MAT.Events.Event_Id_Type;
      Last_Id     : MAT.Events.Event_Id_Type;
      First_Event : MAT.Events.Target_Event_Type;
      Last_Event  : MAT.Events.Target_Event_Type;
      Addr        : MAT.Types.Target_Addr := Event.Addr;

      Done : exception;

      procedure Collect_Free (Event : in MAT.Events.Target_Event_Type) is
      begin
         if Event.Index = MAT.Events.MSG_FREE and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.MSG_REALLOC and then Event.Old_Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Addr;
         end if;
      end Collect_Free;

      procedure Collect_Alloc (Event : in MAT.Events.Target_Event_Type) is
      begin
         if Event.Index = MAT.Events.MSG_MALLOC and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.MSG_REALLOC and then Event.Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Old_Addr;
         end if;
      end Collect_Alloc;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      First_Id := Event.Id;
      if Event.Index = MAT.Events.MSG_FREE then
         --  Search backward for MSG_MALLOC and MSG_REALLOC.
         First_Id := First_Id - 1;
         while First_Id > First_Event.Id loop
            if First_Id > ITERATE_COUNT then
               Last_Id := First_Id - ITERATE_COUNT;
            else
               Last_Id := First_Event.Id;
            end if;
            Target.Iterate (Start   => First_Id,
                            Finish  => Last_Id,
                            Process => Collect_Alloc'Access);
            First_Id := Last_Id;
         end loop;
      else
         --  Search forward for MSG_REALLOC and MSG_FREE
         First_Id := First_Id + 1;
         while First_Id < Last_Event.Id loop
            Target.Iterate (Start   => First_Id,
                            Finish  => First_Id + ITERATE_COUNT,
                            Process => Collect_Free'Access);
            First_Id := First_Id + ITERATE_COUNT;
         end loop;
      end if;

   exception
      when Done =>
         null;
   end Find_Related;

   --  ------------------------------
   --  Find the sizes of malloc and realloc events which is selected by the given filter.
   --  Update the <tt>Sizes</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding size.
   --  ------------------------------
   procedure Find_Sizes (Target : in out MAT.Events.Targets.Target_Events'Class;
                         Filter : in MAT.Expressions.Expression_Type;
                         Sizes  : in out MAT.Events.Tools.Size_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type);

      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type) is
         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Tools.Event_Info_Type);

         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Tools.Event_Info_Type) is
            pragma Unreferenced (Size);
         begin
            Info.Count      := Info.Count + 1;
            Info.Last_Event := Event;
            if Event.Index = MAT.Events.MSG_MALLOC then
               Info.Alloc_Size := Info.Alloc_Size + Event.Size;
            elsif Event.Index = MAT.Events.MSG_REALLOC then
               Info.Alloc_Size := Info.Alloc_Size + Event.Size;
               Info.Free_Size := Info.Alloc_Size + Event.Old_Size;
            else
               Info.Free_Size := Info.Alloc_Size + Event.Size;
            end if;
         end Update_Size;

      begin
         --  Look for malloc or realloc events which are selected by the filter.
         if (Event.Index /= MAT.Events.MSG_MALLOC
             and Event.Index /= MAT.Events.MSG_FREE
             and Event.Index /= MAT.Events.MSG_REALLOC)
           or else not Filter.Is_Selected (Event)
         then
            return;
         end if;
         declare
            Pos : constant MAT.Events.Tools.Size_Event_Info_Cursor := Sizes.Find (Event.Size);
         begin
            if MAT.Events.Tools.Size_Event_Info_Maps.Has_Element (Pos) then
               --  Increment the count and update the last event.
               Sizes.Update_Element (Pos, Update_Size'Access);
            else
               declare
                  Info : MAT.Events.Tools.Event_Info_Type;
               begin
                  --  Insert a new size with the event.
                  Info.First_Event := Event;
                  Info.Last_Event := Event;
                  Info.Count := 1;
                  if Event.Index = MAT.Events.MSG_MALLOC then
                     Info.Alloc_Size := Event.Size;
                  elsif Event.Index = MAT.Events.MSG_REALLOC then
                     Info.Alloc_Size := Event.Size;
                     Info.Free_Size := Event.Old_Size;
                  else
                     Info.Free_Size := Event.Size;
                  end if;
                  Sizes.Insert (Event.Size, Info);
               end;
            end if;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Sizes;

   --  ------------------------------
   --  Find the function address from the call event frames for the events which is selected
   --  by the given filter.  The function addresses are collected up to the given frame depth.
   --  Update the <tt>Frames</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding frame address.
   --  ------------------------------
   procedure Find_Frames (Target : in out MAT.Events.Targets.Target_Events'Class;
                          Filter : in MAT.Expressions.Expression_Type;
                          Depth  : in Natural;
                          Frames : in out MAT.Events.Tools.Frame_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type);

      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type) is

         procedure Update_Size (Key  : in MAT.Events.Tools.Frame_Key_Type;
                                Info : in out MAT.Events.Tools.Event_Info_Type);

         procedure Update_Size (Key  : in MAT.Events.Tools.Frame_Key_Type;
                                Info : in out MAT.Events.Tools.Event_Info_Type) is
            pragma Unreferenced (Key);
         begin
            Info.Count      := Info.Count + 1;
            Info.Last_Event := Event;
            if Event.Event = 2 then
               Info.Malloc_Count := Info.Malloc_Count + 1;
               Info.Alloc_Size := Info.Alloc_Size + Event.Size;
            elsif Event.Event = 3 then
               Info.Realloc_Count := Info.Realloc_Count + 1;
               Info.Alloc_Size := Info.Alloc_Size + Event.Size;
               Info.Free_Size := Info.Free_Size + Event.Old_Size;
            elsif Event.Event = 4 then
               Info.Free_Count := Info.Free_Count + 1;
               Info.Free_Size := Info.Free_Size + Event.Size;
            end if;
         end Update_Size;

      begin
         --  Look for events which are selected by the filter.
         if not Filter.Is_Selected (Event) then
            return;
         end if;
         declare
            Backtrace : constant MAT.Frames.Frame_Table := MAT.Frames.Backtrace (Event.Frame);
            Key       : MAT.Events.Tools.Frame_Key_Type;
         begin
            for I in Backtrace'Range loop
               exit when I > Depth;
               Key.Addr  := Backtrace (Backtrace'Last - I + 1);
               Key.Level := I;
               declare
                  Pos : constant MAT.Events.Tools.Frame_Event_Info_Cursor
                    := Frames.Find (Key);
               begin
                  if MAT.Events.Tools.Frame_Event_Info_Maps.Has_Element (Pos) then
                     --  Increment the count and update the last event.
                     Frames.Update_Element (Pos, Update_Size'Access);
                  else
                     declare
                        Info : MAT.Events.Tools.Event_Info_Type;
                     begin
                        --  Insert a new size with the event.
                        Info.First_Event := Event;
                        Info.Last_Event := Event;
                        Info.Frame_Addr := Key.Addr;
                        Info.Count := 1;
                        Frames.Insert (Key, Info);
                     end;
                  end if;
               end;
            end loop;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Frames;

end MAT.Events.Timelines;

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

   use MAT.Events.Targets;

   ITERATE_COUNT : constant MAT.Events.Event_Id_Type := 10_000;

   procedure Extract (Target : in out MAT.Events.Targets.Target_Events'Class;
                      Into   : in out Timeline_Info_Vector) is
      use type MAT.Types.Target_Time;
      use type MAT.Types.Target_Size;
      procedure Collect (Event : in MAT.Events.Target_Event_Type);

      First_Event : MAT.Events.Target_Event_Type;
      Last_Event  : MAT.Events.Target_Event_Type;
      Prev_Event  : MAT.Events.Target_Event_Type;
      Info        : Timeline_Info;
      First_Id    : MAT.Events.Event_Id_Type;

      procedure Collect (Event : in MAT.Events.Target_Event_Type) is
         Dt : constant MAT.Types.Target_Time := Event.Time - Prev_Event.Time;
      begin
         if Dt > 500_000 then
            Into.Append (Info);
            Info.Malloc_Count := 0;
            Info.Realloc_Count := 0;
            Info.Free_Count := 0;
            Info.First_Event := Event;
            Info.Free_Size := 0;
            Info.Alloc_Size := 0;
            Prev_Event := Event;
         end if;
         Info.Last_Event := Event;
         if Event.Event = 2 then
            Info.Malloc_Count := Info.Malloc_Count + 1;
            Info.Alloc_Size := Info.Alloc_Size + Event.Size;
         elsif Event.Event = 3 then
            Info.Realloc_Count := Info.Realloc_Count + 1;
            Info.Alloc_Size := Info.Alloc_Size + Event.Size;
            Info.Free_Size := Info.Free_Size + Event.Old_Size;
         elsif Event.Event = 4 then
            Info.Free_Count := Info.Free_Count + 1;
            Info.Free_Size := Info.Free_Size + Event.Size;
         end if;
      end Collect;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      Prev_Event      := First_Event;
      Info.First_Event := First_Event;
      First_Id := First_Event.Id;
      while First_Id < Last_Event.Id loop
         Target.Iterate (Start   => First_Id,
                         Finish  => First_Id + ITERATE_COUNT,
                         Process => Collect'Access);
         First_Id := First_Id + ITERATE_COUNT;
      end loop;
   end Extract;

   --  ------------------------------
   --  Find in the events stream the events which are associated with a given event.
   --  When the <tt>Event</tt> is a memory allocation, find the associated reallocation
   --  and free events.  When the event is a free, find the associated allocations.
   --  Collect at most <tt>Max</tt> events.
   --  ------------------------------
   procedure Find_Related (Target : in out MAT.Events.Targets.Target_Events'Class;
                           Event  : in MAT.Events.Target_Event_Type;
                           Max    : in Positive;
                           List   : in out MAT.Events.Tools.Target_Event_Vector) is

      procedure Collect_Free (Event : in MAT.Events.Target_Event_Type);
      procedure Collect_Alloc (Event : in MAT.Events.Target_Event_Type);

      First_Id    : MAT.Events.Event_Id_Type;
      Last_Id     : MAT.Events.Event_Id_Type;
      First_Event : MAT.Events.Target_Event_Type;
      Last_Event  : MAT.Events.Target_Event_Type;
      Addr        : MAT.Types.Target_Addr := Event.Addr;

      Done : exception;

      procedure Collect_Free (Event : in MAT.Events.Target_Event_Type) is
      begin
         if Event.Index = MAT.Events.MSG_FREE and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.MSG_REALLOC and then Event.Old_Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Addr;
         end if;
      end Collect_Free;

      procedure Collect_Alloc (Event : in MAT.Events.Target_Event_Type) is
      begin
         if Event.Index = MAT.Events.MSG_MALLOC and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.MSG_REALLOC and then Event.Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Old_Addr;
         end if;
      end Collect_Alloc;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      First_Id := Event.Id;
      if Event.Index = MAT.Events.MSG_FREE then
         --  Search backward for MSG_MALLOC and MSG_REALLOC.
         First_Id := First_Id - 1;
         while First_Id > First_Event.Id loop
            if First_Id > ITERATE_COUNT then
               Last_Id := First_Id - ITERATE_COUNT;
            else
               Last_Id := First_Event.Id;
            end if;
            Target.Iterate (Start   => First_Id,
                            Finish  => Last_Id,
                            Process => Collect_Alloc'Access);
            First_Id := Last_Id;
         end loop;
      else
         --  Search forward for MSG_REALLOC and MSG_FREE
         First_Id := First_Id + 1;
         while First_Id < Last_Event.Id loop
            Target.Iterate (Start   => First_Id,
                            Finish  => First_Id + ITERATE_COUNT,
                            Process => Collect_Free'Access);
            First_Id := First_Id + ITERATE_COUNT;
         end loop;
      end if;

   exception
      when Done =>
         null;
   end Find_Related;

   --  ------------------------------
   --  Find the sizes of malloc and realloc events which is selected by the given filter.
   --  Update the <tt>Sizes</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding size.
   --  ------------------------------
   procedure Find_Sizes (Target : in out MAT.Events.Targets.Target_Events'Class;
                         Filter : in MAT.Expressions.Expression_Type;
                         Sizes  : in out MAT.Events.Tools.Size_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type);

      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type) is
         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Tools.Event_Info_Type);

         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Tools.Event_Info_Type) is
            pragma Unreferenced (Size);
         begin
            Info.Count      := Info.Count + 1;
            Info.Last_Event := Event;
            if Event.Index = MAT.Events.MSG_MALLOC then
               Info.Alloc_Size := Info.Alloc_Size + Event.Size;
            elsif Event.Index = MAT.Events.MSG_REALLOC then
               Info.Alloc_Size := Info.Alloc_Size + Event.Size;
               Info.Free_Size := Info.Alloc_Size + Event.Old_Size;
            else
               Info.Free_Size := Info.Alloc_Size + Event.Size;
            end if;
         end Update_Size;

      begin
         --  Look for malloc or realloc events which are selected by the filter.
         if (Event.Index /= MAT.Events.MSG_MALLOC
             and Event.Index /= MAT.Events.MSG_FREE
             and Event.Index /= MAT.Events.MSG_REALLOC)
           or else not Filter.Is_Selected (Event)
         then
            return;
         end if;
         declare
            Pos : constant MAT.Events.Tools.Size_Event_Info_Cursor := Sizes.Find (Event.Size);
         begin
            if MAT.Events.Tools.Size_Event_Info_Maps.Has_Element (Pos) then
               --  Increment the count and update the last event.
               Sizes.Update_Element (Pos, Update_Size'Access);
            else
               declare
                  Info : MAT.Events.Tools.Event_Info_Type;
               begin
                  --  Insert a new size with the event.
                  Info.First_Event := Event;
                  MAT.Events.Tools.Collect_Info (Info, Event);
                  Sizes.Insert (Event.Size, Info);
               end;
            end if;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Sizes;

   --  ------------------------------
   --  Find the function address from the call event frames for the events which is selected
   --  by the given filter.  The function addresses are collected up to the given frame depth.
   --  Update the <tt>Frames</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding frame address.
   --  ------------------------------
   procedure Find_Frames (Target : in out MAT.Events.Targets.Target_Events'Class;
                          Filter : in MAT.Expressions.Expression_Type;
                          Depth  : in Natural;
                          Frames : in out MAT.Events.Tools.Frame_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type);

      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type) is

         procedure Update_Size (Key  : in MAT.Events.Tools.Frame_Key_Type;
                                Info : in out MAT.Events.Tools.Event_Info_Type);

         procedure Update_Size (Key  : in MAT.Events.Tools.Frame_Key_Type;
                                Info : in out MAT.Events.Tools.Event_Info_Type) is
            pragma Unreferenced (Key);
         begin
            MAT.Events.Tools.Collect_Info (Info, Event);
         end Update_Size;

      begin
         --  Look for events which are selected by the filter.
         if not Filter.Is_Selected (Event) then
            return;
         end if;
         declare
            Backtrace : constant MAT.Frames.Frame_Table := MAT.Frames.Backtrace (Event.Frame);
            Key       : MAT.Events.Tools.Frame_Key_Type;
         begin
            for I in Backtrace'Range loop
               exit when I > Depth;
               Key.Addr  := Backtrace (Backtrace'Last - I + 1);
               Key.Level := I;
               declare
                  Pos : constant MAT.Events.Tools.Frame_Event_Info_Cursor
                    := Frames.Find (Key);
               begin
                  if MAT.Events.Tools.Frame_Event_Info_Maps.Has_Element (Pos) then
                     --  Increment the count and update the last event.
                     Frames.Update_Element (Pos, Update_Size'Access);
                  else
                     declare
                        Info : MAT.Events.Tools.Event_Info_Type;
                     begin
                        --  Insert a new size with the event.
                        Info.First_Event := Event;
                        Info.Count := 0;
                        MAT.Events.Tools.Collect_Info (Info, Event);
                        Frames.Insert (Key, Info);
                     end;
                  end if;
               end;
            end loop;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Frames;

end MAT.Events.Timelines;

Use MAT.Events.Tools.Collect_Info to collect the information about events


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

with GNAT.Command_Line;

with ASF.Applications.Main;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;

with EL.Objects;
--  This example reads an XHTML file and renders the result.
procedure Render is

   use GNAT.Command_Line;
   use Ada.Strings.Fixed;

   use ASF;

   use EL.Objects;

   Factory  : ASF.Applications.Main.Application_Factory;
   App      : Applications.Main.Application;
   Conf     : Applications.Config;
begin
   Conf.Set ("view.ignore_white_spaces", "false");
   Conf.Set ("view.escape_unknown_tags", "false");
   Conf.Set ("view.ignore_empty_lines", "true");
   Conf.Set ("view.dir", ".");
   Conf.Set ("view.file_ext", "");

   App.Initialize (Conf, Factory);
   loop
      case Getopt ("D:") is
         when 'D' =>
            declare
               Value : constant String := Parameter;
               Pos   : constant Natural := Index (Value, "=");
            begin
               if Pos > 0 then
                  App.Set_Global (Name  => Value (Value'First .. Pos - 1),
                                  Value => To_Object (Value (Pos + 1 .. Value'Last)));
               else
                  App.Set_Global (Name  => Value (Value'First .. Pos - 1),
                                  Value => To_Object (True));
               end if;
            end;

         when others =>
            exit;
      end case;
   end loop;

   declare
      View_Name : constant String := Get_Argument;
      Pos       : constant Natural := Index (View_Name, ".");
      Req       : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Content   : Ada.Strings.Unbounded.Unbounded_String;
   begin
      if View_Name = "" or Pos = 0 then
         Ada.Text_IO.Put_Line ("Usage: render [-DNAME=VALUE ] file");
         Ada.Text_IO.Put_Line ("Example: render -DcontextPath=/test samples/web/ajax.xhtml");
         return;
      end if;

      Req.Set_Method ("GET");
      Req.Set_Request_URI (View_Name (View_Name'First .. Pos - 1));
      App.Dispatch (Page     => View_Name (View_Name'First .. Pos - 1),
                    Request  => Req,
                    Response => Reply);

      Reply.Read_Content (Content);
      Ada.Text_IO.Put_Line (Ada.Strings.Unbounded.To_String (Content));

   exception
      when Ada.IO_Exceptions.Name_Error =>
         Ada.Text_IO.Put_Line ("Cannot read file '" & View_Name & "'");
   end;
end Render;

-----------------------------------------------------------------------
--  render -- XHTML Rendering example
--  Copyright (C) 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 Ada.Text_IO;
with Ada.IO_Exceptions;
with Ada.Strings.Unbounded;
with Ada.Strings.Fixed;

with GNAT.Command_Line;

with ASF.Applications.Main;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Servlets;
with ASF.Servlets.Faces;
with ASF.Server;

with EL.Objects;
--  This example reads an XHTML file and renders the result.
procedure Render is

   use GNAT.Command_Line;
   use Ada.Strings.Fixed;

   use ASF;

   use EL.Objects;

   Factory   : ASF.Applications.Main.Application_Factory;
   Faces     : aliased ASF.Servlets.Faces.Faces_Servlet;
   App       : aliased Applications.Main.Application;
   Conf      : Applications.Config;
   Container : ASF.Server.Container;
begin
   Conf.Set ("view.ignore_white_spaces", "false");
   Conf.Set ("view.escape_unknown_tags", "false");
   Conf.Set ("view.ignore_empty_lines", "true");
   Conf.Set ("view.dir", "./");
   Conf.Set ("view.file_ext", "");
   App.Initialize (Conf, Factory);

   App.Add_Servlet (Name => "file", Server => Faces'Unchecked_Access);
   App.Add_Mapping ("*.xhtml", "file");
   Container.Register_Application ("/render", App'Unchecked_Access);
   loop
      case Getopt ("D:") is
         when 'D' =>
            declare
               Value : constant String := Parameter;
               Pos   : constant Natural := Index (Value, "=");
            begin
               if Pos > 0 then
                  App.Set_Global (Name  => Value (Value'First .. Pos - 1),
                                  Value => To_Object (Value (Pos + 1 .. Value'Last)));
               else
                  App.Set_Global (Name  => Value (Value'First .. Pos - 1),
                                  Value => To_Object (True));
               end if;
            end;

         when others =>
            exit;
      end case;
   end loop;

   declare
      View_Name : constant String := Get_Argument;
      Pos       : constant Natural := Index (View_Name, ".");
      Req       : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Content   : Ada.Strings.Unbounded.Unbounded_String;
   begin
      if View_Name = "" or Pos = 0 then
         Ada.Text_IO.Put_Line ("Usage: render [-DNAME=VALUE ] file");
         Ada.Text_IO.Put_Line ("Example: render -DcontextPath=/test samples/web/ajax.xhtml");
         return;
      end if;

      Req.Set_Method ("GET");
      Req.Set_Request_URI ("/render/" & View_Name); --  View_Name (View_Name'First .. Pos - 1) & ".html");
      Container.Service (Req, Reply);

      Reply.Read_Content (Content);
      Ada.Text_IO.Put_Line (Ada.Strings.Unbounded.To_String (Content));

   exception
      when Ada.IO_Exceptions.Name_Error =>
         Ada.Text_IO.Put_Line ("Cannot read file '" & View_Name & "'");
   end;
end Render;

Fix the render example so that it works with the new ASF routes


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

   --  Register the CURL Http manager.
   procedure Register;

private

   package C renames Interfaces.C;
   package Strings renames Interfaces.C.Strings;

   use type C.size_t;
   use type C.int;

   --  Define 'Int' and 'Chars_Ptr' with capitals to avoid GNAT warnings due
   --  to Eclipse capitalization.
   subtype Int is C.int;
   subtype Chars_Ptr is Strings.chars_ptr;
   subtype Size_T is C.size_t;

   subtype CURL is System.Address;

   type CURL_Code is new Interfaces.C.int;

   CURLE_OK               : constant CURL_Code := 0;

   type CURL_Info is new Int;

   type Curl_Option is new Int;

   type CURL_Slist;
   type CURL_Slist_Access is access CURL_Slist;

   type CURL_Slist is record
      Data : Chars_Ptr;
      Next : CURL_Slist_Access;
   end record;

   --  Check the CURL result code and report and exception and a log message if
   --  the CURL code indicates an error.
   procedure Check_Code (Code    : in CURL_Code;
                         Message : in String);

   type Curl_Http_Manager is new Http_Manager with null record;
   type Curl_Http_Manager_Access is access all Http_Manager'Class;

   --  Create a new HTTP request associated with the current request manager.
   procedure Create (Manager  : in Curl_Http_Manager;
                     Http     : in out Client'Class);

   procedure Do_Get (Manager  : in Curl_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class);

   procedure Do_Post (Manager  : in Curl_Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class);

   type Curl_Http_Request is new Util.Http.Mockups.Mockup_Request with record
      Data         : CURL := System.Null_Address;
      URL          : Chars_Ptr := Interfaces.C.Strings.Null_Ptr;
      Content      : Chars_Ptr := Interfaces.C.Strings.Null_Ptr;
      Curl_Headers : CURL_Slist_Access := null;
   end record;
   type Curl_Http_Request_Access is access all Curl_Http_Request'Class;

   --  Prepare to setup the headers in the request.
   procedure Set_Headers (Request : in out Curl_Http_Request);

   overriding
   procedure Finalize (Request : in out Curl_Http_Request);

   type Curl_Http_Response is new Util.Http.Mockups.Mockup_Response with record
      C : CURL;
      Content : Ada.Strings.Unbounded.Unbounded_String;
      Status  : Natural;
      Parsing_Body : Boolean := False;
   end record;
   type Curl_Http_Response_Access is access all Curl_Http_Response'Class;

   --  Get the response body as a string.
   overriding
   function Get_Body (Reply : in Curl_Http_Response) return String;

   --  Get the response status code.
   overriding
   function Get_Status (Reply : in Curl_Http_Response) return Natural;

   --  Add a string to a CURL slist.
   function Curl_Slist_Append (List  : in CURL_Slist_Access;
                               Value : in Chars_Ptr) return CURL_Slist_Access;
   pragma Import (C, Curl_Slist_Append, "curl_slist_append");

   --  Free an entrire CURL slist.
   procedure Curl_Slist_Free_All (List : in CURL_Slist_Access);
   pragma Import (C, Curl_Slist_Free_All, "curl_slist_free_all");

   --  Start a libcurl easy session.
   function Curl_Easy_Init return CURL;
   pragma Import (C, Curl_Easy_Init, "curl_easy_init");

   --  End a libcurl easy session.
   procedure Curl_Easy_Cleanup (Handle : in CURL);
   pragma Import (C, Curl_Easy_Cleanup, "curl_easy_cleanup");

   --  Perform a file transfer.
   function Curl_Easy_Perform (Handle : in CURL) return CURL_Code;
   pragma Import (C, Curl_Easy_Perform, "curl_easy_perform");

   --  Return the error message which correspond to the given CURL error code.
   function Curl_Easy_Strerror (Code : in CURL_Code) return Chars_Ptr;
   pragma Import (C, Curl_Easy_Strerror, "curl_easy_strerror");

   --  Set options for a curl easy handle.
   function Curl_Easy_Setopt_String (Handle : in CURL;
                                     Option : in Curl_Option;
                                     Value  : in Chars_Ptr) return CURL_Code;
   pragma Import (C, Curl_Easy_Setopt_String, "curl_easy_setopt");

   --  Set options for a curl easy handle.
   function Curl_Easy_Setopt_Slist (Handle : in CURL;
                                     Option : in Curl_Option;
                                     Value  : in CURL_Slist_Access) return CURL_Code;
   pragma Import (C, Curl_Easy_Setopt_Slist, "curl_easy_setopt");

   --  Set options for a curl easy handle.
   function Curl_Easy_Setopt_Long (Handle : in CURL;
                                     Option : in Curl_Option;
                                     Value  : in Interfaces.C.long) return CURL_Code;
   pragma Import (C, Curl_Easy_Setopt_Long, "curl_easy_setopt");

   --  Get information from a CURL handle for an option returning a String.
   function Curl_Easy_Getinfo_String (Handle : in CURL;
                                      Option : in CURL_Info;
                                      Value  : access Chars_Ptr) return CURL_Code;
   pragma Import (C, Curl_Easy_Getinfo_String, "curl_easy_getinfo");

   --  Get information from a CURL handle for an option returning a Long.
   function Curl_Easy_Getinfo_Long (Handle : in CURL;
                                    Option : in CURL_Info;
                                    Value  : access C.long) return CURL_Code;
   pragma Import (C, Curl_Easy_Getinfo_Long, "curl_easy_getinfo");

   function Curl_Easy_Setopt_Write_Callback
     (Handle : in CURL;
      Option : in Curl_Option;
      Func : access function (Data  : in Chars_Ptr;
                              Size  : in Size_T;
                              Nmemb : in Size_T;
                              Ptr   : in Curl_Http_Response_Access) return Size_T)
      return CURL_Code;
   pragma Import (C, Curl_Easy_Setopt_Write_Callback, "curl_easy_setopt");

   --  Set options for a curl easy handle.
   function Curl_Easy_Setopt_Data (Handle : in CURL;
                                   Option : in Curl_Option;
                                   Value  : in Curl_Http_Response_Access) return CURL_Code;
   pragma Import (C, Curl_Easy_Setopt_Data, "curl_easy_setopt");

   function Read_Response (Data     : in Chars_Ptr;
                           Size     : in Size_T;
                           Nmemb    : in Size_T;
                           Response : in Curl_Http_Response_Access) return Size_T;

end Util.Http.Clients.Curl;

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

   --  Register the CURL Http manager.
   procedure Register;

private

   package C renames Interfaces.C;
   package Strings renames Interfaces.C.Strings;

   use type C.size_t;
   use type C.int;

   --  Define 'Int' and 'Chars_Ptr' with capitals to avoid GNAT warnings due
   --  to Eclipse capitalization.
   subtype Int is C.int;
   subtype Chars_Ptr is Strings.chars_ptr;
   subtype Size_T is C.size_t;

   subtype CURL is System.Address;

   type CURL_Code is new Interfaces.C.int;

   CURLE_OK               : constant CURL_Code := 0;

   type CURL_Info is new Int;

   type Curl_Option is new Int;

   type CURL_Slist;
   type CURL_Slist_Access is access CURL_Slist;

   type CURL_Slist is record
      Data : Chars_Ptr;
      Next : CURL_Slist_Access;
   end record;

   --  Check the CURL result code and report and exception and a log message if
   --  the CURL code indicates an error.
   procedure Check_Code (Code    : in CURL_Code;
                         Message : in String);

   type Curl_Http_Manager is new Http_Manager with null record;
   type Curl_Http_Manager_Access is access all Http_Manager'Class;

   --  Create a new HTTP request associated with the current request manager.
   procedure Create (Manager  : in Curl_Http_Manager;
                     Http     : in out Client'Class);

   overriding
   procedure Do_Get (Manager  : in Curl_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class);

   overriding
   procedure Do_Post (Manager  : in Curl_Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class);

   overriding
   procedure Do_Put (Manager  : in Curl_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Data     : in String;
                     Reply    : out Response'Class);

   type Curl_Http_Request is new Util.Http.Mockups.Mockup_Request with record
      Data         : CURL := System.Null_Address;
      URL          : Chars_Ptr := Interfaces.C.Strings.Null_Ptr;
      Content      : Chars_Ptr := Interfaces.C.Strings.Null_Ptr;
      Curl_Headers : CURL_Slist_Access := null;
   end record;
   type Curl_Http_Request_Access is access all Curl_Http_Request'Class;

   --  Prepare to setup the headers in the request.
   procedure Set_Headers (Request : in out Curl_Http_Request);

   overriding
   procedure Finalize (Request : in out Curl_Http_Request);

   type Curl_Http_Response is new Util.Http.Mockups.Mockup_Response with record
      C : CURL;
      Content : Ada.Strings.Unbounded.Unbounded_String;
      Status  : Natural;
      Parsing_Body : Boolean := False;
   end record;
   type Curl_Http_Response_Access is access all Curl_Http_Response'Class;

   --  Get the response body as a string.
   overriding
   function Get_Body (Reply : in Curl_Http_Response) return String;

   --  Get the response status code.
   overriding
   function Get_Status (Reply : in Curl_Http_Response) return Natural;

   --  Add a string to a CURL slist.
   function Curl_Slist_Append (List  : in CURL_Slist_Access;
                               Value : in Chars_Ptr) return CURL_Slist_Access;
   pragma Import (C, Curl_Slist_Append, "curl_slist_append");

   --  Free an entrire CURL slist.
   procedure Curl_Slist_Free_All (List : in CURL_Slist_Access);
   pragma Import (C, Curl_Slist_Free_All, "curl_slist_free_all");

   --  Start a libcurl easy session.
   function Curl_Easy_Init return CURL;
   pragma Import (C, Curl_Easy_Init, "curl_easy_init");

   --  End a libcurl easy session.
   procedure Curl_Easy_Cleanup (Handle : in CURL);
   pragma Import (C, Curl_Easy_Cleanup, "curl_easy_cleanup");

   --  Perform a file transfer.
   function Curl_Easy_Perform (Handle : in CURL) return CURL_Code;
   pragma Import (C, Curl_Easy_Perform, "curl_easy_perform");

   --  Return the error message which correspond to the given CURL error code.
   function Curl_Easy_Strerror (Code : in CURL_Code) return Chars_Ptr;
   pragma Import (C, Curl_Easy_Strerror, "curl_easy_strerror");

   --  Set options for a curl easy handle.
   function Curl_Easy_Setopt_String (Handle : in CURL;
                                     Option : in Curl_Option;
                                     Value  : in Chars_Ptr) return CURL_Code;
   pragma Import (C, Curl_Easy_Setopt_String, "curl_easy_setopt");

   --  Set options for a curl easy handle.
   function Curl_Easy_Setopt_Slist (Handle : in CURL;
                                     Option : in Curl_Option;
                                     Value  : in CURL_Slist_Access) return CURL_Code;
   pragma Import (C, Curl_Easy_Setopt_Slist, "curl_easy_setopt");

   --  Set options for a curl easy handle.
   function Curl_Easy_Setopt_Long (Handle : in CURL;
                                     Option : in Curl_Option;
                                     Value  : in Interfaces.C.long) return CURL_Code;
   pragma Import (C, Curl_Easy_Setopt_Long, "curl_easy_setopt");

   --  Get information from a CURL handle for an option returning a String.
   function Curl_Easy_Getinfo_String (Handle : in CURL;
                                      Option : in CURL_Info;
                                      Value  : access Chars_Ptr) return CURL_Code;
   pragma Import (C, Curl_Easy_Getinfo_String, "curl_easy_getinfo");

   --  Get information from a CURL handle for an option returning a Long.
   function Curl_Easy_Getinfo_Long (Handle : in CURL;
                                    Option : in CURL_Info;
                                    Value  : access C.long) return CURL_Code;
   pragma Import (C, Curl_Easy_Getinfo_Long, "curl_easy_getinfo");

   function Curl_Easy_Setopt_Write_Callback
     (Handle : in CURL;
      Option : in Curl_Option;
      Func : access function (Data  : in Chars_Ptr;
                              Size  : in Size_T;
                              Nmemb : in Size_T;
                              Ptr   : in Curl_Http_Response_Access) return Size_T)
      return CURL_Code;
   pragma Import (C, Curl_Easy_Setopt_Write_Callback, "curl_easy_setopt");

   --  Set options for a curl easy handle.
   function Curl_Easy_Setopt_Data (Handle : in CURL;
                                   Option : in Curl_Option;
                                   Value  : in Curl_Http_Response_Access) return CURL_Code;
   pragma Import (C, Curl_Easy_Setopt_Data, "curl_easy_setopt");

   function Read_Response (Data     : in Chars_Ptr;
                           Size     : in Size_T;
                           Nmemb    : in Size_T;
                           Response : in Curl_Http_Response_Access) return Size_T;

end Util.Http.Clients.Curl;

Declare and override the Do_Put procedure


--  Copyright (c) 2017 onox <denkpadje@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.Tags.Generic_Dispatching_Constructor;

with Orka.SIMD;
with Orka.Transforms.Singles.Vectors;
with Orka.Types;

package body Orka.Cameras is

   package Vector_Transforms renames Orka.Transforms.Singles.Vectors;

   function Clamp_Distance is new Orka.Types.Clamp (GL.Types.Single, Distance);
   function Normalize_Angle is new Orka.Types.Normalize_Periodic (GL.Types.Single, Angle);

   procedure Set_FOV (Object : in out Camera_Lens; FOV : GL.Types.Single) is
   begin
      Object.FOV := FOV;
   end Set_FOV;

   function FOV (Object : Camera_Lens) return GL.Types.Single is
     (Object.FOV);

   function Projection_Matrix (Object : Camera_Lens) return Transforms.Matrix4 is
      Width  : constant GL.Types.Single := GL.Types.Single (Object.Width);
      Height : constant GL.Types.Single := GL.Types.Single (Object.Height);
   begin
      return Transforms.Infinite_Perspective_Reversed_Z (Object.FOV, Width / Height, 0.1);
   end Projection_Matrix;

   -----------------------------------------------------------------------------

   procedure Set_Position
     (Object   : in out First_Person_Camera;
      Position : Transforms.Vector4) is
   begin
      Object.Position := Position;
   end Set_Position;

   procedure Set_Orientation
     (Object : in out Look_From_Camera;
      Roll, Pitch, Yaw : Angle) is
   begin
      Object.Roll := Roll;
      Object.Pitch := Pitch;
      Object.Yaw := Yaw;
   end Set_Orientation;

   overriding
   procedure Look_At
     (Object : in out Look_At_Camera;
      Target : Behaviors.Behavior_Ptr) is
   begin
      Object.Target := Target;
   end Look_At;

   procedure Set_Up_Direction
     (Object    : in out Look_At_Camera;
      Direction : Transforms.Vector4) is
   begin
      Object.Up := Direction;
   end Set_Up_Direction;

   overriding
   procedure Look_At
     (Object : in out Third_Person_Camera;
      Target : Behaviors.Behavior_Ptr) is
   begin
      Object.Target := Target;
   end Look_At;

   procedure Set_Angles
     (Object : in out Rotate_Around_Camera;
      Alpha  : Angle;
      Beta   : Angle) is
   begin
      Object.Alpha := Alpha;
      Object.Beta := Beta;
   end Set_Angles;

   procedure Set_Radius
     (Object : in out Rotate_Around_Camera;
      Radius : Distance) is
   begin
      Object.Radius := Radius;
   end Set_Radius;

   procedure Set_Radius (Object : in out Follow_Camera; Radius : Distance) is
   begin
      Object.Radius := Radius;
   end Set_Radius;

   procedure Set_Height (Object : in out Follow_Camera; Height : Distance) is
   begin
      Object.Height := Height;
   end Set_Height;

   procedure Set_Direction
     (Object    : in out Follow_Camera;
      Direction : Angle) is
   begin
      Object.Direction := Direction;
   end Set_Direction;

   -----------------------------------------------------------------------------

   overriding
   procedure Update (Object : in out Look_From_Camera; Delta_Time : Duration) is
      Using_Camera : constant Boolean := Object.Input.Button_Pressed (Orka.Inputs.Right);
   begin
      Object.Input.Lock_Pointer (Using_Camera);

      if Using_Camera then
         Object.Yaw   := Normalize_Angle (Object.Yaw   + Object.Input.Delta_X);
         Object.Pitch := Normalize_Angle (Object.Pitch + Object.Input.Delta_Y);
      end if;
   end Update;

   --  Look_At camera does not need to implement Update because the
   --  view matrix does not depend on the pointer (it is computed using
   --  the camera's and target's positions)

   overriding
   procedure Update (Object : in out Rotate_Around_Camera; Delta_Time : Duration) is
      Using_Camera : constant Boolean := Object.Input.Button_Pressed (Orka.Inputs.Right);
   begin
      Object.Input.Lock_Pointer (Using_Camera);

      if Using_Camera then
         Object.Alpha := Normalize_Angle (Object.Alpha + Object.Input.Delta_X);
         Object.Beta  := Normalize_Angle (Object.Beta  + Object.Input.Delta_Y);
      end if;

      Object.Radius := Clamp_Distance (Object.Radius - Object.Input.Scroll_Y);
   end Update;

   overriding
   procedure Update (Object : in out Follow_Camera; Delta_Time : Duration) is
      Using_Camera : constant Boolean := Object.Input.Button_Pressed (Orka.Inputs.Right);
   begin
      Object.Input.Lock_Pointer (Using_Camera);

      --  TODO
   end Update;

   -----------------------------------------------------------------------------

   overriding
   function View_Matrix (Object : Look_From_Camera) return Transforms.Matrix4 is
      use Transforms;
   begin
      return Ry (Object.Roll) * Rx (Object.Pitch) * Ry (Object.Yaw);
   end View_Matrix;

   overriding
   function View_Matrix (Object : Look_At_Camera) return Transforms.Matrix4 is
      use Vector_Transforms;
      use Orka.SIMD;

      Forward : constant Vector4 := Normalize (Object.Target.Position - Object.Position);
      Side    : constant Vector4 := Cross (Forward, Object.Up);
      Up      : constant Vector4 := Cross (Side, Forward);
   begin
      return
        ((Side (X), Up (X), -Forward (X), 0.0),
         (Side (Y), Up (Y), -Forward (Y), 0.0),
         (Side (Z), Up (Z), -Forward (Z), 0.0),
         (0.0, 0.0, 0.0, 1.0));
   end View_Matrix;

   overriding
   function View_Matrix (Object : Rotate_Around_Camera) return Transforms.Matrix4 is
      use Transforms;
   begin
      return (0.0, 0.0, -Object.Radius, 0.0) + Rx (Object.Beta) * Ry (Object.Alpha);
   end View_Matrix;

   overriding
   function View_Matrix (Object : Follow_Camera) return Transforms.Matrix4 is
   begin
      --  TODO
      return Transforms.Identity_Value;
   end View_Matrix;

   -----------------------------------------------------------------------------

   overriding
   function View_Position (Object : First_Person_Camera) return Transforms.Vector4 is
     (Object.Position);

   overriding
   function View_Position (Object : Third_Person_Camera) return Transforms.Vector4 is
     (Object.Target.Position);

   -----------------------------------------------------------------------------

   function Create_Lens
     (Width, Height : Positive;
      FOV : GL.Types.Single;
      Context : Contexts.Context) return Camera_Lens'Class is
   begin
      return Result : Camera_Lens (Width, Height) do
         Result.FOV := FOV;
      end return;
   end Create_Lens;

   -----------------------------------------------------------------------------

   Kind_To_Tag : constant array (Camera_Kind) of Ada.Tags.Tag :=
     (Look_From     => Look_From_Camera'Tag,
      Look_At       => Look_At_Camera'Tag,
      Rotate_Around => Rotate_Around_Camera'Tag,
      Follow        => Follow_Camera'Tag);

   overriding
   function Create_Camera
     (Parameters : not null access Parameter_Record) return Look_From_Camera is
   begin
      return Look_From_Camera'(Camera with
        Input => Parameters.Input,
        Lens  => Parameters.Lens,
        FB    => Parameters.FB, others => <>);
   end Create_Camera;

   overriding
   function Create_Camera
     (Parameters : not null access Parameter_Record) return Look_At_Camera is
   begin
      return Look_At_Camera'(Camera with
        Input => Parameters.Input,
        Lens  => Parameters.Lens,
        FB    => Parameters.FB, others => <>);
   end Create_Camera;

   overriding
   function Create_Camera
     (Parameters : not null access Parameter_Record) return Rotate_Around_Camera is
   begin
      return Rotate_Around_Camera'(Camera with
        Input => Parameters.Input,
        Lens  => Parameters.Lens,
        FB    => Parameters.FB, others => <>);
   end Create_Camera;

   overriding
   function Create_Camera
     (Parameters : not null access Parameter_Record) return Follow_Camera is
   begin
      return Follow_Camera'(Camera with
        Input => Parameters.Input,
        Lens  => Parameters.Lens,
        FB    => Parameters.FB, others => <>);
   end Create_Camera;

   function Create_Camera
     (Kind  : Camera_Kind;
      Input : Inputs.Pointer_Input_Ptr;
      Lens  : Lens_Ptr;
      FB    : Rendering.Framebuffers.Framebuffer_Ptr) return Camera'Class
   is
      function Create is new Ada.Tags.Generic_Dispatching_Constructor
        (Camera, Parameter_Record, Create_Camera);

      Parameters : aliased Parameter_Record := (Input, Lens, FB);
   begin
      return Create (Kind_To_Tag (Kind), Parameters'Access);
   end Create_Camera;

end Orka.Cameras;

--  Copyright (c) 2017 onox <denkpadje@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.Tags.Generic_Dispatching_Constructor;

with Orka.SIMD;
with Orka.Transforms.Singles.Vectors;
with Orka.Types;

package body Orka.Cameras is

   package Vector_Transforms renames Orka.Transforms.Singles.Vectors;

   function Clamp_Distance is new Orka.Types.Clamp (GL.Types.Single, Distance);
   function Normalize_Angle is new Orka.Types.Normalize_Periodic (GL.Types.Single, Angle);

   procedure Set_FOV (Object : in out Camera_Lens; FOV : GL.Types.Single) is
   begin
      Object.FOV := FOV;
   end Set_FOV;

   function FOV (Object : Camera_Lens) return GL.Types.Single is
     (Object.FOV);

   function Projection_Matrix (Object : Camera_Lens) return Transforms.Matrix4 is
      Width  : constant GL.Types.Single := GL.Types.Single (Object.Width);
      Height : constant GL.Types.Single := GL.Types.Single (Object.Height);
   begin
      return Transforms.Infinite_Perspective_Reversed_Z (Object.FOV, Width / Height, 0.1);
   end Projection_Matrix;

   -----------------------------------------------------------------------------

   procedure Set_Position
     (Object   : in out First_Person_Camera;
      Position : Transforms.Vector4) is
   begin
      Object.Position := Position;
   end Set_Position;

   procedure Set_Orientation
     (Object : in out Look_From_Camera;
      Roll, Pitch, Yaw : Angle) is
   begin
      Object.Roll := Roll;
      Object.Pitch := Pitch;
      Object.Yaw := Yaw;
   end Set_Orientation;

   overriding
   procedure Look_At
     (Object : in out Look_At_Camera;
      Target : Behaviors.Behavior_Ptr) is
   begin
      Object.Target := Target;
   end Look_At;

   procedure Set_Up_Direction
     (Object    : in out Look_At_Camera;
      Direction : Transforms.Vector4) is
   begin
      Object.Up := Direction;
   end Set_Up_Direction;

   overriding
   procedure Look_At
     (Object : in out Third_Person_Camera;
      Target : Behaviors.Behavior_Ptr) is
   begin
      Object.Target := Target;
   end Look_At;

   procedure Set_Angles
     (Object : in out Rotate_Around_Camera;
      Alpha  : Angle;
      Beta   : Angle) is
   begin
      Object.Alpha := Alpha;
      Object.Beta := Beta;
   end Set_Angles;

   procedure Set_Radius
     (Object : in out Rotate_Around_Camera;
      Radius : Distance) is
   begin
      Object.Radius := Radius;
   end Set_Radius;

   procedure Set_Radius (Object : in out Follow_Camera; Radius : Distance) is
   begin
      Object.Radius := Radius;
   end Set_Radius;

   procedure Set_Height (Object : in out Follow_Camera; Height : Distance) is
   begin
      Object.Height := Height;
   end Set_Height;

   procedure Set_Direction
     (Object    : in out Follow_Camera;
      Direction : Angle) is
   begin
      Object.Direction := Direction;
   end Set_Direction;

   -----------------------------------------------------------------------------

   overriding
   procedure Update (Object : in out Look_From_Camera; Delta_Time : Duration) is
      Using_Camera : constant Boolean := Object.Input.Button_Pressed (Orka.Inputs.Right);
   begin
      Object.Input.Lock_Pointer (Using_Camera);

      if Using_Camera then
         Object.Yaw   := Normalize_Angle (Object.Yaw   + Object.Input.Delta_X);
         Object.Pitch := Normalize_Angle (Object.Pitch + Object.Input.Delta_Y);
      end if;
   end Update;

   --  Look_At camera does not need to implement Update because the
   --  view matrix does not depend on the pointer (it is computed using
   --  the camera's and target's positions)

   overriding
   procedure Update (Object : in out Rotate_Around_Camera; Delta_Time : Duration) is
      Using_Camera : constant Boolean := Object.Input.Button_Pressed (Orka.Inputs.Right);
   begin
      Object.Input.Lock_Pointer (Using_Camera);

      if Using_Camera then
         Object.Alpha := Normalize_Angle (Object.Alpha + Object.Input.Delta_X);
         Object.Beta  := Normalize_Angle (Object.Beta  + Object.Input.Delta_Y);
      end if;

      Object.Radius := Clamp_Distance (Object.Radius - Object.Input.Scroll_Y);
   end Update;

   overriding
   procedure Update (Object : in out Follow_Camera; Delta_Time : Duration) is
      Using_Camera : constant Boolean := Object.Input.Button_Pressed (Orka.Inputs.Right);
   begin
      Object.Input.Lock_Pointer (Using_Camera);

      --  TODO
   end Update;

   -----------------------------------------------------------------------------

   overriding
   function View_Matrix (Object : Look_From_Camera) return Transforms.Matrix4 is
      use Transforms;
   begin
      return Ry (Object.Roll) * Rx (Object.Pitch) * Ry (Object.Yaw);
   end View_Matrix;

   overriding
   function View_Matrix (Object : Look_At_Camera) return Transforms.Matrix4 is
      use Vector_Transforms;
      use Transforms;
      use Orka.SIMD;

      Rotate_To_GL : constant Matrix4 := Ry (-90.0) * Rx (-90.0);

      Forward : constant Vector_Type
        := Normalize (Rotate_To_GL * (Object.Target.Position - Object.Position));
      Side    : constant Vector_Type := Cross (Forward, Object.Up);
      Up      : constant Vector_Type := Cross (Side, Forward);
   begin
      return
        ((Side (X), Up (X), -Forward (X), 0.0),
         (Side (Y), Up (Y), -Forward (Y), 0.0),
         (Side (Z), Up (Z), -Forward (Z), 0.0),
         (0.0, 0.0, 0.0, 1.0));
   end View_Matrix;

   overriding
   function View_Matrix (Object : Rotate_Around_Camera) return Transforms.Matrix4 is
      use Transforms;
   begin
      return (0.0, 0.0, -Object.Radius, 0.0) + Rx (Object.Beta) * Ry (Object.Alpha);
   end View_Matrix;

   overriding
   function View_Matrix (Object : Follow_Camera) return Transforms.Matrix4 is
   begin
      --  TODO
      return Transforms.Identity_Value;
   end View_Matrix;

   -----------------------------------------------------------------------------

   overriding
   function View_Position (Object : First_Person_Camera) return Transforms.Vector4 is
     (Object.Position);

   overriding
   function View_Position (Object : Third_Person_Camera) return Transforms.Vector4 is
     (Object.Target.Position);

   -----------------------------------------------------------------------------

   function Create_Lens
     (Width, Height : Positive;
      FOV : GL.Types.Single;
      Context : Contexts.Context) return Camera_Lens'Class is
   begin
      return Result : Camera_Lens (Width, Height) do
         Result.FOV := FOV;
      end return;
   end Create_Lens;

   -----------------------------------------------------------------------------

   Kind_To_Tag : constant array (Camera_Kind) of Ada.Tags.Tag :=
     (Look_From     => Look_From_Camera'Tag,
      Look_At       => Look_At_Camera'Tag,
      Rotate_Around => Rotate_Around_Camera'Tag,
      Follow        => Follow_Camera'Tag);

   overriding
   function Create_Camera
     (Parameters : not null access Parameter_Record) return Look_From_Camera is
   begin
      return Look_From_Camera'(Camera with
        Input => Parameters.Input,
        Lens  => Parameters.Lens,
        FB    => Parameters.FB, others => <>);
   end Create_Camera;

   overriding
   function Create_Camera
     (Parameters : not null access Parameter_Record) return Look_At_Camera is
   begin
      return Look_At_Camera'(Camera with
        Input => Parameters.Input,
        Lens  => Parameters.Lens,
        FB    => Parameters.FB, others => <>);
   end Create_Camera;

   overriding
   function Create_Camera
     (Parameters : not null access Parameter_Record) return Rotate_Around_Camera is
   begin
      return Rotate_Around_Camera'(Camera with
        Input => Parameters.Input,
        Lens  => Parameters.Lens,
        FB    => Parameters.FB, others => <>);
   end Create_Camera;

   overriding
   function Create_Camera
     (Parameters : not null access Parameter_Record) return Follow_Camera is
   begin
      return Follow_Camera'(Camera with
        Input => Parameters.Input,
        Lens  => Parameters.Lens,
        FB    => Parameters.FB, others => <>);
   end Create_Camera;

   function Create_Camera
     (Kind  : Camera_Kind;
      Input : Inputs.Pointer_Input_Ptr;
      Lens  : Lens_Ptr;
      FB    : Rendering.Framebuffers.Framebuffer_Ptr) return Camera'Class
   is
      function Create is new Ada.Tags.Generic_Dispatching_Constructor
        (Camera, Parameter_Record, Create_Camera);

      Parameters : aliased Parameter_Record := (Input, Lens, FB);
   begin
      return Create (Kind_To_Tag (Kind), Parameters'Access);
   end Create_Camera;

end Orka.Cameras;

orka: Fix function View_Matrix of Look_At camera

Function Position of interface Behavior returns positions in the
structural frame (X = aft, Y = right, Z = top), not in OpenGL
(X = right, Y = top, Z = aft).

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


-----------------------------------------------------------------------
--  wiki-helpers-parser -- Generic procedure for the wiki parser
--  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 Wiki.Strings;
with Wiki.Documents;
with Wiki.Streams;
generic
   type Engine_Type is limited private;
   type Element_Type is limited private;
   with function Element (Item : in Element_Type;
                          Pos  : in Natural) return Wiki.Strings.WChar is <>;
   with function Length (Item  : in Element_Type) return Natural is <>;
   with procedure Parse (Engine : in out Engine_Type;
                         Stream : in Wiki.Streams.Input_Stream_Access;
                         Doc    : in out Wiki.Documents.Document) is <>;
procedure Wiki.Helpers.Parser (Engine  : in out Engine_Type;
                               Content : in Element_Type;
                               Doc     : in out Wiki.Documents.Document);
pragma Preelaborate (Wiki.Helpers.Parser);

-----------------------------------------------------------------------
--  wiki-helpers-parser -- Generic procedure for the wiki parser
--  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 Wiki.Strings;
with Wiki.Documents;
with Wiki.Streams;
generic
   type Engine_Type is limited private;
   type Element_Type (<>) is limited private;
   with procedure Element (Item : in Element_Type;
                           Pos  : in out Natural;
                           Char : out Wiki.Strings.WChar) is <>;
   with function Length (Item  : in Element_Type) return Natural is <>;
   with procedure Parse (Engine : in out Engine_Type;
                         Stream : in Wiki.Streams.Input_Stream_Access;
                         Doc    : in out Wiki.Documents.Document) is <>;
procedure Wiki.Helpers.Parser (Engine  : in out Engine_Type;
                               Content : in Element_Type;
                               Doc     : in out Wiki.Documents.Document);
pragma Preelaborate (Wiki.Helpers.Parser);

Change the Element operation to a procedure that gets and updates the position


-----------------------------------------------------------------------
--  util-encoders-hmac-sha1 -- Compute HMAC-SHA1 authentication code
--  Copyright (C) 2011, 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.Encoders.Base16;
with Util.Encoders.Base64;

--  The Util.Encodes.HMAC.SHA1 package generates HMAC-SHA1 authentication
--  (See RFC 2104 - HMAC: Keyed-Hashing for Message Authentication).
package body Util.Encoders.HMAC.SHA1 is

   --  ------------------------------
   --  Sign the data string with the key and return the HMAC-SHA1 code in binary.
   --  ------------------------------
   function Sign (Key  : in String;
                  Data : in String) return Util.Encoders.SHA1.Hash_Array is
      Ctx    : Context;
      Result : Util.Encoders.SHA1.Hash_Array;
   begin
      Set_Key (Ctx, Key);
      Update (Ctx, Data);
      Finish (Ctx, Result);
      return Result;
   end Sign;

   --  ------------------------------
   --  Sign the data string with the key and return the HMAC-SHA1 code as hexadecimal string.
   --  ------------------------------
   function Sign (Key  : in String;
                  Data : in String) return Util.Encoders.SHA1.Digest is
      Ctx    : Context;
      Result : Util.Encoders.SHA1.Digest;
   begin
      Set_Key (Ctx, Key);
      Update (Ctx, Data);
      Finish (Ctx, Result);
      return Result;
   end Sign;

   --  ------------------------------
   --  Sign the data string with the key and return the HMAC-SHA1 code as base64 string.
   --  When URL is True, use the base64 URL alphabet to encode in base64.
   --  ------------------------------
   function Sign_Base64 (Key  : in String;
                         Data : in String;
                         URL  : in Boolean := False) return Util.Encoders.SHA1.Base64_Digest is
      Ctx    : Context;
      Result : Util.Encoders.SHA1.Base64_Digest;
   begin
      Set_Key (Ctx, Key);
      Update (Ctx, Data);
      Finish_Base64 (Ctx, Result, URL);
      return Result;
   end Sign_Base64;

   --  ------------------------------
   --  Set the hmac private key.  The key must be set before calling any Update
   --  procedure.
   --  ------------------------------
   procedure Set_Key (E   : in out Context;
                      Key : in String) is
      Buf : Ada.Streams.Stream_Element_Array (1 .. Key'Length);
      for Buf'Address use Key'Address;
      pragma Import (Ada, Buf);

   begin
      Set_Key (E, Buf);
   end Set_Key;

   IPAD : constant Ada.Streams.Stream_Element := 16#36#;
   OPAD : constant Ada.Streams.Stream_Element := 16#5c#;

   --  ------------------------------
   --  Set the hmac private key.  The key must be set before calling any Update
   --  procedure.
   --  ------------------------------
   procedure Set_Key (E   : in out Context;
                      Key : in Ada.Streams.Stream_Element_Array) is
      use type Ada.Streams.Stream_Element_Offset;
      use type Ada.Streams.Stream_Element;
   begin
      --  Reduce the key
      if Key'Length > 64 then
         Util.Encoders.SHA1.Update (E.SHA, Key);
         Util.Encoders.SHA1.Finish (E.SHA, E.Key (0 .. 19));
         E.Key_Len := 19;
      else
         E.Key_Len := Key'Length - 1;
         E.Key (0 .. E.Key_Len) := Key;
      end if;

      --  Hash the key in the SHA1 context.
      declare
         Block : Ada.Streams.Stream_Element_Array (0 .. 63);
      begin
         for I in 0 .. E.Key_Len loop
            Block (I) := IPAD xor E.Key (I);
         end loop;
         for I in E.Key_Len + 1 .. 63 loop
            Block (I) := IPAD;
         end loop;
         Util.Encoders.SHA1.Update (E.SHA, Block);
      end;
   end Set_Key;

   --  ------------------------------
   --  Update the hash with the string.
   --  ------------------------------
   procedure Update (E : in out Context;
                     S : in String) is
   begin
      Util.Encoders.SHA1.Update (E.SHA, S);
   end Update;

   --  ------------------------------
   --  Update the hash with the string.
   --  ------------------------------
   procedure Update (E : in out Context;
                     S : in Ada.Streams.Stream_Element_Array) is
   begin
      Util.Encoders.SHA1.Update (E.SHA, S);
   end Update;

   --  ------------------------------
   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the raw binary hash in Hash.
   --  ------------------------------
   procedure Finish (E    : in out Context;
                     Hash : out Util.Encoders.SHA1.Hash_Array) is
      use type Ada.Streams.Stream_Element;
      use type Ada.Streams.Stream_Element_Offset;
   begin
      Util.Encoders.SHA1.Finish (E.SHA, Hash);

      --  Hash the key in the SHA1 context.
      declare
         Block : Ada.Streams.Stream_Element_Array (0 .. 63);
      begin
         for I in 0 .. E.Key_Len loop
            Block (I) := OPAD xor E.Key (I);
         end loop;
         if E.Key_Len < 63 then
            for I in E.Key_Len + 1 .. 63 loop
               Block (I) := OPAD;
            end loop;
         end if;
         Util.Encoders.SHA1.Update (E.SHA, Block);
      end;
      Util.Encoders.SHA1.Update (E.SHA, Hash);
      Util.Encoders.SHA1.Finish (E.SHA, Hash);
   end Finish;

   --  ------------------------------
   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the hexadecimal hash in Hash.
   --  ------------------------------
   procedure Finish (E    : in out Context;
                     Hash : out Util.Encoders.SHA1.Digest) is
      H       : Util.Encoders.SHA1.Hash_Array;
      B       : Util.Encoders.Base16.Encoder;
   begin
      Finish (E, H);
      B.Convert (H, Hash);
   end Finish;

   --  ------------------------------
   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the base64 hash in Hash.
   --  When URL is True, use the base64 URL alphabet to encode in base64.
   --  ------------------------------
   procedure Finish_Base64 (E    : in out Context;
                            Hash : out Util.Encoders.SHA1.Base64_Digest;
                            URL  : in Boolean := False) is
      H       : Util.Encoders.SHA1.Hash_Array;
      B       : Util.Encoders.Base64.Encoder;
   begin
      Finish (E, H);
      B.Set_URL_Mode (URL);
      B.Convert (H, Hash);
   end Finish_Base64;

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

   --  Initialize the SHA-1 context.
   overriding
   procedure Initialize (E : in out Context) is
   begin
      null;
   end Initialize;

end Util.Encoders.HMAC.SHA1;

-----------------------------------------------------------------------
--  util-encoders-hmac-sha1 -- Compute HMAC-SHA1 authentication code
--  Copyright (C) 2011, 2017, 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.Encoders.Base16;
with Util.Encoders.Base64;

--  The Util.Encodes.HMAC.SHA1 package generates HMAC-SHA1 authentication
--  (See RFC 2104 - HMAC: Keyed-Hashing for Message Authentication).
package body Util.Encoders.HMAC.SHA1 is

   --  ------------------------------
   --  Sign the data string with the key and return the HMAC-SHA1 code in binary.
   --  ------------------------------
   function Sign (Key  : in String;
                  Data : in String) return Util.Encoders.SHA1.Hash_Array is
      Ctx    : Context;
      Result : Util.Encoders.SHA1.Hash_Array;
   begin
      Set_Key (Ctx, Key);
      Update (Ctx, Data);
      Finish (Ctx, Result);
      return Result;
   end Sign;

   --  ------------------------------
   --  Sign the data string with the key and return the HMAC-SHA1 code as hexadecimal string.
   --  ------------------------------
   function Sign (Key  : in String;
                  Data : in String) return Util.Encoders.SHA1.Digest is
      Ctx    : Context;
      Result : Util.Encoders.SHA1.Digest;
   begin
      Set_Key (Ctx, Key);
      Update (Ctx, Data);
      Finish (Ctx, Result);
      return Result;
   end Sign;

   --  ------------------------------
   --  Sign the data array with the key and return the HMAC-SHA256 code in the result.
   --  ------------------------------
   procedure Sign (Key    : in Ada.Streams.Stream_Element_Array;
                   Data   : in Ada.Streams.Stream_Element_Array;
                   Result : out Util.Encoders.SHA1.Hash_Array) is
      Ctx    : Context;
   begin
      Set_Key (Ctx, Key);
      Update (Ctx, Data);
      Finish (Ctx, Result);
   end Sign;

   --  ------------------------------
   --  Sign the data string with the key and return the HMAC-SHA1 code as base64 string.
   --  When URL is True, use the base64 URL alphabet to encode in base64.
   --  ------------------------------
   function Sign_Base64 (Key  : in String;
                         Data : in String;
                         URL  : in Boolean := False) return Util.Encoders.SHA1.Base64_Digest is
      Ctx    : Context;
      Result : Util.Encoders.SHA1.Base64_Digest;
   begin
      Set_Key (Ctx, Key);
      Update (Ctx, Data);
      Finish_Base64 (Ctx, Result, URL);
      return Result;
   end Sign_Base64;

   --  ------------------------------
   --  Set the hmac private key.  The key must be set before calling any Update
   --  procedure.
   --  ------------------------------
   procedure Set_Key (E   : in out Context;
                      Key : in String) is
      Buf : Ada.Streams.Stream_Element_Array (1 .. Key'Length);
      for Buf'Address use Key'Address;
      pragma Import (Ada, Buf);

   begin
      Set_Key (E, Buf);
   end Set_Key;

   IPAD : constant Ada.Streams.Stream_Element := 16#36#;
   OPAD : constant Ada.Streams.Stream_Element := 16#5c#;

   --  ------------------------------
   --  Set the hmac private key.  The key must be set before calling any Update
   --  procedure.
   --  ------------------------------
   procedure Set_Key (E   : in out Context;
                      Key : in Ada.Streams.Stream_Element_Array) is
   begin
      --  Reduce the key
      if Key'Length > 64 then
         Util.Encoders.SHA1.Update (E.SHA, Key);
         Util.Encoders.SHA1.Finish (E.SHA, E.Key (0 .. 19));
         E.Key_Len := 19;
      else
         E.Key_Len := Key'Length - 1;
         E.Key (0 .. E.Key_Len) := Key;
      end if;

      --  Hash the key in the SHA1 context.
      declare
         Block : Ada.Streams.Stream_Element_Array (0 .. 63);
      begin
         for I in 0 .. E.Key_Len loop
            Block (I) := IPAD xor E.Key (I);
         end loop;
         for I in E.Key_Len + 1 .. 63 loop
            Block (I) := IPAD;
         end loop;
         Util.Encoders.SHA1.Update (E.SHA, Block);
      end;
   end Set_Key;

   --  ------------------------------
   --  Update the hash with the string.
   --  ------------------------------
   procedure Update (E : in out Context;
                     S : in String) is
   begin
      Util.Encoders.SHA1.Update (E.SHA, S);
   end Update;

   --  ------------------------------
   --  Update the hash with the string.
   --  ------------------------------
   procedure Update (E : in out Context;
                     S : in Ada.Streams.Stream_Element_Array) is
   begin
      Util.Encoders.SHA1.Update (E.SHA, S);
   end Update;

   --  ------------------------------
   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the raw binary hash in Hash.
   --  ------------------------------
   procedure Finish (E    : in out Context;
                     Hash : out Util.Encoders.SHA1.Hash_Array) is
   begin
      Util.Encoders.SHA1.Finish (E.SHA, Hash);

      --  Hash the key in the SHA1 context.
      declare
         Block : Ada.Streams.Stream_Element_Array (0 .. 63);
      begin
         for I in 0 .. E.Key_Len loop
            Block (I) := OPAD xor E.Key (I);
         end loop;
         if E.Key_Len < 63 then
            for I in E.Key_Len + 1 .. 63 loop
               Block (I) := OPAD;
            end loop;
         end if;
         Util.Encoders.SHA1.Update (E.SHA, Block);
      end;
      Util.Encoders.SHA1.Update (E.SHA, Hash);
      Util.Encoders.SHA1.Finish (E.SHA, Hash);
   end Finish;

   --  ------------------------------
   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the hexadecimal hash in Hash.
   --  ------------------------------
   procedure Finish (E    : in out Context;
                     Hash : out Util.Encoders.SHA1.Digest) is
      H       : Util.Encoders.SHA1.Hash_Array;
      B       : Util.Encoders.Base16.Encoder;
   begin
      Finish (E, H);
      B.Convert (H, Hash);
   end Finish;

   --  ------------------------------
   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the base64 hash in Hash.
   --  When URL is True, use the base64 URL alphabet to encode in base64.
   --  ------------------------------
   procedure Finish_Base64 (E    : in out Context;
                            Hash : out Util.Encoders.SHA1.Base64_Digest;
                            URL  : in Boolean := False) is
      H       : Util.Encoders.SHA1.Hash_Array;
      B       : Util.Encoders.Base64.Encoder;
   begin
      Finish (E, H);
      B.Set_URL_Mode (URL);
      B.Convert (H, Hash);
   end Finish_Base64;

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

   --  Initialize the SHA-1 context.
   overriding
   procedure Initialize (E : in out Context) is
   begin
      null;
   end Initialize;

end Util.Encoders.HMAC.SHA1;

Implement Sign procedure for PBKDF2

Implement Sign procedure for PBKDF2