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

with System;
with Interfaces.C;
with Interfaces.C.Strings;
with Util.Systems.Constants;

package body Util.Systems.DLLs is

   function Sys_Dlopen (Path  : in Interfaces.C.Strings.chars_ptr;
                        Mode  : in Flags) return Handle;
   pragma Import (C, Sys_Dlopen, "dlopen");

   function Sys_Dlclose (Lib : in Handle) return Interfaces.C.int;
   pragma Import (C, Sys_Dlclose, "dlclose");

   function Sys_Dlsym (Lib    : in Handle;
                       Symbol : in Interfaces.C.Strings.chars_ptr) return System.Address;
   pragma Import (C, Sys_Dlsym, "dlsym");

   function Sys_Dlerror return Interfaces.C.Strings.chars_ptr;
   pragma Import (C, Sys_Dlerror, "dlerror");

   function Error_Message return String is
   begin
      return Interfaces.C.Strings.Value (Sys_Dlerror);
   end Error_Message;

   --  -----------------------
   --  Load the shared library with the given name or path and return a library handle.
   --  Raises the <tt>Load_Error</tt> exception if the library cannot be loaded.
   --  -----------------------
   function Load (Path : in String;
                  Mode : in Flags := Util.Systems.Constants.RTLD_LAZY) return Handle is
      Lib    : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.New_String (Path);
      Result : Handle := Sys_Dlopen (Lib, Mode);
   begin
      Interfaces.C.Strings.Free (Lib);
      if Result = Null_Handle then
         raise Load_Error with Error_Message;
      else
         return Result;
      end if;
   end Load;

   --  -----------------------
   --  Unload the shared library.
   --  -----------------------
   procedure Unload (Lib : in Handle) is
      Result : Interfaces.C.int;
   begin
      if Lib /= Null_Handle then
         Result := Sys_Dlclose (Lib);
      end if;
   end Unload;

   --  -----------------------
   --  Get a global symbol with the given name in the library.
   --  Raises the <tt>Not_Found</tt> exception if the symbol does not exist.
   --  -----------------------
   function Get_Symbol (Lib  : in Handle;
                        Name : in String) return System.Address is
      use type System.Address;

      Symbol : Interfaces.C.Strings.Chars_Ptr := Interfaces.C.Strings.New_String (Name);
      Result : System.Address := Sys_Dlsym (Lib, Symbol);
   begin
      Interfaces.C.Strings.Free (Symbol);
      if Result = System.Null_Address then
         raise Not_Found with Error_Message;
      else
         return Result;
      end if;
   end Get_Symbol;

end Util.Systems.DLLs;

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

with Interfaces.C.Strings;

package body Util.Systems.DLLs is

   pragma Linker_Options (Util.Systems.Constants.DLL_OPTIONS);

   function Sys_Dlopen (Path  : in Interfaces.C.Strings.chars_ptr;
                        Mode  : in Flags) return Handle;
   pragma Import (C, Sys_Dlopen, "dlopen");

   function Sys_Dlclose (Lib : in Handle) return Interfaces.C.int;
   pragma Import (C, Sys_Dlclose, "dlclose");

   function Sys_Dlsym (Lib    : in Handle;
                       Symbol : in Interfaces.C.Strings.chars_ptr) return System.Address;
   pragma Import (C, Sys_Dlsym, "dlsym");

   function Sys_Dlerror return Interfaces.C.Strings.chars_ptr;
   pragma Import (C, Sys_Dlerror, "dlerror");

   function Error_Message return String;

   function Error_Message return String is
   begin
      return Interfaces.C.Strings.Value (Sys_Dlerror);
   end Error_Message;

   --  -----------------------
   --  Load the shared library with the given name or path and return a library handle.
   --  Raises the <tt>Load_Error</tt> exception if the library cannot be loaded.
   --  -----------------------
   function Load (Path : in String;
                  Mode : in Flags := Util.Systems.Constants.RTLD_LAZY) return Handle is
      Lib    : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.New_String (Path);
      Result : constant Handle := Sys_Dlopen (Lib, Mode);
   begin
      Interfaces.C.Strings.Free (Lib);
      if Result = Null_Handle then
         raise Load_Error with Error_Message;
      else
         return Result;
      end if;
   end Load;

   --  -----------------------
   --  Unload the shared library.
   --  -----------------------
   procedure Unload (Lib : in Handle) is
      Result : Interfaces.C.int;
      pragma Unreferenced (Result);
   begin
      if Lib /= Null_Handle then
         Result := Sys_Dlclose (Lib);
      end if;
   end Unload;

   --  -----------------------
   --  Get a global symbol with the given name in the library.
   --  Raises the <tt>Not_Found</tt> exception if the symbol does not exist.
   --  -----------------------
   function Get_Symbol (Lib  : in Handle;
                        Name : in String) return System.Address is
      use type System.Address;

      Symbol : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.New_String (Name);
      Result : constant System.Address := Sys_Dlsym (Lib, Symbol);
   begin
      Interfaces.C.Strings.Free (Symbol);
      if Result = System.Null_Address then
         raise Not_Found with Error_Message;
      else
         return Result;
      end if;
   end Get_Symbol;

end Util.Systems.DLLs;

Add a pragma Linker_Options configured by utilgen in Util.Systems.Constants Fix compilation warnings


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

with AUnit.Test_Caller;
with AUnit.Assertions;
with Ada.Text_IO;
with ASF.Testsuite;
with AUnit.Assertions;
with ASF.Contexts.Facelets;
with ASF.Components.Util.Factory;
package body ASF.Views.Facelets.Tests is

   use AUnit.Assertions;
   use ASF.Testsuite;
   use ASF.Contexts.Facelets;

   --  Set up performed before each test case
   overriding
   procedure Set_Up (T : in out Test) is
   begin
      null;
   end Set_Up;

   --  Tear down performed after each test case
   overriding
   procedure Tear_Down (T : in out Test) is
   begin
      null;
   end Tear_Down;

   --  Test loading of facelet file
   procedure Test_Load_Facelet (T : in out Test) is
      Factory    : ASF.Views.Facelets.Facelet_Factory;
      Components : aliased ASF.Factory.Component_Factory;
      View       : ASF.Views.Facelets.Facelet;
      Ctx        : Facelet_Context;
   begin
      Initialize (Factory, Components'Unchecked_Access, "regtests/files/views;.", True, True, True);
      Find_Facelet (Factory, "text.xhtml", Ctx, View);

      T.Assert (Condition => not Is_Null (View),
                Message   => "Loading an existing facelet should return a view");
   end Test_Load_Facelet;

   --  Test loading of an unknown file
   procedure Test_Load_Unknown_Facelet (T : in out Test) is
      Factory    : ASF.Views.Facelets.Facelet_Factory;
      Components : aliased ASF.Factory.Component_Factory;
      View       : ASF.Views.Facelets.Facelet;
      Ctx        : Facelet_Context;
   begin
      Initialize (Factory, Components'Unchecked_Access, "regtests/files;.", True, True, True);
      Find_Facelet (Factory, "not-found-file.xhtml", Ctx, View);

      T.Assert (Condition => Is_Null (View),
                Message   => "Loading a missing facelet should not raise any exception");
   end Test_Load_Unknown_Facelet;

   package Caller is new AUnit.Test_Caller (Test);

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is

   begin
      --  To document what is tested, register the test methods for each
      --  operation that is tested.
      Suite.Add_Test (Caller.Create ("Test ASF.Views.Facelets.Find_Facelet",
        Test_Load_Facelet'Access));
      Suite.Add_Test (Caller.Create ("Test ASF.Views.Facelets.Find_Facelet",
        Test_Load_Unknown_Facelet'Access));
   end Add_Tests;

end ASF.Views.Facelets.Tests;

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

with AUnit.Test_Caller;
with AUnit.Assertions;
with Ada.Text_IO;
with ASF.Testsuite;
with AUnit.Assertions;
with ASF.Contexts.Facelets;
with ASF.Components.Utils.Factory;
with ASF.Applications.Main;
package body ASF.Views.Facelets.Tests is

   use AUnit.Assertions;
   use ASF.Testsuite;
   use ASF.Contexts.Facelets;

   type Facelet_Context is new ASF.Contexts.Facelets.Facelet_Context with null record;

   --  Get the application associated with this facelet context.
   overriding
   function Get_Application (Context : in Facelet_Context)
                             return access ASF.Applications.Main.Application'Class;

   --  Get the application associated with this facelet context.
   overriding
   function Get_Application (Context : in Facelet_Context)
                             return access ASF.Applications.Main.Application'Class is
   begin
      return null;
   end Get_Application;

   --  Set up performed before each test case
   overriding
   procedure Set_Up (T : in out Test) is
   begin
      null;
   end Set_Up;

   --  Tear down performed after each test case
   overriding
   procedure Tear_Down (T : in out Test) is
   begin
      null;
   end Tear_Down;

   --  Test loading of facelet file
   procedure Test_Load_Facelet (T : in out Test) is
      Factory    : ASF.Views.Facelets.Facelet_Factory;
      Components : aliased ASF.Factory.Component_Factory;
      View       : ASF.Views.Facelets.Facelet;
      Ctx        : Facelet_Context;
   begin
      Initialize (Factory, Components'Unchecked_Access, "regtests/files/views;.", True, True, True);
      Find_Facelet (Factory, "text.xhtml", Ctx, View);

      T.Assert (Condition => not Is_Null (View),
                Message   => "Loading an existing facelet should return a view");
   end Test_Load_Facelet;

   --  Test loading of an unknown file
   procedure Test_Load_Unknown_Facelet (T : in out Test) is
      Factory    : ASF.Views.Facelets.Facelet_Factory;
      Components : aliased ASF.Factory.Component_Factory;
      View       : ASF.Views.Facelets.Facelet;
      Ctx        : Facelet_Context;
   begin
      Initialize (Factory, Components'Unchecked_Access, "regtests/files;.", True, True, True);
      Find_Facelet (Factory, "not-found-file.xhtml", Ctx, View);

      T.Assert (Condition => Is_Null (View),
                Message   => "Loading a missing facelet should not raise any exception");
   end Test_Load_Unknown_Facelet;

   package Caller is new AUnit.Test_Caller (Test);

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is

   begin
      --  To document what is tested, register the test methods for each
      --  operation that is tested.
      Suite.Add_Test (Caller.Create ("Test ASF.Views.Facelets.Find_Facelet",
        Test_Load_Facelet'Access));
      Suite.Add_Test (Caller.Create ("Test ASF.Views.Facelets.Find_Facelet",
        Test_Load_Unknown_Facelet'Access));
   end Add_Tests;

end ASF.Views.Facelets.Tests;

Fix compilation of unit tests

Fix compilation of unit tests


-----------------------------------------------------------------------
--  el-contexts-tests - Tests the EL contexts
--  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.Test_Caller;

with Util.Properties;
with Util.Beans.Objects;

with EL.Expressions;
with EL.Contexts.Properties;
with EL.Contexts.Default;
package body EL.Contexts.Tests is

   use Util.Tests;

   package Caller is new Util.Test_Caller (Test);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test EL.Contexts.Properties.Get_Value",
                       Test_Context_Properties'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test Add_Parameter
   --  ------------------------------
   procedure Test_Context_Properties (T : in out Test) is

      function Eval (Item : in String) return String;

      Context       : EL.Contexts.Default.Default_Context;
      Prop_Resolver : aliased EL.Contexts.Properties.Property_Resolver;
      Props         : Util.Properties.Manager;

      function Eval (Item : in String) return String is
         Expr   : constant Expressions.Expression
           := EL.Expressions.Create_Expression (Item, Context);
         Result : constant Util.Beans.Objects.Object := Expr.Get_Value (Context);
      begin
         return Util.Beans.Objects.To_String (Result);
      end Eval;

   begin
      Props.Set ("user", "joe");
      Props.Set ("home", "/home/joe");
      Prop_Resolver.Set_Properties (Props);

      Context.Set_Resolver (Prop_Resolver'Unchecked_Access);

      Assert_Equals (T, "joe", Eval ("#{user}"), "Invalid evaluation of #{user}");
      Assert_Equals (T, "/home/joe", Eval ("#{home}"), "Invalid evaluation of #{home}");
   end Test_Context_Properties;

end EL.Contexts.Tests;

-----------------------------------------------------------------------
--  el-contexts-tests - Tests the EL contexts
--  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.Test_Caller;

with Util.Properties;
with Util.Beans.Objects;

with EL.Expressions;
with EL.Contexts.Properties;
with EL.Contexts.Default;
package body EL.Contexts.Tests is

   use Util.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test EL.Contexts.Properties.Get_Value",
                       Test_Context_Properties'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test Add_Parameter
   --  ------------------------------
   procedure Test_Context_Properties (T : in out Test) is

      function Eval (Item : in String) return String;

      Context       : EL.Contexts.Default.Default_Context;
      Prop_Resolver : aliased EL.Contexts.Properties.Property_Resolver;
      Props         : Util.Properties.Manager;

      function Eval (Item : in String) return String is
         Expr   : constant Expressions.Expression
           := EL.Expressions.Create_Expression (Item, Context);
         Result : constant Util.Beans.Objects.Object := Expr.Get_Value (Context);
      begin
         return Util.Beans.Objects.To_String (Result);
      end Eval;

   begin
      Props.Set ("user", "joe");
      Props.Set ("home", "/home/joe");
      Prop_Resolver.Set_Properties (Props);

      Context.Set_Resolver (Prop_Resolver'Unchecked_Access);

      Assert_Equals (T, "joe", Eval ("#{user}"), "Invalid evaluation of #{user}");
      Assert_Equals (T, "/home/joe", Eval ("#{home}"), "Invalid evaluation of #{home}");
   end Test_Context_Properties;

end EL.Contexts.Tests;

Use the test name EL.Contexts

Use the test name EL.Contexts


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

with Util.Concurrent.Counters;

with MAT.Frames;
package MAT.Events.Targets is

   Not_Found : exception;

   type Event_Type is mod 16;
   type Probe_Index_Type is (MSG_BEGIN,
                             MSG_END,
                             MSG_LIBRARY,
                             MSG_MALLOC,
                             MSG_FREE,
                             MSG_REALLOC
                             );

   type Event_Id_Type is new Natural;

   type Probe_Event_Type is record
      Id       : Event_Id_Type;
      Next_Id  : Event_Id_Type := 0;
      Prev_Id  : Event_Id_Type := 0;
      Event    : MAT.Types.Uint16;
      Index    : Probe_Index_Type;
      Time     : MAT.Types.Target_Tick_Ref;
      Thread   : MAT.Types.Target_Thread_Ref;
      Frame    : MAT.Frames.Frame_Type;
      Addr     : MAT.Types.Target_Addr;
      Size     : MAT.Types.Target_Size;
      Old_Addr : MAT.Types.Target_Addr;
      Old_Size : MAT.Types.Target_Size;
   end record;

   subtype Target_Event is Probe_Event_Type;

   package Target_Event_Vectors is
     new Ada.Containers.Vectors (Positive, Target_Event);

   subtype Target_Event_Vector is Target_Event_Vectors.Vector;
   subtype Target_Event_Cursor is Target_Event_Vectors.Cursor;

   --  Find in the list the first event with the given type.
   --  Raise <tt>Not_Found</tt> if the list does not contain such event.
   function Find (List : in Target_Event_Vector;
                  Kind : in Probe_Index_Type) return Probe_Event_Type;

   type Event_Info_Type is record
      First_Event : Target_Event;
      Last_Event  : Target_Event;
      Frame_Addr  : MAT.Types.Target_Addr;
      Count       : Natural;
   end record;

   package Size_Event_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Size,
                                      Element_Type => Event_Info_Type);
   subtype Size_Event_Info_Map is Size_Event_Info_Maps.Map;
   subtype Size_Event_Info_Cursor is Size_Event_Info_Maps.Cursor;

   package Frame_Event_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Addr,
                                      Element_Type => Event_Info_Type);
   subtype Frame_Event_Info_Map is Frame_Event_Info_Maps.Map;
   subtype Frame_Event_Info_Cursor is Frame_Event_Info_Maps.Cursor;

   package Event_Info_Vectors is
     new Ada.Containers.Vectors (Index_Type   => Positive,
                                 Element_Type => Event_Info_Type);
   subtype Event_Info_Vector is Event_Info_Vectors.Vector;
   subtype Event_Info_Cursor is Event_Info_Vectors.Cursor;

   --  Extract from the frame info map, the list of event info sorted on the count.
   procedure Build_Event_Info (Map : in Frame_Event_Info_Map;
                               List : in out Event_Info_Vector);

   type Target_Events is tagged limited private;
   type Target_Events_Access is access all Target_Events'Class;

   --  Add the event in the list of events and increment the event counter.
   procedure Insert (Target : in out Target_Events;
                     Event  : in Probe_Event_Type);

   procedure Get_Events (Target : in out Target_Events;
                         Start  : in MAT.Types.Target_Time;
                         Finish : in MAT.Types.Target_Time;
                         Into   : in out Target_Event_Vector);

   --  Get the start and finish time for the events that have been received.
   procedure Get_Time_Range (Target : in out Target_Events;
                             Start  : out MAT.Types.Target_Time;
                             Finish : out MAT.Types.Target_Time);

   --  Get the probe event with the given allocated unique id.
   function Get_Event (Target : in Target_Events;
                       Id     : in Event_Id_Type) return Probe_Event_Type;

   --  Get the first and last event that have been received.
   procedure Get_Limits (Target : in out Target_Events;
                         First  : out Probe_Event_Type;
                         Last   : out Probe_Event_Type);

   --  Get the current event counter.
   function Get_Event_Counter (Target : in Target_Events) return Integer;

   --  Iterate over the events starting from the <tt>Start</tt> event and until the
   --  <tt>Finish</tt> event is found (inclusive).  Execute the <tt>Process</tt> procedure
   --  with each event instance.
   procedure Iterate (Target  : in out Target_Events;
                      Start   : in Event_Id_Type;
                      Finish  : in Event_Id_Type;
                      Process : access procedure (Event : in Probe_Event_Type));

   --  Iterate over the events starting from first first event up to the last event collected.
   --  Execute the <tt>Process</tt> procedure with each event instance.
   procedure Iterate (Target  : in out Target_Events;
                      Process : access procedure (Event : in Target_Event));

private

   EVENT_BLOCK_SIZE : constant Event_Id_Type := 1024;

   type Probe_Event_Array is array (1 .. EVENT_BLOCK_SIZE) of Probe_Event_Type;

   type Event_Block is record
      Start  : MAT.Types.Target_Time;
      Finish : MAT.Types.Target_Time;
      Count  : Event_Id_Type := 0;
      Events : Probe_Event_Array;
   end record;
   type Event_Block_Access is access all Event_Block;

   use type MAT.Types.Target_Time;
   package Event_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Time,
                                      Element_Type => Event_Block_Access);

   subtype Event_Map is Event_Maps.Map;
   subtype Event_Cursor is Event_Maps.Cursor;

   package Event_Id_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => Event_Id_Type,
                                      Element_Type => Event_Block_Access);

   subtype Event_Id_Map is Event_Id_Maps.Map;
   subtype Event_Id_Cursor is Event_Id_Maps.Cursor;

   protected type Event_Collector is

      --  Add the event in the list of events.
      procedure Insert (Event  : in Probe_Event_Type);

      procedure Get_Events (Start  : in MAT.Types.Target_Time;
                            Finish : in MAT.Types.Target_Time;
                            Into   : in out Target_Event_Vector);

      --  Get the first and last event that have been received.
      procedure Get_Limits (First : out Probe_Event_Type;
                            Last  : out Probe_Event_Type);

      --  Get the start and finish time for the events that have been received.
      procedure Get_Time_Range (Start  : out MAT.Types.Target_Time;
                                Finish : out MAT.Types.Target_Time);

      --  Get the probe event with the given allocated unique id.
      function Get_Event (Id : in Event_Id_Type) return Probe_Event_Type;

      --  Iterate over the events starting from the <tt>Start</tt> event and until the
      --  <tt>Finish</tt> event is found (inclusive).  Execute the <tt>Process</tt> procedure
      --  with each event instance.
      procedure Iterate (Start   : in Event_Id_Type;
                         Finish  : in Event_Id_Type;
                         Process : access procedure (Event : in Probe_Event_Type));

      --  Clear the events.
      procedure Clear;

   private
      Current       : Event_Block_Access := null;
      Events        : Event_Map;
      Ids           : Event_Id_Map;
      Last_Id       : Event_Id_Type := 0;
   end Event_Collector;

   type Target_Events is new Ada.Finalization.Limited_Controlled with record
      Events      : Event_Collector;
      Event_Count : Util.Concurrent.Counters.Counter;
   end record;

   --  Release the storage allocated for the events.
   overriding
   procedure Finalize (Target : in out Target_Events);

end MAT.Events.Targets;

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

with Util.Concurrent.Counters;

with MAT.Frames;
package MAT.Events.Targets is

   Not_Found : exception;

   type Event_Type is mod 16;
   type Probe_Index_Type is (MSG_BEGIN,
                             MSG_END,
                             MSG_LIBRARY,
                             MSG_MALLOC,
                             MSG_FREE,
                             MSG_REALLOC
                             );

   type Event_Id_Type is new Natural;

   type Probe_Event_Type is record
      Id       : Event_Id_Type;
      Next_Id  : Event_Id_Type := 0;
      Prev_Id  : Event_Id_Type := 0;
      Event    : MAT.Types.Uint16;
      Index    : Probe_Index_Type;
      Time     : MAT.Types.Target_Tick_Ref;
      Thread   : MAT.Types.Target_Thread_Ref;
      Frame    : MAT.Frames.Frame_Type;
      Addr     : MAT.Types.Target_Addr;
      Size     : MAT.Types.Target_Size;
      Old_Addr : MAT.Types.Target_Addr;
      Old_Size : MAT.Types.Target_Size;
   end record;

   subtype Target_Event is Probe_Event_Type;

   package Target_Event_Vectors is
     new Ada.Containers.Vectors (Positive, Target_Event);

   subtype Target_Event_Vector is Target_Event_Vectors.Vector;
   subtype Target_Event_Cursor is Target_Event_Vectors.Cursor;

   --  Find in the list the first event with the given type.
   --  Raise <tt>Not_Found</tt> if the list does not contain such event.
   function Find (List : in Target_Event_Vector;
                  Kind : in Probe_Index_Type) return Probe_Event_Type;

   type Event_Info_Type is record
      First_Event : Target_Event;
      Last_Event  : Target_Event;
      Frame_Addr  : MAT.Types.Target_Addr;
      Count       : Natural;
   end record;

   package Size_Event_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Size,
                                      Element_Type => Event_Info_Type);
   subtype Size_Event_Info_Map is Size_Event_Info_Maps.Map;
   subtype Size_Event_Info_Cursor is Size_Event_Info_Maps.Cursor;

   package Frame_Event_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Addr,
                                      Element_Type => Event_Info_Type);
   subtype Frame_Event_Info_Map is Frame_Event_Info_Maps.Map;
   subtype Frame_Event_Info_Cursor is Frame_Event_Info_Maps.Cursor;

   package Event_Info_Vectors is
     new Ada.Containers.Vectors (Index_Type   => Positive,
                                 Element_Type => Event_Info_Type);
   subtype Event_Info_Vector is Event_Info_Vectors.Vector;
   subtype Event_Info_Cursor is Event_Info_Vectors.Cursor;

   --  Extract from the frame info map, the list of event info sorted on the count.
   procedure Build_Event_Info (Map : in Frame_Event_Info_Map;
                               List : in out Event_Info_Vector);

   type Target_Events is tagged limited private;
   type Target_Events_Access is access all Target_Events'Class;

   --  Add the event in the list of events and increment the event counter.
   procedure Insert (Target : in out Target_Events;
                     Event  : in Probe_Event_Type);

   procedure Get_Events (Target : in out Target_Events;
                         Start  : in MAT.Types.Target_Time;
                         Finish : in MAT.Types.Target_Time;
                         Into   : in out Target_Event_Vector);

   --  Get the start and finish time for the events that have been received.
   procedure Get_Time_Range (Target : in out Target_Events;
                             Start  : out MAT.Types.Target_Time;
                             Finish : out MAT.Types.Target_Time);

   --  Get the probe event with the given allocated unique id.
   function Get_Event (Target : in Target_Events;
                       Id     : in Event_Id_Type) return Probe_Event_Type;

   --  Get the first and last event that have been received.
   procedure Get_Limits (Target : in out Target_Events;
                         First  : out Probe_Event_Type;
                         Last   : out Probe_Event_Type);

   --  Get the current event counter.
   function Get_Event_Counter (Target : in Target_Events) return Integer;

   --  Iterate over the events starting from the <tt>Start</tt> event and until the
   --  <tt>Finish</tt> event is found (inclusive).  Execute the <tt>Process</tt> procedure
   --  with each event instance.
   procedure Iterate (Target  : in out Target_Events;
                      Start   : in Event_Id_Type;
                      Finish  : in Event_Id_Type;
                      Process : access procedure (Event : in Probe_Event_Type));

   --  Iterate over the events starting from first first event up to the last event collected.
   --  Execute the <tt>Process</tt> procedure with each event instance.
   procedure Iterate (Target  : in out Target_Events;
                      Process : access procedure (Event : in Target_Event));

private

   EVENT_BLOCK_SIZE : constant Event_Id_Type := 1024;

   type Probe_Event_Array is array (1 .. EVENT_BLOCK_SIZE) of Probe_Event_Type;

   type Event_Block is record
      Start  : MAT.Types.Target_Time;
      Finish : MAT.Types.Target_Time;
      Count  : Event_Id_Type := 0;
      Events : Probe_Event_Array;
   end record;
   type Event_Block_Access is access all Event_Block;

   use type MAT.Types.Target_Time;
   package Event_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Time,
                                      Element_Type => Event_Block_Access);

   subtype Event_Map is Event_Maps.Map;
   subtype Event_Cursor is Event_Maps.Cursor;

   package Event_Id_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => Event_Id_Type,
                                      Element_Type => Event_Block_Access);

   subtype Event_Id_Map is Event_Id_Maps.Map;
   subtype Event_Id_Cursor is Event_Id_Maps.Cursor;

   protected type Event_Collector is

      --  Update the Size and Prev_Id information in the event identified by <tt>Id</tt>.
      --  Update the event represented by <tt>Prev_Id</tt> so that its Next_Id refers
      --  to the <tt>Id</tt> event.
      procedure Update_Event (Id      : in Event_Id_Type;
                              Size    : in MAT.Types.Target_Size;
                              Prev_Id : in Event_Id_Type);

      --  Add the event in the list of events.
      procedure Insert (Event  : in Probe_Event_Type);

      procedure Get_Events (Start  : in MAT.Types.Target_Time;
                            Finish : in MAT.Types.Target_Time;
                            Into   : in out Target_Event_Vector);

      --  Get the first and last event that have been received.
      procedure Get_Limits (First : out Probe_Event_Type;
                            Last  : out Probe_Event_Type);

      --  Get the start and finish time for the events that have been received.
      procedure Get_Time_Range (Start  : out MAT.Types.Target_Time;
                                Finish : out MAT.Types.Target_Time);

      --  Get the probe event with the given allocated unique id.
      function Get_Event (Id : in Event_Id_Type) return Probe_Event_Type;

      --  Iterate over the events starting from the <tt>Start</tt> event and until the
      --  <tt>Finish</tt> event is found (inclusive).  Execute the <tt>Process</tt> procedure
      --  with each event instance.
      procedure Iterate (Start   : in Event_Id_Type;
                         Finish  : in Event_Id_Type;
                         Process : access procedure (Event : in Probe_Event_Type));

      --  Clear the events.
      procedure Clear;

   private
      Current       : Event_Block_Access := null;
      Events        : Event_Map;
      Ids           : Event_Id_Map;
      Last_Id       : Event_Id_Type := 0;
   end Event_Collector;

   type Target_Events is new Ada.Finalization.Limited_Controlled with record
      Events      : Event_Collector;
      Event_Count : Util.Concurrent.Counters.Counter;
   end record;

   --  Release the storage allocated for the events.
   overriding
   procedure Finalize (Target : in out Target_Events);

end MAT.Events.Targets;

Declare the Update_Event protected procedure


-----------------------------------------------------------------------
--  util-beans -- Interface Definition with Getter and Setters
--  Copyright (C) 2009, 2010, 2018 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.
-----------------------------------------------------------------------

--  = Ada Beans =
--  A [Java Bean](http://en.wikipedia.org/wiki/JavaBean) is an object that
--  allows to access its properties through getters and setters. Java Beans
--  rely on the use of Java introspection to discover the Java Bean object properties.
--
--  An Ada Bean has some similarities with the Java Bean as it tries to expose
--  an object through a set of common interfaces.  Since Ada does not have introspection,
--  some developer work is necessary. The Ada Bean framework consists of:
--
--    * An `Object` concrete type that allows to hold any data type such
--      as boolean, integer, floats, strings, dates and Ada bean objects.
--    * A `Bean` interface that exposes a `Get_Value` and `Set_Value`
--      operation through which the object properties can be obtained and modified.
--    * A `Method_Bean` interface that exposes a set of method bindings
--      that gives access to the methods provided by the Ada Bean object.
--
--  The benefit of Ada beans comes when you need to get a value or invoke
--  a method on an object but you don't know at compile time the object or method.
--  That step being done later through some external configuration or presentation file.
--
--  The Ada Bean framework is the basis for the implementation of
--  [Ada Server Faces](http://code.google.com/p/ada-asf/) and
--  [Ada EL](http://code.google.com/p/ada-el/).  It allows the presentation layer to
--  access information provided by Ada beans.
--
--  @include util-beans-objects.ads
--  @include util-beans-objects-datasets.ads
--  @include util-beans-basic.ads
package Util.Beans is

   pragma Preelaborate;

end Util.Beans;

-----------------------------------------------------------------------
--  util-beans -- Interface Definition with Getter and Setters
--  Copyright (C) 2009, 2010, 2018 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.
-----------------------------------------------------------------------

--  = Ada Beans =
--  A [Java Bean](http://en.wikipedia.org/wiki/JavaBean) is an object that
--  allows to access its properties through getters and setters. Java Beans
--  rely on the use of Java introspection to discover the Java Bean object properties.
--
--  An Ada Bean has some similarities with the Java Bean as it tries to expose
--  an object through a set of common interfaces.  Since Ada does not have introspection,
--  some developer work is necessary. The Ada Bean framework consists of:
--
--    * An `Object` concrete type that allows to hold any data type such
--      as boolean, integer, floats, strings, dates and Ada bean objects.
--    * A `Bean` interface that exposes a `Get_Value` and `Set_Value`
--      operation through which the object properties can be obtained and modified.
--    * A `Method_Bean` interface that exposes a set of method bindings
--      that gives access to the methods provided by the Ada Bean object.
--
--  The benefit of Ada beans comes when you need to get a value or invoke
--  a method on an object but you don't know at compile time the object or method.
--  That step being done later through some external configuration or presentation file.
--
--  The Ada Bean framework is the basis for the implementation of
--  Ada Server Faces and Ada EL.  It allows the presentation layer to
--  access information provided by Ada beans.
--
--  @include util-beans-objects.ads
--  @include util-beans-objects-datasets.ads
--  @include util-beans-basic.ads
package Util.Beans is

   pragma Preelaborate;

end Util.Beans;

Remove links since they are now automatically generated


-----------------------------------------------------------------------
--  ADO Sequences -- Database sequence generator
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 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.Exceptions;
with Ada.Calendar;

with ADO.Statements;
with ADO.Objects;
with ADO.Databases;
with ADO.Sessions;
with ADO.Utils;
with Regtests;

with Regtests.Simple.Model;
with Regtests.Images.Model;

with Util.Assertions;
with Util.Measures;
with Util.Log;
with Util.Log.Loggers;
with Util.Beans.Objects;
with Util.Test_Caller;

package body ADO.Tests is

   use Ada.Exceptions;
   use ADO.Statements;
   use type Regtests.Simple.Model.User_Ref;
   use type Regtests.Simple.Model.Allocate_Ref;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ADO.Tests");

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

   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence);

   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence) is
      Message : constant String := Exception_Message (E);
   begin
      Log.Info ("Exception: {0}", Message);
      T.Assert (Message'Length > 0,
                "Exception " & Exception_Name (E) & " does not have any message");
   end Assert_Has_Message;

   procedure Set_Up (T : in out Test) is
   begin
      null;
   end Set_Up;

   --  ------------------------------
   --  Check:
   --     Object_Ref.Load
   --     Object_Ref.Is_Null
   --  ------------------------------
   procedure Test_Load (T : in out Test) is

      DB  : ADO.Sessions.Session := Regtests.Get_Database;

      Object : Regtests.Simple.Model.User_Ref;
   begin
      T.Assert (Object.Is_Null, "Object_Ref.Is_Null: Empty object must be null");

      Object.Load (DB, -1);
      T.Assert (False, "Object_Ref.Load: Load must raise NOT_FOUND exception");

   exception
      when ADO.Objects.NOT_FOUND =>
         T.Assert (Object.Is_Null, "Object_Ref.Load: Must not change the object");
   end Test_Load;

   --  ------------------------------
   --  Check:
   --    Object_Ref.Load
   --    Object_Ref.Save
   --    <Model>.Set_xxx (Unbounded_String)
   --    <Model>.Create
   --  ------------------------------
   procedure Test_Create_Load (T : in out Test) is

      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      Object : Regtests.Simple.Model.User_Ref;
      Check  : Regtests.Simple.Model.User_Ref;
   begin
      --  Initialize and save an object
      Object.Set_Name ("A simple test name");
      Object.Save (DB);

      T.Assert (Object.Get_Id > 0, "Saving an object did not allocate an identifier");

      --  Load the object
      Check.Load (DB, Object.Get_Id);
      T.Assert (not Check.Is_Null, "Object_Ref.Load: Loading the object failed");
   end Test_Create_Load;

   --  ------------------------------
   --  Check:
   --    Various error checks on database connections
   --
   --    Master_Connection.Rollback
   --  ------------------------------
   procedure Test_Not_Open (T : in out Test) is
      DB : ADO.Sessions.Master_Session;
   begin
      begin
         DB.Rollback;
         T.Fail ("Master_Connection.Rollback should raise an exception");

      exception
         when E : ADO.Sessions.NOT_OPEN =>
            Assert_Has_Message (T, E);
      end;

      begin
         DB.Commit;
         T.Fail ("Master_Connection.Commit should raise an exception");

      exception
         when E : ADO.Sessions.NOT_OPEN =>
            Assert_Has_Message (T, E);
      end;

   end Test_Not_Open;

   --  ------------------------------
   --  Check id generation
   --  ------------------------------
   procedure Test_Allocate (T : in out Test) is
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Key    : ADO.Objects.Object_Key (Of_Type => ADO.Objects.KEY_INTEGER,
                                       Of_Class => Regtests.Simple.Model.ALLOCATE_TABLE);
      PrevId : Identifier := NO_IDENTIFIER;
      S      : Util.Measures.Stamp;
   begin
      for I in 1 .. 200 loop
         declare
            Obj : Regtests.Simple.Model.Allocate_Ref;
         begin
            Obj.Save (DB);
            Key := Obj.Get_Key;
            if PrevId /= NO_IDENTIFIER then
               T.Assert (Objects.Get_Value (Key) = PrevId + 1, "Invalid allocated identifier: "
                         & Objects.To_String (Key) & " previous=" & Identifier'Image (PrevId));
            end if;
            PrevId := Objects.Get_Value (Key);
         end;
      end loop;
      Util.Measures.Report (S, "Allocate 200 ids");
   end Test_Allocate;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --    Object.Find
   --    Object.Save (update)
   --  ------------------------------
   procedure Test_Create_Save (T : in out Test) is
      use ADO.Objects;
      use type ADO.Sessions.Connection_Status;

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Ref  : Regtests.Simple.Model.Allocate_Ref;
      Ref2 : Regtests.Simple.Model.Allocate_Ref;
   begin
      T.Assert (DB.Get_Status = ADO.Sessions.OPEN,
                "The database connection is open");

      Ref.Set_Name ("Testing the allocation");
      Ref.Save (DB);
      T.Assert (Ref.Get_Id > 0, "Object must have an id");

      Ref.Set_Name ("Testing the allocation: update");
      Ref.Save (DB);

      Ref2.Load (DB, Ref.Get_Id);

   end Test_Create_Save;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --  ------------------------------
   procedure Test_Perf_Create_Save (T : in out Test) is
      use ADO.Objects;

      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      S  : Util.Measures.Stamp;
   begin
      DB.Begin_Transaction;
      for I in 1 .. 1_000 loop
         declare
            Ref  : Regtests.Simple.Model.Allocate_Ref;
         begin
            Ref.Set_Name ("Testing the allocation");
            Ref.Save (DB);
            T.Assert (Ref.Get_Id > 0, "Object must have an id");
         end;
      end loop;
      DB.Commit;
      Util.Measures.Report (S, "Create 1000 rows");
   end Test_Perf_Create_Save;

   procedure Test_Delete_All (T : in out Test) is

      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Stmt : ADO.Statements.Delete_Statement
        := DB.Create_Statement (Regtests.Simple.Model.ALLOCATE_TABLE);
      Result : Natural;
   begin
      DB.Begin_Transaction;
      Stmt.Execute (Result);
      Log.Info ("Deleted {0} rows", Natural'Image (Result));
      DB.Commit;

      T.Assert (Result > 100, "Too few rows were deleted");
   end Test_Delete_All;

   --  ------------------------------
   --  Test string insert.
   --  ------------------------------
   procedure Test_String (T : in out Test) is
      use ADO.Objects;
      use Ada.Strings.Unbounded;

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      User : Regtests.Simple.Model.User_Ref;
      Usr2 : Regtests.Simple.Model.User_Ref;
      Name : Unbounded_String;
   begin
      for I in 1 .. 127 loop
         Append (Name, Character'Val (I));
      end loop;
      Append (Name, ' ');
      Append (Name, ' ');
      Append (Name, ' ');
      Append (Name, ' ');
      DB.Begin_Transaction;
      User.Set_Name (Name);
      User.Save (DB);
      DB.Commit;

      --  Check that we can load the image and the blob.
      Usr2.Load (DB, User.Get_Id);
      Util.Tests.Assert_Equals (T, To_String (Name), String '(Usr2.Get_Name),
                                "Invalid name inserted for user");
   end Test_String;

   --  ------------------------------
   --  Test blob insert.
   --  ------------------------------
   procedure Test_Blob (T : in out Test) is
      use ADO.Objects;
      use Ada.Streams;

      procedure Assert_Equals is
        new Util.Assertions.Assert_Equals_T (Ada.Streams.Stream_Element);

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Img  : Regtests.Images.Model.Image_Ref;
      Size : constant Natural := 100;
      Data : ADO.Blob_Ref := ADO.Create_Blob (Size);
      Img2 : Regtests.Images.Model.Image_Ref;
   begin
      for I in 1 .. Size loop
         Data.Value.Data (Ada.Streams.Stream_Element_Offset (I)) := Integer'Pos ((64 + I) mod 255);
      end loop;
      DB.Begin_Transaction;
      Img.Set_Image (Data);
      Img.Set_Create_Date (Ada.Calendar.Clock);
      Img.Save (DB);
      DB.Commit;

      --  Check that we can load the image and the blob.
      Img2.Load (DB, Img.Get_Id);
      T.Assert (Img2.Get_Image.Is_Null = False, "No image blob loaded");

      --  And verify that the blob data matches what we inserted.
      Util.Tests.Assert_Equals (T, Size, Integer (Img2.Get_Image.Value.Len),
                                "Invalid blob length");
      for I in 1 .. Data.Value.Len loop
         Assert_Equals (T, Data.Value.Data (I), Img2.Get_Image.Value.Data (I),
                        "Invalid blob content at " & Stream_Element_Offset'Image (I));
      end loop;

      --  Create a blob initialized with a file content.
      Data := ADO.Create_Blob ("Makefile");
      T.Assert (not Data.Is_Null, "Null blob returned by Create_Blob");
      T.Assert (Data.Value.Len > 100, "Blob length initialized from file is too small");

      declare
         Content : Ada.Streams.Stream_Element_Array (1 .. 10);
         Img3    : Regtests.Images.Model.Image_Ref;
      begin
         for I in Content'Range loop
            Content (I) := Ada.Streams.Stream_Element_Offset'Pos (I + 30);
         end loop;
         Data := ADO.Create_Blob (Content);
         T.Assert (not Data.Is_Null, "Null blob returned by Create_Blob (Stream_Element_Array)");
         T.Assert (Data.Value.Len = 10, "Blob length initialized from array is too small");

         DB.Begin_Transaction;
         Img3.Set_Image (Data);
         Img3.Set_Create_Date (Ada.Calendar.Clock);
         Img3.Save (DB);
         DB.Commit;

         --  Check that we can load the image and the blob.
         Img2.Load (DB, Img3.Get_Id);
         T.Assert (Img2.Get_Image.Is_Null = False, "No image blob loaded");

         Img2.Set_Image (ADO.Null_Blob);
         Img2.Save (DB);
         DB.Commit;
      end;
   end Test_Blob;

   --  ------------------------------
   --  Test the To_Object and To_Identifier operations.
   --  ------------------------------
   procedure Test_Identifier_To_Object (T : in out Test) is
      Val : Util.Beans.Objects.Object := ADO.Utils.To_Object (ADO.NO_IDENTIFIER);
   begin
      T.Assert (Util.Beans.Objects.Is_Null (Val),
                "To_Object must return null for ADO.NO_IDENTIFIER");
      T.Assert (ADO.Utils.To_Identifier (Val) = ADO.NO_IDENTIFIER,
                "To_Identifier must return ADO.NO_IDENTIFIER for null");
      Val := ADO.Utils.To_Object (1);
      T.Assert (not Util.Beans.Objects.Is_Null (Val),
                "To_Object must not return null for a valid Identifier");
      T.Assert (ADO.Utils.To_Identifier (Val) = 1,
                "To_Identifier must return the correct identifier");
   end Test_Identifier_To_Object;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Object_Ref.Load", Test_Load'Access);
      Caller.Add_Test (Suite, "Test Object_Ref.Save", Test_Create_Load'Access);
      Caller.Add_Test (Suite, "Test Master_Connection init error", Test_Not_Open'Access);
      Caller.Add_Test (Suite, "Test Sequences.Factory", Test_Allocate'Access);
      Caller.Add_Test (Suite, "Test Object_Ref.Save/Create/Update",
                       Test_Create_Save'Access);
      Caller.Add_Test (Suite, "Test Object_Ref.Create (DB Insert)",
                       Test_Perf_Create_Save'Access);
      Caller.Add_Test (Suite, "Test Statement.Delete_Statement (delete all)",
                       Test_Delete_All'Access);
      Caller.Add_Test (Suite, "Test insert string",
                       Test_String'Access);
      Caller.Add_Test (Suite, "Test insert blob",
                       Test_Blob'Access);
      Caller.Add_Test (Suite, "Test ADO.Utils.To_Object/To_Identifier",
                       Test_Identifier_To_Object'Access);
   end Add_Tests;

end ADO.Tests;

-----------------------------------------------------------------------
--  ADO Sequences -- Database sequence generator
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 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.Exceptions;
with Ada.Calendar;

with ADO.Statements;
with ADO.Objects;
with ADO.Sessions;
with ADO.Utils;
with Regtests;

with Regtests.Simple.Model;
with Regtests.Images.Model;

with Util.Assertions;
with Util.Measures;
with Util.Log;
with Util.Log.Loggers;
with Util.Beans.Objects;
with Util.Test_Caller;

package body ADO.Tests is

   use Ada.Exceptions;
   use ADO.Statements;
   use type Regtests.Simple.Model.User_Ref;
   use type Regtests.Simple.Model.Allocate_Ref;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ADO.Tests");

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

   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence);

   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence) is
      Message : constant String := Exception_Message (E);
   begin
      Log.Info ("Exception: {0}", Message);
      T.Assert (Message'Length > 0,
                "Exception " & Exception_Name (E) & " does not have any message");
   end Assert_Has_Message;

   procedure Set_Up (T : in out Test) is
   begin
      null;
   end Set_Up;

   --  ------------------------------
   --  Check:
   --     Object_Ref.Load
   --     Object_Ref.Is_Null
   --  ------------------------------
   procedure Test_Load (T : in out Test) is

      DB  : ADO.Sessions.Session := Regtests.Get_Database;

      Object : Regtests.Simple.Model.User_Ref;
   begin
      T.Assert (Object.Is_Null, "Object_Ref.Is_Null: Empty object must be null");

      Object.Load (DB, -1);
      T.Assert (False, "Object_Ref.Load: Load must raise NOT_FOUND exception");

   exception
      when ADO.Objects.NOT_FOUND =>
         T.Assert (Object.Is_Null, "Object_Ref.Load: Must not change the object");
   end Test_Load;

   --  ------------------------------
   --  Check:
   --    Object_Ref.Load
   --    Object_Ref.Save
   --    <Model>.Set_xxx (Unbounded_String)
   --    <Model>.Create
   --  ------------------------------
   procedure Test_Create_Load (T : in out Test) is

      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      Object : Regtests.Simple.Model.User_Ref;
      Check  : Regtests.Simple.Model.User_Ref;
   begin
      --  Initialize and save an object
      Object.Set_Name ("A simple test name");
      Object.Save (DB);

      T.Assert (Object.Get_Id > 0, "Saving an object did not allocate an identifier");

      --  Load the object
      Check.Load (DB, Object.Get_Id);
      T.Assert (not Check.Is_Null, "Object_Ref.Load: Loading the object failed");
   end Test_Create_Load;

   --  ------------------------------
   --  Check:
   --    Various error checks on database connections
   --
   --    Master_Connection.Rollback
   --  ------------------------------
   procedure Test_Not_Open (T : in out Test) is
      DB : ADO.Sessions.Master_Session;
   begin
      begin
         DB.Rollback;
         T.Fail ("Master_Connection.Rollback should raise an exception");

      exception
         when E : ADO.Sessions.NOT_OPEN =>
            Assert_Has_Message (T, E);
      end;

      begin
         DB.Commit;
         T.Fail ("Master_Connection.Commit should raise an exception");

      exception
         when E : ADO.Sessions.NOT_OPEN =>
            Assert_Has_Message (T, E);
      end;

   end Test_Not_Open;

   --  ------------------------------
   --  Check id generation
   --  ------------------------------
   procedure Test_Allocate (T : in out Test) is
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Key    : ADO.Objects.Object_Key (Of_Type => ADO.Objects.KEY_INTEGER,
                                       Of_Class => Regtests.Simple.Model.ALLOCATE_TABLE);
      PrevId : Identifier := NO_IDENTIFIER;
      S      : Util.Measures.Stamp;
   begin
      for I in 1 .. 200 loop
         declare
            Obj : Regtests.Simple.Model.Allocate_Ref;
         begin
            Obj.Save (DB);
            Key := Obj.Get_Key;
            if PrevId /= NO_IDENTIFIER then
               T.Assert (Objects.Get_Value (Key) = PrevId + 1, "Invalid allocated identifier: "
                         & Objects.To_String (Key) & " previous=" & Identifier'Image (PrevId));
            end if;
            PrevId := Objects.Get_Value (Key);
         end;
      end loop;
      Util.Measures.Report (S, "Allocate 200 ids");
   end Test_Allocate;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --    Object.Find
   --    Object.Save (update)
   --  ------------------------------
   procedure Test_Create_Save (T : in out Test) is
      use ADO.Objects;
      use type ADO.Sessions.Connection_Status;

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Ref  : Regtests.Simple.Model.Allocate_Ref;
      Ref2 : Regtests.Simple.Model.Allocate_Ref;
   begin
      T.Assert (DB.Get_Status = ADO.Sessions.OPEN,
                "The database connection is open");

      Ref.Set_Name ("Testing the allocation");
      Ref.Save (DB);
      T.Assert (Ref.Get_Id > 0, "Object must have an id");

      Ref.Set_Name ("Testing the allocation: update");
      Ref.Save (DB);

      Ref2.Load (DB, Ref.Get_Id);

   end Test_Create_Save;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --  ------------------------------
   procedure Test_Perf_Create_Save (T : in out Test) is
      use ADO.Objects;

      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      S  : Util.Measures.Stamp;
   begin
      DB.Begin_Transaction;
      for I in 1 .. 1_000 loop
         declare
            Ref  : Regtests.Simple.Model.Allocate_Ref;
         begin
            Ref.Set_Name ("Testing the allocation");
            Ref.Save (DB);
            T.Assert (Ref.Get_Id > 0, "Object must have an id");
         end;
      end loop;
      DB.Commit;
      Util.Measures.Report (S, "Create 1000 rows");
   end Test_Perf_Create_Save;

   procedure Test_Delete_All (T : in out Test) is

      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Stmt : ADO.Statements.Delete_Statement
        := DB.Create_Statement (Regtests.Simple.Model.ALLOCATE_TABLE);
      Result : Natural;
   begin
      DB.Begin_Transaction;
      Stmt.Execute (Result);
      Log.Info ("Deleted {0} rows", Natural'Image (Result));
      DB.Commit;

      T.Assert (Result > 100, "Too few rows were deleted");
   end Test_Delete_All;

   --  ------------------------------
   --  Test string insert.
   --  ------------------------------
   procedure Test_String (T : in out Test) is
      use ADO.Objects;
      use Ada.Strings.Unbounded;

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      User : Regtests.Simple.Model.User_Ref;
      Usr2 : Regtests.Simple.Model.User_Ref;
      Name : Unbounded_String;
   begin
      for I in 1 .. 127 loop
         Append (Name, Character'Val (I));
      end loop;
      Append (Name, ' ');
      Append (Name, ' ');
      Append (Name, ' ');
      Append (Name, ' ');
      DB.Begin_Transaction;
      User.Set_Name (Name);
      User.Save (DB);
      DB.Commit;

      --  Check that we can load the image and the blob.
      Usr2.Load (DB, User.Get_Id);
      Util.Tests.Assert_Equals (T, To_String (Name), String '(Usr2.Get_Name),
                                "Invalid name inserted for user");
   end Test_String;

   --  ------------------------------
   --  Test blob insert.
   --  ------------------------------
   procedure Test_Blob (T : in out Test) is
      use ADO.Objects;
      use Ada.Streams;

      procedure Assert_Equals is
        new Util.Assertions.Assert_Equals_T (Ada.Streams.Stream_Element);

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Img  : Regtests.Images.Model.Image_Ref;
      Size : constant Natural := 100;
      Data : ADO.Blob_Ref := ADO.Create_Blob (Size);
      Img2 : Regtests.Images.Model.Image_Ref;
   begin
      for I in 1 .. Size loop
         Data.Value.Data (Ada.Streams.Stream_Element_Offset (I)) := Integer'Pos ((64 + I) mod 255);
      end loop;
      DB.Begin_Transaction;
      Img.Set_Image (Data);
      Img.Set_Create_Date (Ada.Calendar.Clock);
      Img.Save (DB);
      DB.Commit;

      --  Check that we can load the image and the blob.
      Img2.Load (DB, Img.Get_Id);
      T.Assert (Img2.Get_Image.Is_Null = False, "No image blob loaded");

      --  And verify that the blob data matches what we inserted.
      Util.Tests.Assert_Equals (T, Size, Integer (Img2.Get_Image.Value.Len),
                                "Invalid blob length");
      for I in 1 .. Data.Value.Len loop
         Assert_Equals (T, Data.Value.Data (I), Img2.Get_Image.Value.Data (I),
                        "Invalid blob content at " & Stream_Element_Offset'Image (I));
      end loop;

      --  Create a blob initialized with a file content.
      Data := ADO.Create_Blob ("Makefile");
      T.Assert (not Data.Is_Null, "Null blob returned by Create_Blob");
      T.Assert (Data.Value.Len > 100, "Blob length initialized from file is too small");

      declare
         Content : Ada.Streams.Stream_Element_Array (1 .. 10);
         Img3    : Regtests.Images.Model.Image_Ref;
      begin
         for I in Content'Range loop
            Content (I) := Ada.Streams.Stream_Element_Offset'Pos (I + 30);
         end loop;
         Data := ADO.Create_Blob (Content);
         T.Assert (not Data.Is_Null, "Null blob returned by Create_Blob (Stream_Element_Array)");
         T.Assert (Data.Value.Len = 10, "Blob length initialized from array is too small");

         DB.Begin_Transaction;
         Img3.Set_Image (Data);
         Img3.Set_Create_Date (Ada.Calendar.Clock);
         Img3.Save (DB);
         DB.Commit;

         --  Check that we can load the image and the blob.
         Img2.Load (DB, Img3.Get_Id);
         T.Assert (Img2.Get_Image.Is_Null = False, "No image blob loaded");

         Img2.Set_Image (ADO.Null_Blob);
         Img2.Save (DB);
         DB.Commit;
      end;
   end Test_Blob;

   --  ------------------------------
   --  Test the To_Object and To_Identifier operations.
   --  ------------------------------
   procedure Test_Identifier_To_Object (T : in out Test) is
      Val : Util.Beans.Objects.Object := ADO.Utils.To_Object (ADO.NO_IDENTIFIER);
   begin
      T.Assert (Util.Beans.Objects.Is_Null (Val),
                "To_Object must return null for ADO.NO_IDENTIFIER");
      T.Assert (ADO.Utils.To_Identifier (Val) = ADO.NO_IDENTIFIER,
                "To_Identifier must return ADO.NO_IDENTIFIER for null");
      Val := ADO.Utils.To_Object (1);
      T.Assert (not Util.Beans.Objects.Is_Null (Val),
                "To_Object must not return null for a valid Identifier");
      T.Assert (ADO.Utils.To_Identifier (Val) = 1,
                "To_Identifier must return the correct identifier");
   end Test_Identifier_To_Object;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Object_Ref.Load", Test_Load'Access);
      Caller.Add_Test (Suite, "Test Object_Ref.Save", Test_Create_Load'Access);
      Caller.Add_Test (Suite, "Test Master_Connection init error", Test_Not_Open'Access);
      Caller.Add_Test (Suite, "Test Sequences.Factory", Test_Allocate'Access);
      Caller.Add_Test (Suite, "Test Object_Ref.Save/Create/Update",
                       Test_Create_Save'Access);
      Caller.Add_Test (Suite, "Test Object_Ref.Create (DB Insert)",
                       Test_Perf_Create_Save'Access);
      Caller.Add_Test (Suite, "Test Statement.Delete_Statement (delete all)",
                       Test_Delete_All'Access);
      Caller.Add_Test (Suite, "Test insert string",
                       Test_String'Access);
      Caller.Add_Test (Suite, "Test insert blob",
                       Test_Blob'Access);
      Caller.Add_Test (Suite, "Test ADO.Utils.To_Object/To_Identifier",
                       Test_Identifier_To_Object'Access);
   end Add_Tests;

end ADO.Tests;

Update the unit test

Update the unit test


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

   pragma Preelaborate;

   type Node_Kind is (N_LINE_BREAK,
                      N_HORIZONTAL_RULE,
                      N_TOC_DISPLAY,
                      N_PARAGRAPH,
                      N_NEWLINE,
                      N_HEADER,
                      N_TOC,
                      N_TOC_ENTRY,
                      N_BLOCKQUOTE,
                      N_QUOTE,
                      N_TAG_START,
                      N_PREFORMAT,
                      N_TABLE,
                      N_ROW,
                      N_COLUMN,
                      N_LIST,
                      N_NUM_LIST,
                      N_INDENT,
                      N_TEXT,
                      N_LINK,
                      N_IMAGE);

   --  Node kinds which are simple markers in the document.
   subtype Simple_Node_Kind is Node_Kind range N_LINE_BREAK .. N_NEWLINE;

   type Node_List is limited private;
   type Node_List_Access is access all Node_List;

   type Node_Type;
   type Node_Type_Access is access all Node_Type;

   type Node_Type (Kind : Node_Kind; Len : Natural) is limited record
      Parent     : Node_Type_Access;
      case Kind is
         when N_HEADER | N_BLOCKQUOTE | N_INDENT | N_LIST | N_NUM_LIST | N_TOC_ENTRY =>
            Level  : Natural := 0;
            Header : Wiki.Strings.WString (1 .. Len);

         when N_TEXT =>
            Format : Format_Map;
            Text   : Wiki.Strings.WString (1 .. Len);

         when N_LINK | N_IMAGE | N_QUOTE =>
            Link_Attr  : Wiki.Attributes.Attribute_List;
            Title      : Wiki.Strings.WString (1 .. Len);

         when N_TAG_START | N_TABLE | N_ROW | N_COLUMN =>
            Tag_Start  : Html_Tag;
            Attributes : Wiki.Attributes.Attribute_List;
            Children   : Node_List_Access;

         when N_PREFORMAT =>
            Language     : Wiki.Strings.UString;
            Preformatted : Wiki.Strings.WString (1 .. Len);

         when N_TOC =>
            Entries    : Node_List_Access;

         when others =>
            null;

      end case;
   end record;

   --  Append a node to the tag node.
   procedure Append (Into : in Node_Type_Access;
                     Node : in Node_Type_Access);

   --  Append a node to the document.
   procedure Append (Into : in out Node_List;
                     Node : in Node_Type_Access);

   --  Finalize the node list to release the allocated memory.
   procedure Finalize (List : in out Node_List);

private

   NODE_LIST_BLOCK_SIZE : constant Positive := 16;

   type Node_Array is array (Positive range <>) of Node_Type_Access;

   type Node_List_Block;
   type Node_List_Block_Access is access all Node_List_Block;

   type Node_List_Block (Max : Positive) is limited record
      Next  : Node_List_Block_Access;
      Last  : Natural := 0;
      List  : Node_Array (1 .. Max);
   end record;

   type Node_List is limited record
      Current : Node_List_Block_Access;
      Length  : Natural := 0;
      First   : aliased Node_List_Block (NODE_LIST_BLOCK_SIZE);
   end record;

end Wiki.Nodes;

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

   pragma Preelaborate;

   type Node_Kind is (N_NONE,
                      N_LINE_BREAK,
                      N_HORIZONTAL_RULE,
                      N_TOC_DISPLAY,
                      N_PARAGRAPH,
                      N_LIST_ITEM_END,
                      N_LIST_END,
                      N_NUM_LIST_END,
                      N_LIST_ITEM,
                      N_NEWLINE,
                      N_HEADER,
                      N_TOC,
                      N_TOC_ENTRY,
                      N_BLOCKQUOTE,
                      N_QUOTE,
                      N_TAG_START,
                      N_PREFORMAT,
                      N_TABLE,
                      N_ROW,
                      N_COLUMN,
                      N_LIST_START,
                      N_NUM_LIST_START,
                      N_INDENT,
                      N_TEXT,
                      N_LINK,
                      N_IMAGE);

   --  Node kinds which are simple markers in the document.
   subtype Simple_Node_Kind is Node_Kind range N_NONE .. N_NEWLINE;

   type Node_List is limited private;
   type Node_List_Access is access all Node_List;

   type Node_Type;
   type Node_Type_Access is access all Node_Type;

   type Node_Type (Kind : Node_Kind; Len : Natural) is limited record
      Parent     : Node_Type_Access;
      case Kind is
         when N_HEADER | N_BLOCKQUOTE | N_INDENT | N_TOC_ENTRY
            | N_NUM_LIST_START | N_LIST_START =>
            Level  : Natural := 0;
            Header : Wiki.Strings.WString (1 .. Len);

         when N_TEXT =>
            Format : Format_Map;
            Text   : Wiki.Strings.WString (1 .. Len);

         when N_LINK | N_IMAGE | N_QUOTE =>
            Link_Attr  : Wiki.Attributes.Attribute_List;
            Title      : Wiki.Strings.WString (1 .. Len);

         when N_TAG_START | N_TABLE | N_ROW | N_COLUMN =>
            Tag_Start  : Html_Tag;
            Attributes : Wiki.Attributes.Attribute_List;
            Children   : Node_List_Access;

         when N_PREFORMAT =>
            Language     : Wiki.Strings.UString;
            Preformatted : Wiki.Strings.WString (1 .. Len);

         when N_TOC =>
            Entries    : Node_List_Access;

         when others =>
            null;

      end case;
   end record;

   --  Append a node to the tag node.
   procedure Append (Into : in Node_Type_Access;
                     Node : in Node_Type_Access);

   --  Append a node to the document.
   procedure Append (Into : in out Node_List;
                     Node : in Node_Type_Access);

   --  Finalize the node list to release the allocated memory.
   procedure Finalize (List : in out Node_List);

private

   NODE_LIST_BLOCK_SIZE : constant Positive := 16;

   type Node_Array is array (Positive range <>) of Node_Type_Access;

   type Node_List_Block;
   type Node_List_Block_Access is access all Node_List_Block;

   type Node_List_Block (Max : Positive) is limited record
      Next  : Node_List_Block_Access;
      Last  : Natural := 0;
      List  : Node_Array (1 .. Max);
   end record;

   type Node_List is limited record
      Current : Node_List_Block_Access;
      Length  : Natural := 0;
      First   : aliased Node_List_Block (NODE_LIST_BLOCK_SIZE);
   end record;

end Wiki.Nodes;

Change the list representation to better identify the start and end of list and list items


with ada.text_io;   use ada.text_io;
-- Simple Lumen demo/test program to illustrate how to display text, using the
-- texture-mapped font facility.

with Ada.Characters.Latin_1;
with Ada.Command_Line;
with Ada.Strings.Fixed;
with Ada.Float_Text_IO;

with Lumen.Events.Animate;
with Lumen.Window;

with Lumen.Font.Txf;
with Lumen.GL;
with Lumen.GLU;

use Lumen;

procedure Text2 is

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

   -- Rotation wraps around at this point, in degrees
   Max_Rotation      : constant := 359;

   -- Nice peppy game-style framerate, in frames per second
   Framerate         : constant := 60;

   -- A font to fall back on
   Default_Font_Path : constant String := "fsb.txf";

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

   Win      : Window.Handle;
   Direct   : Boolean := True;  -- want direct rendering by default
   Event    : Events.Event_Data;
   Wide     : Natural := 400;
   High     : Natural := 400;
   Img_Wide : Float;
   Img_High : Float;
   Rotation : Natural := 0;
   Tx_Font  : Font.Txf.Handle;
   Object   : GL.UInt;
   Frame    : Natural := 0;

   Attrs    : Window.Context_Attributes :=
      (
       (Window.Attr_Red_Size,    8),
       (Window.Attr_Green_Size,  8),
       (Window.Attr_Blue_Size,   8),
       (Window.Attr_Alpha_Size,  8),
       (Window.Attr_Depth_Size, 24)
      );

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

   Program_Error : exception;
   Program_Exit  : exception;

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

   -- Return number blank-padded on the left out to Width; returns full
   -- number if it's wider than Width.
   function Img (Number : in Integer;
                 Width  : in Positive := 1) return String is

      use Ada.Strings.Fixed;

      Image : String := Trim (Integer'Image (Number), Side => Ada.Strings.Left);

   begin  -- Img
      if Image'Length >= Width then
         return Image;
      else
         return ((Width - Image'Length) * ' ') & Image;
      end if;
   end Img;

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

   -- Set or reset the window view parameters
   procedure Set_View (W, H : in Natural) is

      Aspect : GL.Double;

   begin  -- Set_View

      -- Viewport dimensions
      GL.Viewport (0, 0, GL.SizeI (W), GL.SizeI (H));

      -- Size of rectangle upon which text is displayed
      if Wide > High then
         Img_Wide := 1.0;
         Img_High := Float (High) / Float (Wide);
      else
         Img_Wide := Float (Wide) / Float (High);
         Img_High := 1.0;
      end if;

      -- Set up the projection matrix based on the window's shape--wider than
      -- high, or higher than wide
      GL.MatrixMode (GL.GL_PROJECTION);
      GL.LoadIdentity;

      -- Set up a 3D viewing frustum, which is basically a truncated pyramid
      -- in which the scene takes place.  Roughly, the narrow end is your
      -- screen, and the wide end is 10 units away from the camera.
      if W <= H then
         Aspect := GL.Double (H) / GL.Double (W);
         GL.Frustum (-1.0, 1.0, -Aspect, Aspect, 2.0, 10.0);
      else
         Aspect := GL.Double (W) / GL.Double (H);
         GL.Frustum (-Aspect, Aspect, -1.0, 1.0, 2.0, 10.0);
      end if;

   end Set_View;

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

   -- Draw our scene
   procedure Draw is

      use type GL.Bitfield;

      MW    : Natural;
      MA    : Natural;
      MD    : Natural;
      Scale : Float;
      Pad   : Float := Img_Wide / 10.0;

      FNum  : String := Img (Frame, 6);
      FRate : String (1 .. 6);

   begin  -- Draw

      -- Set an off-white background
      GL.ClearColor (0.85, 0.85, 0.85, 0.0);
      GL.Clear (GL.GL_COLOR_BUFFER_BIT or GL.GL_DEPTH_BUFFER_BIT);

      -- Draw a black square
      GL.Disable (GL.GL_TEXTURE_2D);
      GL.Disable (GL.GL_BLEND);
      GL.Disable (GL.GL_ALPHA_TEST);

      GL.Color (Float (0.0), 0.0, 0.0);
      GL.glBegin (GL.GL_POLYGON);
      begin
         GL.Vertex (-Img_Wide, -Img_High, 0.0);
         GL.Vertex (-Img_Wide,  Img_High, 0.0);
         GL.Vertex ( Img_Wide,  Img_High, 0.0);
         GL.Vertex ( Img_Wide, -Img_High, 0.0);
      end;
      GL.glEnd;

      -- Set up to draw the text messages
      GL.PushMatrix;
      GL.Enable (GL.GL_TEXTURE_2D);
      GL.Enable (GL.GL_ALPHA_TEST);
      GL.AlphaFunc (GL.GL_GEQUAL, 0.0625);
      GL.Enable (GL.GL_BLEND);
      GL.BlendFunc (GL.GL_SRC_ALPHA, GL.GL_ONE_MINUS_SRC_ALPHA);
      GL.Enable (GL.GL_POLYGON_OFFSET_FILL);
      GL.PolygonOffset (0.0, -3.0);
      GL.Color (Float (0.1), 0.8, 0.1);

      -- Draw the frame number, right-justified in upper half of rectangle
      GL.PushMatrix;
      Font.Txf.Get_String_Metrics (Tx_Font, FNum, MW, MA, MD);
      Scale := Img_High / (Float (MA) * 3.0);
      GL.Translate (Img_Wide - (Pad + Float (MW) * Scale), Float (MA) * Scale, 0.0);
      GL.Scale (Scale, Scale, Scale);
      Font.Txf.Render (Tx_Font, FNum);
      GL.PopMatrix;

      -- Draw the frame rate, right-justified in lowe half of rectangle
      GL.PushMatrix;
      begin
         Ada.Float_Text_IO.Put (FRate, Events.Animate.FPS (Win), Aft => 3, Exp => 0);

      exception
         when others =>
            FRate := (others => '?');
      end;
      Font.Txf.Get_String_Metrics (Tx_Font, FRate, MW, MA, MD);
      GL.Translate (Img_Wide - (Pad + Float (MW) * Scale), -Float (MA) * Scale, 0.0);
      GL.Scale (Scale, Scale, Scale);
      Font.Txf.Render (Tx_Font, FRate);
      GL.PopMatrix;

      GL.PopMatrix;

      -- Rotate the object around the Y and Z axes by the current amount, to
      -- give a "tumbling" effect.
      GL.MatrixMode (GL.GL_MODELVIEW);
      GL.LoadIdentity;
      GL.Translate (GL.Double (0.0), 0.0, -4.0);
      GL.Rotate (GL.Double (Rotation), 0.0, 1.0, 0.0);
      GL.Rotate (GL.Double (Rotation), 0.0, 0.0, 1.0);

      -- Now show it
      Window.Swap (Win);

   end Draw;

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

   -- Simple event handler routine for close-window events
   procedure Quit_Handler (Event : in Events.Event_Data) is
   begin  -- Quit_Handler
      raise Program_Exit;
   end Quit_Handler;

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

   -- Simple event handler routine for keypresses
   procedure Key_Handler (Event : in Events.Event_Data) is

      use type Events.Key_Symbol;

   begin  -- Key_Handler
      if Event.Key_Data.Key = Events.To_Symbol (Ada.Characters.Latin_1.ESC) or
         Event.Key_Data.Key = Events.To_Symbol ('q') then
         raise Program_Exit;
      end if;
   end Key_Handler;

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

   -- Simple event handler routine for Exposed events
   procedure Expose_Handler (Event : in Events.Event_Data) is
   begin  -- Expose_Handler
      Draw;
   end Expose_Handler;

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

   -- Simple event handler routine for Resized events
   procedure Resize_Handler (Event : in Events.Event_Data) is
   begin  -- Resize_Handler
      Wide := Event.Resize_Data.Width;
      High := Event.Resize_Data.Height;
      Set_View (Wide, High);
      Draw;
   end Resize_Handler;

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

   -- Our draw-a-frame routine, should get called FPS times a second
   procedure New_Frame (Frame_Delta : in Duration) is
   begin  -- New_Frame
      if Rotation >= Max_Rotation then
         Rotation := 0;
      else
         Rotation := Rotation + 1;
      end if;

      Frame := Frame + 1;

      Draw;
   end New_Frame;

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

begin  -- Text2

   -- Load the font we'll be using
   if Ada.Command_Line.Argument_Count > 0 then
      declare
         Font_Path : String := Ada.Command_Line.Argument (1);
      begin
         Font.Txf.Load (Tx_Font, Font_Path);

      exception
         when others =>
            raise Program_Error with "cannot find font file """ & Font_Path & """";
      end;
   else
      begin
         Font.Txf.Load (Tx_Font, Default_Font_Path);
      exception
         when others =>
            begin
               Font.Txf.Load (Tx_Font, "demo/" & Default_Font_Path);
            exception
               when others =>
                  raise Program_Error with "cannot find default font file """ & Default_Font_Path & """";
            end;
      end;
   end if;

   -- If other command-line arguments were given then process them
   for Index in 2 .. Ada.Command_Line.Argument_Count loop

      declare
         use Window;
         Arg : String := Ada.Command_Line.Argument (Index);
      begin
         case Arg (Arg'First) is

            when 'a' =>
               Attrs (4) := (Attr_Alpha_Size, Integer'Value (Arg (Arg'First + 1 .. Arg'Last)));

            when 'c' =>
               Attrs (1) := (Attr_Red_Size,   Integer'Value (Arg (Arg'First + 1 .. Arg'Last)));
               Attrs (2) := (Attr_Blue_Size,  Integer'Value (Arg (Arg'First + 1 .. Arg'Last)));
               Attrs (3) := (Attr_Green_Size, Integer'Value (Arg (Arg'First + 1 .. Arg'Last)));

            when 'd' =>
               Attrs (5) := (Attr_Depth_Size, Integer'Value (Arg (Arg'First + 1 .. Arg'Last)));

            when 'n' =>
               Direct := False;

            when others =>
               null;

         end case;
      end;

   end loop;

   -- Create Lumen window, accepting most defaults; turn double buffering off
   -- for simplicity
   Window.Create (Win,
                  Name       => "Text Demo #2, Revenge of the Text",
                  Width      => Wide,
                  Height     => High,
                  Direct     => Direct,
                  Attributes => Attrs,
                  Events     => (Window.Want_Key_Press => True,
                                 Window.Want_Exposure  => True,
                                 others => False));

   -- Set up the viewport and scene parameters
   Set_View (Wide, High);
   Object := Font.Txf.Establish_Texture (Tx_Font, 0, True);

   -- Enter the event loop
   declare
      use Events;
   begin
      Animate.Select_Events (Win   => Win,
                             Calls => (Key_Press    => Key_Handler'Unrestricted_Access,
                                       Exposed      => Expose_Handler'Unrestricted_Access,
                                       Resized      => Resize_Handler'Unrestricted_Access,
                                       Close_Window => Quit_Handler'Unrestricted_Access,
                                       others       => No_Callback),
                             FPS   => Framerate,
                             Frame => New_Frame'Unrestricted_Access);
   end;

exception
   when Program_Exit =>
      null;  -- just exit this block, which terminates the app

end Text2;

with ada.text_io;   use ada.text_io;
-- Simple Lumen demo/test program to illustrate how to display text, using the
-- texture-mapped font facility.

with Ada.Characters.Latin_1;
with Ada.Command_Line;
with Ada.Strings.Fixed;
with Ada.Float_Text_IO;

with Lumen.Events.Animate;
with Lumen.Window;

with Lumen.Font.Txf;
with Lumen.GL;
with Lumen.GLU;

use Lumen;

procedure Text2 is

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

   -- Rotation wraps around at this point, in degrees
   Max_Rotation      : constant := 359;

   -- Nice peppy game-style framerate, in frames per second
   Framerate         : constant := 60;

   -- A font to fall back on
   Default_Font_Path : constant String := "fsb.txf";

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

   Win      : Window.Handle;
   Direct   : Boolean := True;  -- want direct rendering by default
   Event    : Events.Event_Data;
   Wide     : Natural := 400;
   High     : Natural := 400;
   Img_Wide : Float;
   Img_High : Float;
   Rotation : Natural := 0;
   Rotating : Boolean := True;
   Tx_Font  : Font.Txf.Handle;
   Object   : GL.UInt;
   Frame    : Natural := 0;

   Attrs    : Window.Context_Attributes :=
      (
       (Window.Attr_Red_Size,    8),
       (Window.Attr_Green_Size,  8),
       (Window.Attr_Blue_Size,   8),
       (Window.Attr_Alpha_Size,  8),
       (Window.Attr_Depth_Size, 24)
      );

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

   Program_Error : exception;
   Program_Exit  : exception;

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

   -- Return number blank-padded on the left out to Width; returns full
   -- number if it's wider than Width.
   function Img (Number : in Integer;
                 Width  : in Positive := 1) return String is

      use Ada.Strings.Fixed;

      Image : String := Trim (Integer'Image (Number), Side => Ada.Strings.Left);

   begin  -- Img
      if Image'Length >= Width then
         return Image;
      else
         return ((Width - Image'Length) * ' ') & Image;
      end if;
   end Img;

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

   -- Set or reset the window view parameters
   procedure Set_View (W, H : in Natural) is

      Aspect : GL.Double;

   begin  -- Set_View

      -- Viewport dimensions
      GL.Viewport (0, 0, GL.SizeI (W), GL.SizeI (H));

      -- Size of rectangle upon which text is displayed
      if Wide > High then
         Img_Wide := 1.0;
         Img_High := Float (High) / Float (Wide);
      else
         Img_Wide := Float (Wide) / Float (High);
         Img_High := 1.0;
      end if;

      -- Set up the projection matrix based on the window's shape--wider than
      -- high, or higher than wide
      GL.MatrixMode (GL.GL_PROJECTION);
      GL.LoadIdentity;

      -- Set up a 3D viewing frustum, which is basically a truncated pyramid
      -- in which the scene takes place.  Roughly, the narrow end is your
      -- screen, and the wide end is 10 units away from the camera.
      if W <= H then
         Aspect := GL.Double (H) / GL.Double (W);
         GL.Frustum (-1.0, 1.0, -Aspect, Aspect, 2.0, 10.0);
      else
         Aspect := GL.Double (W) / GL.Double (H);
         GL.Frustum (-Aspect, Aspect, -1.0, 1.0, 2.0, 10.0);
      end if;

   end Set_View;

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

   -- Draw our scene
   procedure Draw is

      use type GL.Bitfield;

      MW    : Natural;
      MA    : Natural;
      MD    : Natural;
      Scale : Float;
      Pad   : Float := Img_Wide / 10.0;  -- margin width

      FNum  : String := Img (Frame, 6);
      FRate : String (1 .. 6);

   begin  -- Draw

      -- Set a light grey background
      GL.ClearColor (0.85, 0.85, 0.85, 0.0);
      GL.Clear (GL.GL_COLOR_BUFFER_BIT or GL.GL_DEPTH_BUFFER_BIT);

      -- Draw a black rectangle, disabling texturing so we can do plain colors
      GL.Disable (GL.GL_TEXTURE_2D);
      GL.Disable (GL.GL_BLEND);
      GL.Disable (GL.GL_ALPHA_TEST);
      GL.Color (Float (0.0), 0.0, 0.0);
      GL.glBegin (GL.GL_POLYGON);
      begin
         GL.Vertex (-Img_Wide, -Img_High, 0.0);
         GL.Vertex (-Img_Wide,  Img_High, 0.0);
         GL.Vertex ( Img_Wide,  Img_High, 0.0);
         GL.Vertex ( Img_Wide, -Img_High, 0.0);
      end;
      GL.glEnd;

      -- Turn texturing back on and set up to draw the text messages
      GL.PushMatrix;
      GL.Enable (GL.GL_TEXTURE_2D);
      GL.Enable (GL.GL_ALPHA_TEST);
      GL.AlphaFunc (GL.GL_GEQUAL, 0.0625);
      GL.Enable (GL.GL_BLEND);
      GL.BlendFunc (GL.GL_SRC_ALPHA, GL.GL_ONE_MINUS_SRC_ALPHA);
      GL.Enable (GL.GL_POLYGON_OFFSET_FILL);
      GL.PolygonOffset (0.0, -3.0);
      GL.Color (Float (0.1), 0.8, 0.1);

      -- Draw the frame number, right-justified in upper half of rectangle
      GL.PushMatrix;
      Font.Txf.Get_String_Metrics (Tx_Font, FNum, MW, MA, MD);
      Scale := Img_High / (Float (MA) * 3.0);
      GL.Translate (Img_Wide - (Pad + Float (MW) * Scale), Float (MA) * Scale, 0.0);
      GL.Scale (Scale, Scale, Scale);
      Font.Txf.Render (Tx_Font, FNum);
      GL.PopMatrix;

      -- Draw the frame number label, left-justified in upper half of
      -- rectangle, and one-third the size of the number itself
      GL.PushMatrix;
      Font.Txf.Get_String_Metrics (Tx_Font, "Frame", MW, MA, MD);
      GL.Translate (-(Img_Wide - Pad), Float (MA) * Scale, 0.0);
      GL.Scale (Scale / 3.0, Scale / 3.0, Scale / 3.0);
      Font.Txf.Render (Tx_Font, "Frame");
      GL.PopMatrix;

      -- Draw the frame rate, right-justified in lower half of rectangle
      GL.PushMatrix;
      -- Guard against out-of-range values, and display all question marks if so
      begin
         Ada.Float_Text_IO.Put (FRate, Events.Animate.FPS (Win), Aft => 3, Exp => 0);

      exception
         when others =>
            FRate := (others => '?');
      end;
      Font.Txf.Get_String_Metrics (Tx_Font, FRate, MW, MA, MD);
      GL.Translate (Img_Wide - (Pad + Float (MW) * Scale), -Float (MA) * Scale, 0.0);
      GL.Scale (Scale, Scale, Scale);
      Font.Txf.Render (Tx_Font, FRate);
      GL.PopMatrix;

      -- Draw the frame rate label, left-justified in lower half of
      -- rectangle, and one-third the size of the number itself
      GL.PushMatrix;
      Font.Txf.Get_String_Metrics (Tx_Font, "FPS", MW, MA, MD);
      GL.Translate (-(Img_Wide - Pad), -Float (MA) * Scale, 0.0);
      GL.Scale (Scale / 3.0, Scale / 3.0, Scale / 3.0);
      Font.Txf.Render (Tx_Font, "FPS");
      GL.PopMatrix;

      GL.PopMatrix;

      -- Rotate the object around the Y and Z axes by the current amount, to
      -- give a "tumbling" effect.
      GL.MatrixMode (GL.GL_MODELVIEW);
      GL.LoadIdentity;
      GL.Translate (GL.Double (0.0), 0.0, -4.0);
      GL.Rotate (GL.Double (Rotation), 0.0, 1.0, 0.0);
      GL.Rotate (GL.Double (Rotation), 0.0, 0.0, 1.0);

      -- Now show it
      Window.Swap (Win);

   end Draw;

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

   -- Simple event handler routine for close-window events
   procedure Quit_Handler (Event : in Events.Event_Data) is
   begin  -- Quit_Handler
      raise Program_Exit;
   end Quit_Handler;

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

   -- Simple event handler routine for keypresses
   procedure Key_Handler (Event : in Events.Event_Data) is

      use type Events.Key_Symbol;

   begin  -- Key_Handler
      if Event.Key_Data.Key = Events.To_Symbol (Ada.Characters.Latin_1.ESC) or
         Event.Key_Data.Key = Events.To_Symbol ('q') then
         raise Program_Exit;
      elsif Event.Key_Data.Key = Events.To_Symbol (Ada.Characters.Latin_1.Space) then
         Rotating := not Rotating;
      end if;
   end Key_Handler;

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

   -- Simple event handler routine for Exposed events
   procedure Expose_Handler (Event : in Events.Event_Data) is
   begin  -- Expose_Handler
      Draw;
   end Expose_Handler;

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

   -- Simple event handler routine for Resized events
   procedure Resize_Handler (Event : in Events.Event_Data) is
   begin  -- Resize_Handler
      Wide := Event.Resize_Data.Width;
      High := Event.Resize_Data.Height;
      Set_View (Wide, High);
      Draw;
   end Resize_Handler;

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

   -- Our draw-a-frame routine, should get called FPS times a second
   procedure New_Frame (Frame_Delta : in Duration) is
   begin  -- New_Frame
      if Rotating then
         if Rotation >= Max_Rotation then
            Rotation := 0;
         else
            Rotation := Rotation + 1;
         end if;
      end if;

      Frame := Frame + 1;

      Draw;
   end New_Frame;

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

begin  -- Text2

   -- Load the font we'll be using
   if Ada.Command_Line.Argument_Count > 0 then
      declare
         Font_Path : String := Ada.Command_Line.Argument (1);
      begin
         Font.Txf.Load (Tx_Font, Font_Path);

      exception
         when others =>
            raise Program_Error with "cannot find font file """ & Font_Path & """";
      end;
   else
      begin
         Font.Txf.Load (Tx_Font, Default_Font_Path);
      exception
         when others =>
            begin
               Font.Txf.Load (Tx_Font, "demo/" & Default_Font_Path);
            exception
               when others =>
                  raise Program_Error with "cannot find default font file """ & Default_Font_Path & """";
            end;
      end;
   end if;

   -- If other command-line arguments were given then process them
   for Index in 2 .. Ada.Command_Line.Argument_Count loop

      declare
         use Window;
         Arg : String := Ada.Command_Line.Argument (Index);
      begin
         case Arg (Arg'First) is

            when 'a' =>
               Attrs (4) := (Attr_Alpha_Size, Integer'Value (Arg (Arg'First + 1 .. Arg'Last)));

            when 'c' =>
               Attrs (1) := (Attr_Red_Size,   Integer'Value (Arg (Arg'First + 1 .. Arg'Last)));
               Attrs (2) := (Attr_Blue_Size,  Integer'Value (Arg (Arg'First + 1 .. Arg'Last)));
               Attrs (3) := (Attr_Green_Size, Integer'Value (Arg (Arg'First + 1 .. Arg'Last)));

            when 'd' =>
               Attrs (5) := (Attr_Depth_Size, Integer'Value (Arg (Arg'First + 1 .. Arg'Last)));

            when 'n' =>
               Direct := False;

            when others =>
               null;

         end case;
      end;

   end loop;

   -- Create Lumen window, accepting most defaults; turn double buffering off
   -- for simplicity
   Window.Create (Win,
                  Name       => "Text Demo #2, Revenge of the Text",
                  Width      => Wide,
                  Height     => High,
                  Direct     => Direct,
                  Attributes => Attrs,
                  Events     => (Window.Want_Key_Press => True,
                                 Window.Want_Exposure  => True,
                                 others => False));

   -- Set up the viewport and scene parameters
   Set_View (Wide, High);
   Object := Font.Txf.Establish_Texture (Tx_Font, 0, True);

   -- Enter the event loop
   declare
      use Events;
   begin
      Animate.Select_Events (Win   => Win,
                             Calls => (Key_Press    => Key_Handler'Unrestricted_Access,
                                       Exposed      => Expose_Handler'Unrestricted_Access,
                                       Resized      => Resize_Handler'Unrestricted_Access,
                                       Close_Window => Quit_Handler'Unrestricted_Access,
                                       others       => No_Callback),
                             FPS   => Framerate,
                             Frame => New_Frame'Unrestricted_Access);
   end;

exception
   when Program_Exit =>
      null;  -- just exit this block, which terminates the app

end Text2;

Add labels, pause key, and other minor touch-ups