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

with MAT.Events;
with MAT.Types;
with MAT.Readers.Marshaller;
with Interfaces;
package body MAT.Readers is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Readers");

   function Hash (Key : in MAT.Types.Uint16) return Ada.Containers.Hash_Type is
   begin
      return Ada.Containers.Hash_Type (Key);
   end Hash;

   procedure Register_Servant (Adapter : in Manager;
                               Proxy : in Servant) is
   begin
      if Proxy.Owner /= null then
         raise PROGRAM_ERROR;
      end if;
      Proxy.Owner := Adapter;
   end Register_Servant;

   procedure Register_Reader (Into  : in out Manager_Base;
                              Name  : in String;
                              Id    : in MAT.Events.Internal_Reference;
                              Model : in MAT.Events.Attribute_Table_Ptr) is
      Handler : Message_Handler;
   begin
      Handler.Id := Id;
      Handler.Attributes  := Model;
      Handler.Mapping     := new MAT.Events.Attribute_Table (Model'Range);
      Handler.Mapping.all := Model.all;
      Into.Readers.Insert (Name, Handler);
   end Register_Reader;

   procedure Register_Message_Analyzer (Proxy  : in Reader_Access;
                                        Name   : in String;
                                        Id     : in MAT.Events.Internal_Reference;
                                        Model  : in MAT.Events.Attribute_Table;
                                        Table  : out MAT.Events.Attribute_Table_Ptr) is
      Handler : Message_Handler := (For_Servant => Proxy, Id => Id);
      Adapter : IpcManager := IpcManager_Base (Proxy.Owner.all)'Access;
      N : String_Ptr := new String'(Name);
      It      : Event_Def_AVL.Iterator   := Find (adapter.Event_Types, N);
   begin
      if Is_Done (It) then
         return;
      end if;

      declare
         Event_Def : Event_Description_Ptr := Current_Item (It);
         Inserted  : Boolean;
      begin
         Insert (T => Adapter.Handlers,
                 Element => Handler,
                 The_Key => Event_Def.Id,
                 Not_Found => Inserted);

         Table := new Attribute_Table (1 .. Event_Def.Nb_Attributes);
         Table (Table'Range) := Event_Def.Def (Table'Range);
         for I in Table'Range loop
            Table (I).Ref := 0;
            for J in Model'Range loop
               if Table (I).Name.all = Model (I).Name.all then
                  Table (I).Ref := Model (I).Ref;
                  exit;
               end if;
            end loop;
         end loop;
      end;
   end Register_Message_Analyzer;

   procedure Dispatch_Message (Client : in out Manager_Base;
                               Msg    : in out Message) is
      Event : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Pos   : constant Handler_Maps.Cursor := Client.Handlers.Find (Event);
   begin
      if Handler_Maps.Has_Element (Pos) then
         --  Message is not handled, skip it.
         null;
      else
         declare
            Handler : constant Message_Handler := Handler_Maps.Element (Pos);
         begin
            Dispatch (Handler.For_Servant.all, Handler.Id, Handler.Mapping.all'Access, Msg);
         end;
      end if;
   end Dispatch_Message;

   --  ------------------------------
   --  Read an event definition from the stream and configure the reader.
   --  ------------------------------
   procedure Read_Definition (Client : in out Manager_Base;
                              Msg    : in out Message) is
      Name  : constant String := MAT.Readers.Marshaller.Get_String (Msg.Buffer);
      Event : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Count : constant MAT.Types.Uint8 := MAT.Readers.Marshaller.Get_Uint8 (Msg.Buffer);
      Pos   : constant Reader_Maps.Cursor := Client.Readers.Find (Name);

      procedure Read_Attributes (Key     : in String;
                                 Element : in out Message_Handler) is
      begin
         Element.Mapping := new MAT.Events.Attribute_Table (1 .. Natural (Count));
         for I in 1 .. Natural (Count) loop
            declare
               Name : constant String := MAT.Readers.Marshaller.Get_String (Msg.Buffer);
               Size : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
            begin
               for J in Element.Attributes'Range loop
                  if Element.Attributes (J).Name.all = Name then
                     Element.Mapping (I) := Element.Attributes (J);
                  end if;
               end loop;
            end;
         end loop;
      end Read_Attributes;

   begin
      Log.Debug ("Read event definition {0}", Name);
      if Reader_Maps.Has_Element (Pos) then
         Client.Readers.Update_Element (Pos, Read_Attributes'Access);
      end if;
   end Read_Definition;

   procedure Read_Headers (Client : in out Manager_Base;
                           Msg    : in out Message) is
      Count : MAT.Types.Uint16;
   begin
      Client.Version := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Client.Flags   := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Count := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);

      Log.Info ("Read event stream version {0} with {1} definitions",
                MAT.Types.Uint16'Image (Client.Version),
                MAT.Types.Uint16'Image (Count));
      for I in 1 .. Count loop
         Read_Definition (Client, Msg);
      end loop;
   end Read_Headers;

end MAT.Readers;

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

with MAT.Events;
with MAT.Types;
with MAT.Readers.Marshaller;
with Interfaces;
package body MAT.Readers is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Readers");

   function Hash (Key : in MAT.Types.Uint16) return Ada.Containers.Hash_Type is
   begin
      return Ada.Containers.Hash_Type (Key);
   end Hash;

   procedure Register_Servant (Adapter : in Manager;
                               Proxy : in Servant) is
   begin
      if Proxy.Owner /= null then
         raise PROGRAM_ERROR;
      end if;
      Proxy.Owner := Adapter;
   end Register_Servant;

   --  ------------------------------
   --  Register the reader to handle the event identified by the given name.
   --  The event is mapped to the given id and the attributes table is used
   --  to setup the mapping from the data stream attributes.
   --  ------------------------------
   procedure Register_Reader (Into   : in out Manager_Base;
                              Reader : in Reader_Access;
                              Name   : in String;
                              Id     : in MAT.Events.Internal_Reference;
                              Model  : in MAT.Events.Attribute_Table_Ptr) is
      Handler : Message_Handler;
   begin
      Handler.For_Servant := Reader;
      Handler.Id := Id;
      Handler.Attributes  := Model;
      Handler.Mapping     := null;
      Into.Readers.Insert (Name, Handler);
   end Register_Reader;

   procedure Register_Message_Analyzer (Proxy  : in Reader_Access;
                                        Name   : in String;
                                        Id     : in MAT.Events.Internal_Reference;
                                        Model  : in MAT.Events.Attribute_Table;
                                        Table  : out MAT.Events.Attribute_Table_Ptr) is
      Handler : Message_Handler := (For_Servant => Proxy, Id => Id);
      Adapter : IpcManager := IpcManager_Base (Proxy.Owner.all)'Access;
      N : String_Ptr := new String'(Name);
      It      : Event_Def_AVL.Iterator   := Find (adapter.Event_Types, N);
   begin
      if Is_Done (It) then
         return;
      end if;

      declare
         Event_Def : Event_Description_Ptr := Current_Item (It);
         Inserted  : Boolean;
      begin
         Insert (T => Adapter.Handlers,
                 Element => Handler,
                 The_Key => Event_Def.Id,
                 Not_Found => Inserted);

         Table := new Attribute_Table (1 .. Event_Def.Nb_Attributes);
         Table (Table'Range) := Event_Def.Def (Table'Range);
         for I in Table'Range loop
            Table (I).Ref := 0;
            for J in Model'Range loop
               if Table (I).Name.all = Model (I).Name.all then
                  Table (I).Ref := Model (I).Ref;
                  exit;
               end if;
            end loop;
         end loop;
      end;
   end Register_Message_Analyzer;

   procedure Dispatch_Message (Client : in out Manager_Base;
                               Msg    : in out Message) is
      Event : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Pos   : constant Handler_Maps.Cursor := Client.Handlers.Find (Event);
   begin
      if Handler_Maps.Has_Element (Pos) then
         --  Message is not handled, skip it.
         null;
      else
         declare
            Handler : constant Message_Handler := Handler_Maps.Element (Pos);
         begin
            Dispatch (Handler.For_Servant.all, Handler.Id, Handler.Mapping.all'Access, Msg);
         end;
      end if;
   end Dispatch_Message;

   --  ------------------------------
   --  Read an event definition from the stream and configure the reader.
   --  ------------------------------
   procedure Read_Definition (Client : in out Manager_Base;
                              Msg    : in out Message) is
      Name  : constant String := MAT.Readers.Marshaller.Get_String (Msg.Buffer);
      Event : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Count : constant MAT.Types.Uint8 := MAT.Readers.Marshaller.Get_Uint8 (Msg.Buffer);
      Pos   : constant Reader_Maps.Cursor := Client.Readers.Find (Name);

      procedure Read_Attributes (Key     : in String;
                                 Element : in out Message_Handler) is
      begin
         Element.Mapping := new MAT.Events.Attribute_Table (1 .. Natural (Count));
         for I in 1 .. Natural (Count) loop
            declare
               Name : constant String := MAT.Readers.Marshaller.Get_String (Msg.Buffer);
               Size : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
            begin
               for J in Element.Attributes'Range loop
                  if Element.Attributes (J).Name.all = Name then
                     Element.Mapping (I) := Element.Attributes (J);
                  end if;
               end loop;
            end;
         end loop;
      end Read_Attributes;

   begin
      Log.Debug ("Read event definition {0}", Name);
      if Reader_Maps.Has_Element (Pos) then
         Client.Readers.Update_Element (Pos, Read_Attributes'Access);
      end if;
   end Read_Definition;

   procedure Read_Headers (Client : in out Manager_Base;
                           Msg    : in out Message) is
      Count : MAT.Types.Uint16;
   begin
      Client.Version := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Client.Flags   := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Count := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);

      Log.Info ("Read event stream version {0} with {1} definitions",
                MAT.Types.Uint16'Image (Client.Version),
                MAT.Types.Uint16'Image (Count));
      for I in 1 .. Count loop
         Read_Definition (Client, Msg);
      end loop;
   end Read_Headers;

end MAT.Readers;

Update and fix the Register_Reader operation


-----------------------------------------------------------------------
--  factory -- Session Factory
--  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 ADO.Sequences;
with ADO.Caches;
with ADO.Sessions.Sources;

--  == Session Factory ==
--  The session factory is the entry point to obtain a database session.
--  The `ADO.Sessions.Factory` package defines the factory for creating
--  sessions.
--
--    with ADO.Sessions.Factory;
--    ...
--    Sess_Factory : ADO.Sessions.Factory;
--
--  The session factory can be initialized by using the `Create` operation and
--  by giving a URI string that identifies the driver and the information to connect
--  to the database.  The session factory is created only once when the application starts.
--
--    ADO.Sessions.Factory.Create (Sess_Factory, "mysql://localhost:3306/ado_test?user=test");
--
--  Having a session factory, one can get a database by using the `Get_Session` or
--  `Get_Master_Session` function.  Each time this operation is called, a new session
--  is returned.  The session is released when the session variable is finalized.
--
--    DB : ADO.Sessions.Session := Sess_Factory.Get_Session;
--
--  The session factory is also responsible for maintaining some data that is shared by
--  all the database connections.  This includes:
--
--    * the sequence generators used to allocate unique identifiers for database tables,
--    * the entity cache,
--    * some application specific global cache.
--
package ADO.Sessions.Factory is

   pragma Elaborate_Body;

   ENTITY_CACHE_NAME : constant String := "entity_type";

   --  ------------------------------
   --  Session factory
   --  ------------------------------
   type Session_Factory is tagged limited private;
   type Session_Factory_Access is access all Session_Factory'Class;

   --  Get a read-only session from the factory.
   function Get_Session (Factory : in Session_Factory) return Session;

   --  Get a read-write session from the factory.
   function Get_Master_Session (Factory : in Session_Factory) return Master_Session;

   --  Create the session factory to connect to the database represented
   --  by the data source.
   procedure Create (Factory : out Session_Factory;
                     Source  : in ADO.Sessions.Sources.Data_Source);

   --  Create the session factory to connect to the database identified
   --  by the URI.
   procedure Create (Factory : out Session_Factory;
                     URI     : in String);

   --  Get a read-only session from the session proxy.
   --  If the session has been invalidated, raise the SESSION_EXPIRED exception.
   function Get_Session (Proxy : in Session_Record_Access) return Session;
private

   --  The session factory holds the necessary information to obtain a master or slave
   --  database connection.  The sequence factory is shared by all sessions of the same
   --  factory (implementation is thread-safe).  The factory also contains the entity type
   --  cache which is initialized when the factory is created.
   type Session_Factory is tagged limited record
      Source       : ADO.Sessions.Sources.Data_Source;
      Sequences    : Factory_Access := null;
      Seq_Factory  : aliased ADO.Sequences.Factory;
      --  Entity_Cache : aliased ADO.Schemas.Entities.Entity_Cache;
      Entities     : ADO.Sessions.Entity_Cache_Access := null;
      Cache        : aliased ADO.Caches.Cache_Manager;
      Cache_Values : ADO.Caches.Cache_Manager_Access;
      Queries      : aliased ADO.Queries.Query_Manager;
   end record;

   --  Initialize the sequence factory associated with the session factory.
   procedure Initialize_Sequences (Factory : in out Session_Factory);

end ADO.Sessions.Factory;

-----------------------------------------------------------------------
--  factory -- Session Factory
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 2017, 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.
-----------------------------------------------------------------------

with ADO.Sequences;
with ADO.Caches;
with ADO.Sessions.Sources;

--  == Session Factory ==
--  The session factory is the entry point to obtain a database session.
--  The `ADO.Sessions.Factory` package defines the factory for creating
--  sessions.
--
--    with ADO.Sessions.Factory;
--    ...
--    Sess_Factory : ADO.Sessions.Factory;
--
--  The session factory can be initialized by using the `Create` operation and
--  by giving a URI string that identifies the driver and the information to connect
--  to the database.  The session factory is created only once when the application starts.
--
--    ADO.Sessions.Factory.Create (Sess_Factory, "mysql://localhost:3306/ado_test?user=test");
--
--  Having a session factory, one can get a database by using the `Get_Session` or
--  `Get_Master_Session` function.  Each time this operation is called, a new session
--  is returned.  The session is released when the session variable is finalized.
--
--    DB : ADO.Sessions.Session := Sess_Factory.Get_Session;
--
--  The session factory is also responsible for maintaining some data that is shared by
--  all the database connections.  This includes:
--
--    * the sequence generators used to allocate unique identifiers for database tables,
--    * the entity cache,
--    * some application specific global cache.
--
package ADO.Sessions.Factory is

   pragma Elaborate_Body;

   ENTITY_CACHE_NAME : constant String := "entity_type";

   --  ------------------------------
   --  Session factory
   --  ------------------------------
   type Session_Factory is tagged limited private;
   type Session_Factory_Access is access all Session_Factory'Class;

   --  Get a read-only session from the factory.
   function Get_Session (Factory : in Session_Factory) return Session;

   --  Get a read-write session from the factory.
   function Get_Master_Session (Factory : in Session_Factory) return Master_Session;

   --  Create the session factory to connect to the database represented
   --  by the data source.
   procedure Create (Factory : out Session_Factory;
                     Source  : in ADO.Sessions.Sources.Data_Source);

   --  Create the session factory to connect to the database identified
   --  by the URI.
   procedure Create (Factory : out Session_Factory;
                     URI     : in String);

   --  Get a read-only session from the session proxy.
   --  If the session has been invalidated, raise the Session_Error exception.
   function Get_Session (Proxy : in Session_Record_Access) return Session;
private

   --  The session factory holds the necessary information to obtain a master or slave
   --  database connection.  The sequence factory is shared by all sessions of the same
   --  factory (implementation is thread-safe).  The factory also contains the entity type
   --  cache which is initialized when the factory is created.
   type Session_Factory is tagged limited record
      Source       : ADO.Sessions.Sources.Data_Source;
      Sequences    : Factory_Access := null;
      Seq_Factory  : aliased ADO.Sequences.Factory;
      --  Entity_Cache : aliased ADO.Schemas.Entities.Entity_Cache;
      Entities     : ADO.Sessions.Entity_Cache_Access := null;
      Cache        : aliased ADO.Caches.Cache_Manager;
      Cache_Values : ADO.Caches.Cache_Manager_Access;
      Queries      : aliased ADO.Queries.Query_Manager;
   end record;

   --  Initialize the sequence factory associated with the session factory.
   procedure Initialize_Sequences (Factory : in out Session_Factory);

end ADO.Sessions.Factory;

Update the documentation

Update the documentation


------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                   A U N I T . R E P O R T E R . X M L                    --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                                                                          --
--                       Copyright (C) 2000-2009, AdaCore                   --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- GNAT is maintained by AdaCore (http://www.adacore.com)                   --
--                                                                          --
------------------------------------------------------------------------------

with AUnit.Time_Measure;
with Util.Strings;

--  Very simple reporter to console
package body Util.Tests.Reporter is

   use AUnit.Test_Results;
   use AUnit.Time_Measure;
   use type AUnit.Message_String;
   use Ada.Text_IO;

   procedure Dump_Result_List (File : in Ada.Text_IO.File_Type;
                               L    : in Result_Lists.List);
   --  List failed assertions

--     procedure Put_Measure is new Gen_Put_Measure;
   --  Output elapsed time

   procedure Report_Test (File : in Ada.Text_IO.File_Type;
                          Test : in Test_Result);
   --  Report a single assertion failure or unexpected exception

   procedure Put (File : in Ada.Text_IO.File_Type;
                  I    : in Integer);

   procedure Put (File : in Ada.Text_IO.File_Type;
                  I    : in Integer) is
   begin
      Ada.Text_IO.Put (File, Util.Strings.Image (I));
   end Put;

   ----------------------
   -- Dump_Result_List --
   ----------------------

   procedure Dump_Result_List (File : in Ada.Text_IO.File_Type;
                               L    : in Result_Lists.List) is

      use Result_Lists;

      C : Cursor := First (L);

   begin

      --  Note: can't use Iterate because it violates restriction
      --  No_Implicit_Dynamic_Code

      while Has_Element (C) loop
         Report_Test (File, Element (C));
         Next (C);
      end loop;
   end Dump_Result_List;

   ------------
   -- Report --
   ------------

   procedure Report (Engine : XML_Reporter;
                     R      : in out Result'Class)
   is
      Output : Ada.Text_IO.File_Type;
   begin
      Ada.Text_IO.Create (File => Output,
                          Mode => Ada.Text_IO.Out_File,
                          Name => To_String (Engine.File));
      Engine.Report (Output, R);
      Ada.Text_IO.Close (Output);
   end Report;

   ------------
   -- Report --
   ------------

   procedure Report (Engine : XML_Reporter;
                     File   : in out Ada.Text_IO.File_Type;
                     R      : in out Result'Class)
   is
      pragma Unreferenced (Engine);

      procedure Put (I : in Integer);
      procedure Put (S : in String);

      T   : AUnit_Duration;

      procedure Put (I : in Integer) is
      begin
         Ada.Text_IO.Put (File, Integer'Image (I));
      end Put;

      procedure Put (S : in String) is
      begin
         Put (File, S);
      end Put;

      procedure Put_Measure is new AUnit.Time_Measure.Gen_Put_Measure;

   begin
      Put_Line (File, "<?xml version='1.0' encoding='utf-8' ?>");
      Put      (File, "<TestRun");

      if Elapsed  (R) /= AUnit.Time_Measure.Null_Time then
         T := Get_Measure (Elapsed (R));

         Put (File, " elapsed='");
         Put_Measure (T);
         Put_Line (File, "'>");
      else
         Put_Line (File, ">");
      end if;

      Put_Line (File, "  <Statistics>");
      Put      (File, "    <Tests>");
      Put (File, Integer (Test_Count (R)));
      Put_Line (File, "</Tests>");
      Put      (File, "    <FailuresTotal>");
      Put (File, Integer (Failure_Count (R)) + Integer (Error_Count (R)));
      Put_Line (File, "</FailuresTotal>");
      Put      (File, "    <Failures>");
      Put (File, Integer (Failure_Count (R)));
      Put_Line (File, "</Failures>");
      Put      (File, "    <Errors>");
      Put (File, Integer (Error_Count (R)));
      Put_Line (File, "</Errors>");
      Put_Line (File, "  </Statistics>");

      declare
         S : Result_Lists.List;
      begin
         Put_Line (File, "  <SuccessfulTests>");
         Successes (R, S);
         Dump_Result_List (File, S);
         Put_Line (File, "  </SuccessfulTests>");
      end;

      Put_Line (File, "  <FailedTests>");
      declare
         F : Result_Lists.List;
      begin
         Failures (R, F);
         Dump_Result_List (File, F);
      end;

      declare
         E : Result_Lists.List;
      begin
         Errors (R, E);
         Dump_Result_List (File, E);
      end;
      Put_Line (File, "  </FailedTests>");

      Put_Line (File, "</TestRun>");
   end Report;

   ------------------
   -- Report_Error --
   ------------------

   procedure Report_Test (File : in Ada.Text_IO.File_Type;
                          Test : in Test_Result) is

      procedure Put (I : in Integer);
      procedure Put (S : in String);

      Is_Assert : Boolean;
      T : AUnit_Duration;

      procedure Put (I : in Integer) is
      begin
         Put (File, I);
      end Put;

      procedure Put (S : in String) is
      begin
         Put (File, S);
      end Put;

      procedure Put_Measure is new AUnit.Time_Measure.Gen_Put_Measure;

   begin
      Put (File, "    <Test");
      if Test.Elapsed /= AUnit.Time_Measure.Null_Time then
         T := Get_Measure (Test.Elapsed);

         Put (File, " elapsed='");
         Put_Measure (T);
         Put_Line (File, "'>");
      else
         Put_Line (File, ">");
      end if;
      Put      (File, "      <Name>");
      Put      (File, Test.Test_Name.all);

      if Test.Routine_Name /= null then
         Put (File, " : ");
         Put (File, Test.Routine_Name.all);
      end if;

      Put_Line (File, "</Name>");

      if Test.Failure /= null or else Test.Error /= null then
         if Test.Failure /= null then
            Is_Assert := True;
         else
            Is_Assert := False;
         end if;

         Put      (File, "      <FailureType>");

         if Is_Assert then
            Put   (File, "Assertion");
         else
            Put   (File, "Error");
         end if;

         Put_Line (File, "</FailureType>");
         Put      (File, "      <Message>");
         if Is_Assert then
            Put   (File, Test.Failure.Message.all);
         else
            Put   (File, Test.Error.Exception_Name.all);
         end if;
         Put_Line (File, "</Message>");

         if Is_Assert then
            Put_Line (File, "      <Location>");
            Put      (File, "        <File>");
            Put      (File, Test.Failure.Source_Name.all);
            Put_Line (File, "</File>");
            Put      (File, "        <Line>");
            Put      (File, Test.Failure.Line);
            Put_Line (File, "</Line>");
            Put_Line (File, "      </Location>");

         else
            Put_Line (File, "      <Exception>");
            Put      (File, "      <Message>");
            Put      (File, Test.Error.Exception_Name.all);
            Put_Line (File, "</Message>");

            if Test.Error.Exception_Message /= null then
               Put      (File, "      <Information>");
               Put      (File, Test.Error.Exception_Message.all);
               Put_Line (File, "</Information>");
            end if;

            if Test.Error.Traceback /= null then
               Put      (File, "      <Traceback>");
               Put      (File, Test.Error.Traceback.all);
               Put_Line (File, "</Traceback>");
            end if;

            Put_Line (File, "      </Exception>");
         end if;
      end if;

      Put_Line (File, "    </Test>");
   end Report_Test;

end Util.Tests.Reporter;

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                   A U N I T . R E P O R T E R . X M L                    --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                                                                          --
--                       Copyright (C) 2000-2009, AdaCore                   --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- GNAT is maintained by AdaCore (http://www.adacore.com)                   --
--                                                                          --
------------------------------------------------------------------------------

with AUnit.Time_Measure;
with Util.Strings;

--  Very simple reporter to console
package body Util.Tests.Reporter is

   use AUnit.Test_Results;
   use AUnit.Time_Measure;
   use type AUnit.Message_String;
   use Ada.Text_IO;

   procedure Print_Summary (R : in out Result'Class);

   procedure Dump_Result_List (File : in Ada.Text_IO.File_Type;
                               L    : in Result_Lists.List);
   --  List failed assertions

--     procedure Put_Measure is new Gen_Put_Measure;
   --  Output elapsed time

   procedure Report_Test (File : in Ada.Text_IO.File_Type;
                          Test : in Test_Result);
   --  Report a single assertion failure or unexpected exception

   procedure Put (File : in Ada.Text_IO.File_Type;
                  I    : in Integer);

   procedure Put (File : in Ada.Text_IO.File_Type;
                  I    : in Integer) is
   begin
      Ada.Text_IO.Put (File, Util.Strings.Image (I));
   end Put;

   ----------------------
   -- Dump_Result_List --
   ----------------------

   procedure Dump_Result_List (File : in Ada.Text_IO.File_Type;
                               L    : in Result_Lists.List) is

      use Result_Lists;

      C : Cursor := First (L);

   begin

      --  Note: can't use Iterate because it violates restriction
      --  No_Implicit_Dynamic_Code

      while Has_Element (C) loop
         Report_Test (File, Element (C));
         Next (C);
      end loop;
   end Dump_Result_List;

   ------------
   -- Report --
   ------------

   procedure Report (Engine : XML_Reporter;
                     R      : in out Result'Class)
   is
      Output : Ada.Text_IO.File_Type;
   begin
      Ada.Text_IO.Create (File => Output,
                          Mode => Ada.Text_IO.Out_File,
                          Name => To_String (Engine.File));
      Engine.Report (Output, R);
      Ada.Text_IO.Close (Output);
   end Report;

   procedure Print_Summary (R : in out Result'Class) is
      S_Count : constant Integer := Integer (Success_Count (R));
      F_Count : constant Integer := Integer (Failure_Count (R));
      E_Count : constant Integer := Integer (Error_Count (R));
   begin
      New_Line;
      Put ("Total Tests Run:   ");
      Put (Util.Strings.Image (Integer (Test_Count (R))));
      New_Line;
      Put ("Successful Tests:  ");
      Put (Util.Strings.Image (S_Count));
      New_Line;
      Put ("Failed Assertions: ");
      Put (Util.Strings.Image (F_Count));
      New_Line;
      Put ("Unexpected Errors: ");
      Put (Util.Strings.Image (E_Count));
      New_Line;
   end Print_Summary;

   ------------
   -- Report --
   ------------
   procedure Report (Engine : XML_Reporter;
                     File   : in out Ada.Text_IO.File_Type;
                     R      : in out Result'Class)
   is
      pragma Unreferenced (Engine);

      procedure Put (I : in Integer);
      procedure Put (S : in String);

      T   : AUnit_Duration;

      procedure Put (I : in Integer) is
      begin
         Ada.Text_IO.Put (File, Integer'Image (I));
      end Put;

      procedure Put (S : in String) is
      begin
         Put (File, S);
      end Put;

      procedure Put_Measure is new AUnit.Time_Measure.Gen_Put_Measure;

   begin
      Put_Line (File, "<?xml version='1.0' encoding='utf-8' ?>");
      Put      (File, "<TestRun");

      if Elapsed  (R) /= AUnit.Time_Measure.Null_Time then
         T := Get_Measure (Elapsed (R));

         Put (File, " elapsed='");
         Put_Measure (T);
         Put_Line (File, "'>");
      else
         Put_Line (File, ">");
      end if;

      Print_Summary (R);

      Put_Line (File, "  <Statistics>");
      Put      (File, "    <Tests>");
      Put (File, Integer (Test_Count (R)));
      Put_Line (File, "</Tests>");
      Put      (File, "    <FailuresTotal>");
      Put (File, Integer (Failure_Count (R)) + Integer (Error_Count (R)));
      Put_Line (File, "</FailuresTotal>");
      Put      (File, "    <Failures>");
      Put (File, Integer (Failure_Count (R)));
      Put_Line (File, "</Failures>");
      Put      (File, "    <Errors>");
      Put (File, Integer (Error_Count (R)));
      Put_Line (File, "</Errors>");
      Put_Line (File, "  </Statistics>");

      declare
         S : Result_Lists.List;
      begin
         Put_Line (File, "  <SuccessfulTests>");
         Successes (R, S);
         Dump_Result_List (File, S);
         Put_Line (File, "  </SuccessfulTests>");
      end;

      Put_Line (File, "  <FailedTests>");
      declare
         F : Result_Lists.List;
      begin
         Failures (R, F);
         Dump_Result_List (File, F);
      end;

      declare
         E : Result_Lists.List;
      begin
         Errors (R, E);
         Dump_Result_List (File, E);
      end;
      Put_Line (File, "  </FailedTests>");

      Put_Line (File, "</TestRun>");
   end Report;

   ------------------
   -- Report_Error --
   ------------------

   procedure Report_Test (File : in Ada.Text_IO.File_Type;
                          Test : in Test_Result) is

      procedure Put (I : in Integer);
      procedure Put (S : in String);

      Is_Assert : Boolean;
      T : AUnit_Duration;

      procedure Put (I : in Integer) is
      begin
         Put (File, I);
      end Put;

      procedure Put (S : in String) is
      begin
         Put (File, S);
      end Put;

      procedure Put_Measure is new AUnit.Time_Measure.Gen_Put_Measure;

   begin
      Put (File, "    <Test");
      if Test.Elapsed /= AUnit.Time_Measure.Null_Time then
         T := Get_Measure (Test.Elapsed);

         Put (File, " elapsed='");
         Put_Measure (T);
         Put_Line (File, "'>");
      else
         Put_Line (File, ">");
      end if;
      Put      (File, "      <Name>");
      Put      (File, Test.Test_Name.all);

      if Test.Routine_Name /= null then
         Put (File, " : ");
         Put (File, Test.Routine_Name.all);
      end if;

      Put_Line (File, "</Name>");

      if Test.Failure /= null or else Test.Error /= null then
         if Test.Failure /= null then
            Is_Assert := True;
         else
            Is_Assert := False;
         end if;

         Put      (File, "      <FailureType>");

         if Is_Assert then
            Put   (File, "Assertion");
         else
            Put   (File, "Error");
         end if;

         Put_Line (File, "</FailureType>");
         Put      (File, "      <Message>");
         if Is_Assert then
            Put   (File, Test.Failure.Message.all);
         else
            Put   (File, Test.Error.Exception_Name.all);
         end if;
         Put_Line (File, "</Message>");

         if Is_Assert then
            Put_Line (File, "      <Location>");
            Put      (File, "        <File>");
            Put      (File, Test.Failure.Source_Name.all);
            Put_Line (File, "</File>");
            Put      (File, "        <Line>");
            Put      (File, Test.Failure.Line);
            Put_Line (File, "</Line>");
            Put_Line (File, "      </Location>");

         else
            Put_Line (File, "      <Exception>");
            Put      (File, "      <Message>");
            Put      (File, Test.Error.Exception_Name.all);
            Put_Line (File, "</Message>");

            if Test.Error.Exception_Message /= null then
               Put      (File, "      <Information>");
               Put      (File, Test.Error.Exception_Message.all);
               Put_Line (File, "</Information>");
            end if;

            if Test.Error.Traceback /= null then
               Put      (File, "      <Traceback>");
               Put      (File, Test.Error.Traceback.all);
               Put_Line (File, "</Traceback>");
            end if;

            Put_Line (File, "      </Exception>");
         end if;
      end if;

      Put_Line (File, "    </Test>");
   end Report_Test;

end Util.Tests.Reporter;

Print a summary of results on stdout

Print a summary of results on stdout


-----------------------------------------------------------------------
--  security-permissions -- Definition of permissions
--  Copyright (C) 2010, 2011, 2012, 2016, 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.
-----------------------------------------------------------------------
private with Interfaces;

--  == Permission ==
--  The Security.Permissions package defines the different permissions that can be
--  checked by the access control manager.  An application should declare each permission
--  by instantiating the <tt>Definition</tt> package:
--
--    package Perm_Create_Workspace is new Security.Permissions.Definition ("create-workspace");
--
--  This declares a permission that can be represented by "<tt>create-workspace</tt>" in
--  configuration files.  In Ada, the permission is used as follows:
--
--     Perm_Create_Workspace.Permission
--
package Security.Permissions is

   Invalid_Name   : exception;

   --  Max number of permissions supported by the implementation.
   MAX_PERMISSION : constant Natural := 255;

   type Permission_Index is new Natural range 0 .. MAX_PERMISSION;

   type Permission_Index_Array is array (Positive range <>) of Permission_Index;

   NONE : constant Permission_Index := Permission_Index'First;

   --  Get the permission index associated with the name.
   function Get_Permission_Index (Name : in String) return Permission_Index;

   --  Get the permission name given the index.
   function Get_Name (Index : in Permission_Index) return String;

   --  The permission root class.
   --  Each permission is represented by a Permission_Index number to provide a fast
   --  and efficient permission check.
   type Permission (Id : Permission_Index) is tagged limited null record;

   generic
      Name : String;
   package Definition is
      function Permission return Permission_Index;
      pragma Inline_Always (Permission);
   end Definition;

   --  Add the permission name and allocate a unique permission index.
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index);

   type Permission_Index_Set is private;

   --  Check if the permission index set contains the given permission index.
   function Has_Permission (Set   : in Permission_Index_Set;
                            Index : in Permission_Index) return Boolean;

   --  Add the permission index to the set.
   procedure Add_Permission (Set   : in out Permission_Index_Set;
                             Index : in Permission_Index);

   --  Get the last permission index registered in the global permission map.
   function Get_Last_Permission_Index return Permission_Index;

   --  The empty set of permission indexes.
   EMPTY_SET : constant Permission_Index_Set;

private

   INDEX_SET_SIZE : constant Natural := (MAX_PERMISSION + 7) / 8;

   type Permission_Index_Set is array (0 .. INDEX_SET_SIZE - 1) of Interfaces.Unsigned_8;

   EMPTY_SET : constant Permission_Index_Set := (others => 0);

end Security.Permissions;

-----------------------------------------------------------------------
--  security-permissions -- Definition of permissions
--  Copyright (C) 2010, 2011, 2012, 2016, 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.
-----------------------------------------------------------------------
private with Interfaces;

--  == Permission ==
--  The Security.Permissions package defines the different permissions that can be
--  checked by the access control manager.  An application should declare each permission
--  by instantiating the <tt>Definition</tt> package:
--
--    package Perm_Create_Workspace is new Security.Permissions.Definition ("create-workspace");
--
--  This declares a permission that can be represented by "<tt>create-workspace</tt>" in
--  configuration files.  In Ada, the permission is used as follows:
--
--     Perm_Create_Workspace.Permission
--
package Security.Permissions is

   Invalid_Name   : exception;

   --  Max number of permissions supported by the implementation.
   MAX_PERMISSION : constant Natural := 255;

   type Permission_Index is new Natural range 0 .. MAX_PERMISSION;

   type Permission_Index_Array is array (Positive range <>) of Permission_Index;

   NONE : constant Permission_Index := Permission_Index'First;

   --  Get the permission index associated with the name.
   function Get_Permission_Index (Name : in String) return Permission_Index;

   --  Get the list of permissions whose name is given in the string with separated comma.
   function Get_Permission_Array (List : in String) return Permission_Index_Array;

   --  Get the permission name given the index.
   function Get_Name (Index : in Permission_Index) return String;

   --  The permission root class.
   --  Each permission is represented by a Permission_Index number to provide a fast
   --  and efficient permission check.
   type Permission (Id : Permission_Index) is tagged limited null record;

   generic
      Name : String;
   package Definition is
      function Permission return Permission_Index;
      pragma Inline_Always (Permission);
   end Definition;

   --  Add the permission name and allocate a unique permission index.
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index);

   type Permission_Index_Set is private;

   --  Check if the permission index set contains the given permission index.
   function Has_Permission (Set   : in Permission_Index_Set;
                            Index : in Permission_Index) return Boolean;

   --  Add the permission index to the set.
   procedure Add_Permission (Set   : in out Permission_Index_Set;
                             Index : in Permission_Index);

   --  Get the last permission index registered in the global permission map.
   function Get_Last_Permission_Index return Permission_Index;

   --  The empty set of permission indexes.
   EMPTY_SET : constant Permission_Index_Set;

private

   INDEX_SET_SIZE : constant Natural := (MAX_PERMISSION + 7) / 8;

   type Permission_Index_Set is array (0 .. INDEX_SET_SIZE - 1) of Interfaces.Unsigned_8;

   EMPTY_SET : constant Permission_Index_Set := (others => 0);

end Security.Permissions;

Declare the Get_Permission_Array function


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

--  The Security.Permissions package defines the different permissions that can be
--  checked by the access control manager.
package Security.Permissions is

   Invalid_Name : exception;

   type Permission_Index is new Natural;

   --  Get the permission index associated with the name.
   function Get_Permission_Index (Name : in String) return Permission_Index;

   --  Get the last permission index registered in the global permission map.
   function Get_Last_Permission_Index return Permission_Index;

   --  Add the permission name and allocate a unique permission index.
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index);

   --  The permission root class.
   --  Each permission is represented by a Permission_Index number to provide a fast
   --  and efficient permission check.
   type Permission (Id : Permission_Index) is tagged limited null record;

   generic
      Name : String;
   package Permission_ACL is
      function Permission return Permission_Index;
      pragma Inline_Always (Permission);
   end Permission_ACL;

end Security.Permissions;

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

--  The Security.Permissions package defines the different permissions that can be
--  checked by the access control manager.
package Security.Permissions is

   Invalid_Name : exception;

   type Permission_Index is new Natural;

   --  Get the permission index associated with the name.
   function Get_Permission_Index (Name : in String) return Permission_Index;

   --  The permission root class.
   --  Each permission is represented by a Permission_Index number to provide a fast
   --  and efficient permission check.
   type Permission (Id : Permission_Index) is tagged limited null record;

   generic
      Name : String;
   package Definition is
      function Permission return Permission_Index;
      pragma Inline_Always (Permission);
   end Definition;

   --  Add the permission name and allocate a unique permission index.
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index);

private

   --  Get the last permission index registered in the global permission map.
   function Get_Last_Permission_Index return Permission_Index;

end Security.Permissions;

Rename the package Permission_ACL into Definition


-- Simple Lumen demo/test program, using earliest incomplete library.

with Ada.Characters.Handling;
with Ada.Command_Line;
with System.Address_To_Access_Conversions;

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

with GL;
with GLU;

procedure Texture is

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

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

   -- Traditional cinema framrate, in frames per second
   Framerate    : constant := 24;

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

   Win      : Lumen.Window.Handle;
   Event    : Lumen.Events.Event_Data;
   Wide     : Natural;  -- no longer have default values since they're now set by the image size
   High     : Natural;
   Rotation : Natural := 0;
   Image    : Lumen.Image.Descriptor;
   Img_Wide : GL.glFloat;
   Img_High : GL.glFloat;
   Tx_Name  : aliased GL.GLuint;
   Direct   : Boolean := True;  -- want direct rendering by default

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

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

   Program_Error : exception;
   Program_Exit  : exception;

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

   -- Create a texture and bind a 2D image to it
   procedure Create_Texture is

      use GL;
      use GLU;

      package GLB is new System.Address_To_Access_Conversions (GLubyte);

      IP : GLpointer;

   begin  -- Create_Texture

      -- Allocate a texture name
      glGenTextures (1, Tx_Name'Unchecked_Access);

      -- Bind texture operations to the newly-created texture name
      glBindTexture (GL_TEXTURE_2D, Tx_Name);

      -- Select modulate to mix texture with color for shading
      glTexEnvi (GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE);

      -- Wrap textures at both edges
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT);
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT);

      -- How the texture behaves when minified and magnified
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST);
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST);

      -- Create a pointer to the image.  This sort of horror show is going to
      -- be disappearing once Lumen includes its own OpenGL bindings.
      IP := GLB.To_Pointer (Image.Values (0, 0)'Address).all'Unchecked_Access;

      -- Build our texture from the image we loaded earlier
      glTexImage2D (GL_TEXTURE_2D, 0, GL_RGBA, GLsizei (Image.Width), GLsizei (Image.Height), 0,
                    GL_RGBA, GL_UNSIGNED_BYTE, IP);

   end Create_Texture;

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

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

      use GL;
      use GLU;

      Aspect : GLdouble;

   begin  -- Set_View

      -- Viewport dimensions
      glViewport (0, 0, GLsizei (W), GLsizei (H));

      -- Size of rectangle upon which image is mapped
      if Wide > High then
         Img_Wide := glFloat (1.5);
         Img_High := glFloat (1.5) * glFloat (Float (High) / Float (Wide));
      else
         Img_Wide := glFloat (1.5) * glFloat (Float (Wide) / Float (High));
         Img_High := glFloat (1.5);
      end if;

      -- Set up the projection matrix based on the window's shape--wider than
      -- high, or higher than wide
      glMatrixMode (GL_PROJECTION);
      glLoadIdentity;

      -- 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 := GLdouble (H) / GLdouble (W);
         glFrustum (-1.0, 1.0, -Aspect, Aspect, 2.0, 10.0);
      else
         Aspect := GLdouble (W) / GLdouble (H);
         glFrustum (-Aspect, Aspect, -1.0, 1.0, 2.0, 10.0);
      end if;

   end Set_View;

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

   -- Draw our scene
   procedure Draw is

      use GL;

   begin  -- Draw

      -- Set a black background
      glClearColor (0.8, 0.8, 0.8, 1.0);
      glClear (GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);

      -- Draw a texture-mapped rectangle with the same aspect ratio as the
      -- original image
      glBegin (GL_POLYGON);
      begin
         glTexCoord3f (0.0, 1.0, 0.0);
         glVertex3f (-Img_Wide, -Img_High, 0.0);

         glTexCoord3f (0.0, 0.0, 0.0);
         glVertex3f (-Img_Wide,  Img_High, 0.0);

         glTexCoord3f (1.0, 0.0, 0.0);
         glVertex3f ( Img_Wide,  Img_High, 0.0);

         glTexCoord3f (1.0, 1.0, 0.0);
         glVertex3f ( Img_Wide, -Img_High, 0.0);
      end;
      glEnd;

      -- Rotate the object around the Y and Z axes by the current amount, to
      -- give a "tumbling" effect.
      glMatrixMode (GL_MODELVIEW);
      glLoadIdentity;
      glTranslated (0.0, 0.0, -4.0);
      glRotated (GLdouble (Rotation), 0.0, 1.0, 0.0);
      glRotated (GLdouble (Rotation), 0.0, 0.0, 1.0);

      glFlush;

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

   end Draw;

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

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

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

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

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

   -- Simple event handler routine for Resized events
   procedure Resize_Handler (Event : in Lumen.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;

      Draw;
   end New_Frame;

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

begin  -- Texture

   -- If we haven't been given an image to work with, just do nothing
   if Ada.Command_Line.Argument_Count < 1 then
      raise Program_Error with "You did not supply an image file pathname on the command line";
   end if;

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

      declare
         use Lumen.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;

   -- Read image and use it to size the window.  This will suck if your image
   -- is very large.
   Image := Lumen.Image.From_File (Ada.Command_Line.Argument (1));
   Wide := Image.Width;
   High := Image.Height;

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

   -- Set up the viewport and scene parameters
   Set_View (Wide, High);

   -- Now create the texture and set up to use it
   Create_Texture;
   GL.glEnable (GL.GL_TEXTURE_2D);
   GL.glBindTexture (GL.GL_TEXTURE_2D, Tx_Name);

   -- Enter the event loop
   declare
      use Lumen.Events;
   begin
      Animate.Select_Events (Win   => Win,
                             Calls => (Key_Press    => Quit_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 Texture;

-- Simple Lumen demo/test program, using earliest incomplete library.

with Ada.Characters.Handling;
with Ada.Command_Line;
with System.Address_To_Access_Conversions;

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

with GL;
with GLU;

procedure Texture is

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

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

   -- Traditional cinema framrate, in frames per second
   Framerate    : constant := 24;

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

   Win      : Lumen.Window.Handle;
   Event    : Lumen.Events.Event_Data;
   Wide     : Natural;  -- no longer have default values since they're now set by the image size
   High     : Natural;
   Rotation : Natural := 0;
   Image    : Lumen.Image.Descriptor;
   Img_Wide : GL.glFloat;
   Img_High : GL.glFloat;
   Tx_Name  : aliased GL.GLuint;
   Direct   : Boolean := True;  -- want direct rendering by default

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

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

   Program_Error : exception;
   Program_Exit  : exception;

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

   -- Create a texture and bind a 2D image to it
   procedure Create_Texture is

      use GL;
      use GLU;

      package GLB is new System.Address_To_Access_Conversions (GLubyte);

      IP : GLpointer;

   begin  -- Create_Texture

      -- Allocate a texture name
      glGenTextures (1, Tx_Name'Unchecked_Access);

      -- Bind texture operations to the newly-created texture name
      glBindTexture (GL_TEXTURE_2D, Tx_Name);

      -- Select modulate to mix texture with color for shading
      glTexEnvi (GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE);

      -- Wrap textures at both edges
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT);
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT);

      -- How the texture behaves when minified and magnified
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST);
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST);

      -- Create a pointer to the image.  This sort of horror show is going to
      -- be disappearing once Lumen includes its own OpenGL bindings.
      IP := GLB.To_Pointer (Image.Values.all'Address).all'Unchecked_Access;

      -- Build our texture from the image we loaded earlier
      glTexImage2D (GL_TEXTURE_2D, 0, GL_RGBA, GLsizei (Image.Width), GLsizei (Image.Height), 0,
                    GL_RGBA, GL_UNSIGNED_BYTE, IP);

   end Create_Texture;

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

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

      use GL;
      use GLU;

      Aspect : GLdouble;

   begin  -- Set_View

      -- Viewport dimensions
      glViewport (0, 0, GLsizei (W), GLsizei (H));

      -- Size of rectangle upon which image is mapped
      if Wide > High then
         Img_Wide := glFloat (1.5);
         Img_High := glFloat (1.5) * glFloat (Float (High) / Float (Wide));
      else
         Img_Wide := glFloat (1.5) * glFloat (Float (Wide) / Float (High));
         Img_High := glFloat (1.5);
      end if;

      -- Set up the projection matrix based on the window's shape--wider than
      -- high, or higher than wide
      glMatrixMode (GL_PROJECTION);
      glLoadIdentity;

      -- 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 := GLdouble (H) / GLdouble (W);
         glFrustum (-1.0, 1.0, -Aspect, Aspect, 2.0, 10.0);
      else
         Aspect := GLdouble (W) / GLdouble (H);
         glFrustum (-Aspect, Aspect, -1.0, 1.0, 2.0, 10.0);
      end if;

   end Set_View;

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

   -- Draw our scene
   procedure Draw is

      use GL;

   begin  -- Draw

      -- Set a black background
      glClearColor (0.8, 0.8, 0.8, 1.0);
      glClear (GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);

      -- Draw a texture-mapped rectangle with the same aspect ratio as the
      -- original image
      glBegin (GL_POLYGON);
      begin
         glTexCoord3f (0.0, 1.0, 0.0);
         glVertex3f (-Img_Wide, -Img_High, 0.0);

         glTexCoord3f (0.0, 0.0, 0.0);
         glVertex3f (-Img_Wide,  Img_High, 0.0);

         glTexCoord3f (1.0, 0.0, 0.0);
         glVertex3f ( Img_Wide,  Img_High, 0.0);

         glTexCoord3f (1.0, 1.0, 0.0);
         glVertex3f ( Img_Wide, -Img_High, 0.0);
      end;
      glEnd;

      -- Rotate the object around the Y and Z axes by the current amount, to
      -- give a "tumbling" effect.
      glMatrixMode (GL_MODELVIEW);
      glLoadIdentity;
      glTranslated (0.0, 0.0, -4.0);
      glRotated (GLdouble (Rotation), 0.0, 1.0, 0.0);
      glRotated (GLdouble (Rotation), 0.0, 0.0, 1.0);

      glFlush;

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

   end Draw;

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

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

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

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

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

   -- Simple event handler routine for Resized events
   procedure Resize_Handler (Event : in Lumen.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;

      Draw;
   end New_Frame;

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

begin  -- Texture

   -- If we haven't been given an image to work with, just do nothing
   if Ada.Command_Line.Argument_Count < 1 then
      raise Program_Error with "You did not supply an image file pathname on the command line";
   end if;

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

      declare
         use Lumen.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;

   -- Read image and use it to size the window.  This will suck if your image
   -- is very large.
   Image := Lumen.Image.From_File (Ada.Command_Line.Argument (1));
   Wide := Image.Width;
   High := Image.Height;

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

   -- Set up the viewport and scene parameters
   Set_View (Wide, High);

   -- Now create the texture and set up to use it
   Create_Texture;
   GL.glEnable (GL.GL_TEXTURE_2D);
   GL.glBindTexture (GL.GL_TEXTURE_2D, Tx_Name);

   -- Enter the event loop
   declare
      use Lumen.Events;
   begin
      Animate.Select_Events (Win   => Win,
                             Calls => (Key_Press    => Quit_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 Texture;

Create address to image buffer in a more portable way, as Julian's BMP package uses 1-based indexes, and other future packages may too


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

   type File_Reader_Type is new Manager_Base with private;

   --  Open the file.
   procedure Open (Reader : in out File_Reader_Type;
                   Path   : in String);

   procedure Read_All (Reader : in out File_Reader_Type);

private

   type File_Reader_Type is new Manager_Base with record
      File   : aliased Util.Streams.Files.File_Stream;
      Stream : Util.Streams.Buffered.Buffered_Stream;
   end record;

end MAT.Readers.Files;

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

   type File_Reader_Type is new MAT.Readers.Streams.Stream_Reader_Type with private;

   --  Open the file.
   procedure Open (Reader : in out File_Reader_Type;
                   Path   : in String);

private

   type File_Reader_Type is new MAT.Readers.Streams.Stream_Reader_Type with record
      File   : aliased Util.Streams.Files.File_Stream;
   end record;

end MAT.Readers.Files;

Use the MAT.Readers.Streams package for the file reader implementation


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

--  The ASF.Views package defines the abstractions to represent
--  an XHTML view that can be instantiated to create the JSF component
--  tree.  The ASF.Views are read only once and they are shared
--  by the JSF component trees that are instantiated from it.
--
--  The XHTML view is read using a SAX parser which creates nodes
--  and attributes to represent the view.
--
--  The ASF.Views is composed of nodes represented by Tag_Node
--  and attributes represented by Tag_Attribute.  In a sense, this
--  is very close to an XML DOM tree.
package ASF.Views is

   --  ------------------------------
   --  Source line information
   --  ------------------------------
   type File_Info (<>) is limited private;
   type File_Info_Access is access all File_Info;

   --  Create a File_Info record to identify the file whose path is Path
   --  and whose relative path portion starts at Relative_Position.
   function Create_File_Info (Path              : in String;
                              Relative_Position : in Natural) return File_Info_Access;

   --  Get the relative path name
   function Relative_Path (File : in File_Info) return String;

   type Line_Info is private;

   --  Get the line number
   function Line (Info : in Line_Info) return Natural;
   pragma Inline (Line);

   --  Get the source file
   function File (Info : in Line_Info) return String;
   pragma Inline (File);

private
   type File_Info (Length : Natural) is limited record
      Relative_Pos : Natural;
      Path         : String (1 .. Length);
   end record;

   NO_FILE : aliased File_Info := File_Info '(Length => 0, Path => "", Relative_Pos => 0);

   type Line_Info is record
      Line   : Natural := 0;
      Column : Natural := 0;
      File   : File_Info_Access := NO_FILE'Access;
   end record;

end ASF.Views;

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

--  The ASF.Views package defines the abstractions to represent
--  an XHTML view that can be instantiated to create the JSF component
--  tree.  The ASF.Views are read only once and they are shared
--  by the JSF component trees that are instantiated from it.
--
--  The XHTML view is read using a SAX parser which creates nodes
--  and attributes to represent the view.
--
--  The ASF.Views is composed of nodes represented by Tag_Node
--  and attributes represented by Tag_Attribute.  In a sense, this
--  is very close to an XML DOM tree.
package ASF.Views is

   pragma Preelaborate;

   --  ------------------------------
   --  Source line information
   --  ------------------------------
   type File_Info (<>) is limited private;
   type File_Info_Access is access all File_Info;

   --  Create a File_Info record to identify the file whose path is Path
   --  and whose relative path portion starts at Relative_Position.
   function Create_File_Info (Path              : in String;
                              Relative_Position : in Natural) return File_Info_Access;

   --  Get the relative path name
   function Relative_Path (File : in File_Info) return String;

   type Line_Info is private;

   --  Get the line number
   function Line (Info : in Line_Info) return Natural;
   pragma Inline (Line);

   --  Get the source file
   function File (Info : in Line_Info) return String;
   pragma Inline (File);

private
   type File_Info (Length : Natural) is limited record
      Relative_Pos : Natural;
      Path         : String (1 .. Length);
   end record;

   NO_FILE : aliased File_Info := File_Info '(Length => 0, Path => "", Relative_Pos => 0);

   type Line_Info is record
      Line   : Natural := 0;
      Column : Natural := 0;
      File   : File_Info_Access := NO_FILE'Access;
   end record;

end ASF.Views;

Make the package Preelaborate

Make the package Preelaborate


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

with ASF.Applications.Main;
with ASF.Navigations.Render;
package body ASF.Navigations is

   --  ------------------------------
   --  Navigation Case
   --  ------------------------------

   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("ASF.Navigations");

   --  ------------------------------
   --  Check if the navigator specific condition matches the current execution context.
   --  ------------------------------
   function Matches (Navigator : in Navigation_Case;
                     Action    : in String;
                     Outcome   : in String;
                     Context   : in ASF.Contexts.Faces.Faces_Context'Class) return Boolean is
   begin
      --  outcome must match
      if Navigator.Outcome /= null and then Navigator.Outcome.all /= Outcome then
         return False;
      end if;

      --  action must match
      if Navigator.Action /= null and then Navigator.Action.all /= Action then
         return False;
      end if;

      --  condition must be true
      if not Navigator.Condition.Is_Constant then
         declare
            Value : constant Util.Beans.Objects.Object
              := Navigator.Condition.Get_Value (Context.Get_ELContext.all);
         begin
            if not Util.Beans.Objects.To_Boolean (Value) then
               return False;
            end if;
         end;
      end if;

      return True;
   end Matches;

   --  ------------------------------
   --  Navigation Rule
   --  ------------------------------

   --  ------------------------------
   --  Search for the navigator that matches the current action, outcome and context.
   --  Returns the navigator or null if there was no match.
   --  ------------------------------
   function Find_Navigation (Controller : in Rule;
                             Action     : in String;
                             Outcome    : in String;
                             Context    : in Contexts.Faces.Faces_Context'Class)
                             return Navigation_Access is
      Iter      : Navigator_Vector.Cursor := Controller.Navigators.First;
      Navigator : Navigation_Access;
   begin
      while Navigator_Vector.Has_Element (Iter) loop
         Navigator := Navigator_Vector.Element (Iter);

         --  Check if this navigator matches the action/outcome.
         if Navigator.Matches (Action, Outcome, Context) then
            return Navigator;
         end if;
         Navigator_Vector.Next (Iter);
      end loop;
      return null;
   end Find_Navigation;

   --  ------------------------------
   --  Navigation Handler
   --  ------------------------------

   --  ------------------------------
   --  After executing an action and getting the action outcome, proceed to the navigation
   --  to the next page.
   --  ------------------------------
   procedure Handle_Navigation (Handler : in Navigation_Handler;
                                Action  : in String;
                                Outcome : in String;
                                Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Nav_Rules : constant Navigation_Rules_Access := Handler.Rules;
      View      : constant Components.Root.UIViewRoot := Context.Get_View_Root;
      Name      : constant String := Components.Root.Get_View_Id (View);

      function Find_Navigation (View : in String) return Navigation_Access is
         Pos : constant Rule_Map.Cursor := Nav_Rules.Rules.Find (To_Unbounded_String (View));
      begin
         if not Rule_Map.Has_Element (Pos) then
            return null;
         end if;

         return Rule_Map.Element (Pos).Find_Navigation (Action, Outcome, Context);
      end Find_Navigation;

      Navigator : Navigation_Access;
   begin
      Log.Info ("Navigate from view {0} and action {1} with outcome {2}", Name, Action, Outcome);

      --  Find an exact match
      Navigator := Find_Navigation (Name);

      --  Find a wildcard match
      if Navigator = null then
         declare
            Last : Natural := Name'Last;
            N    : Natural;
         begin
            loop
               N := Util.Strings.Rindex (Name, '/', Last);
               exit when N = 0;

               Navigator := Find_Navigation (Name (Name'First .. N) & "*");
               exit when Navigator /= null or N = Name'First;
               Last := Name'First - 1;
            end loop;
         end;
      end if;

      --  Execute the navigation action.
      if Navigator /= null then
         Navigator.Navigate (Context);
      end if;
   end Handle_Navigation;

   --  ------------------------------
   --  Initialize the the lifecycle handler.
   --  ------------------------------
   procedure Initialize (Handler : in out Navigation_Handler;
                         App     : access ASF.Applications.Main.Application'Class) is
   begin
      Handler.Rules := new Navigation_Rules;
      Handler.Application := App;
   end Initialize;

   --  ------------------------------
   --  Free the storage used by the navigation handler.
   --  ------------------------------
   overriding
   procedure Finalize (Handler : in out Navigation_Handler) is
   begin
      null;
   end Finalize;

   --  ------------------------------
   --  Add a navigation case to navigate from the view identifier by From
   --  to the result view identified by To.  Some optional conditions are evaluated
   --  The Outcome must match unless it is empty.
   --  The Action must match unless it is empty.
   --  The Condition expression must evaluate to True.
   --  ------------------------------
   procedure Add_Navigation_Case (Handler   : in out Navigation_Handler;
                                  From      : in String;
                                  To        : in String;
                                  Outcome   : in String := "";
                                  Action    : in String := "";
                                  Condition : in String := "") is

      C : constant Navigation_Access := Render.Create_Render_Navigator (To);
   begin
      if Outcome'Length > 0 then
         C.Outcome := new String '(Outcome);
      end if;
      if Action'Length > 0 then
         C.Action := new String '(Action);
      end if;

      C.View_Handler := Handler.Application.Get_View_Handler;
      declare
         View : constant Unbounded_String := To_Unbounded_String (From);
         Pos  : constant Rule_Map.Cursor := Handler.Rules.Rules.Find (View);
         R    : Rule_Access;
      begin
         if not Rule_Map.Has_Element (Pos) then
            R := new Rule;
            Handler.Rules.Rules.Include (Key      => View,
                                         New_Item => R);
         else
            R := Rule_Map.Element (Pos);
         end if;

         R.Navigators.Append (C);
      end;
   end Add_Navigation_Case;

end ASF.Navigations;

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

with ASF.Applications.Main;
with ASF.Navigations.Render;
package body ASF.Navigations is

   --  ------------------------------
   --  Navigation Case
   --  ------------------------------

   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("ASF.Navigations");

   --  ------------------------------
   --  Check if the navigator specific condition matches the current execution context.
   --  ------------------------------
   function Matches (Navigator : in Navigation_Case;
                     Action    : in String;
                     Outcome   : in String;
                     Context   : in ASF.Contexts.Faces.Faces_Context'Class) return Boolean is
   begin
      --  outcome must match
      if Navigator.Outcome /= null and then Navigator.Outcome.all /= Outcome then
         return False;
      end if;

      --  action must match
      if Navigator.Action /= null and then Navigator.Action.all /= Action then
         return False;
      end if;

      --  condition must be true
      if not Navigator.Condition.Is_Constant then
         declare
            Value : constant Util.Beans.Objects.Object
              := Navigator.Condition.Get_Value (Context.Get_ELContext.all);
         begin
            if not Util.Beans.Objects.To_Boolean (Value) then
               return False;
            end if;
         end;
      end if;

      return True;
   end Matches;

   --  ------------------------------
   --  Navigation Rule
   --  ------------------------------

   --  ------------------------------
   --  Search for the navigator that matches the current action, outcome and context.
   --  Returns the navigator or null if there was no match.
   --  ------------------------------
   function Find_Navigation (Controller : in Rule;
                             Action     : in String;
                             Outcome    : in String;
                             Context    : in Contexts.Faces.Faces_Context'Class)
                             return Navigation_Access is
      Iter      : Navigator_Vector.Cursor := Controller.Navigators.First;
      Navigator : Navigation_Access;
   begin
      while Navigator_Vector.Has_Element (Iter) loop
         Navigator := Navigator_Vector.Element (Iter);

         --  Check if this navigator matches the action/outcome.
         if Navigator.Matches (Action, Outcome, Context) then
            return Navigator;
         end if;
         Navigator_Vector.Next (Iter);
      end loop;
      return null;
   end Find_Navigation;

   --  ------------------------------
   --  Navigation Handler
   --  ------------------------------

   --  ------------------------------
   --  After executing an action and getting the action outcome, proceed to the navigation
   --  to the next page.
   --  ------------------------------
   procedure Handle_Navigation (Handler : in Navigation_Handler;
                                Action  : in String;
                                Outcome : in String;
                                Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Nav_Rules : constant Navigation_Rules_Access := Handler.Rules;
      View      : constant Components.Root.UIViewRoot := Context.Get_View_Root;
      Name      : constant String := Components.Root.Get_View_Id (View);

      function Find_Navigation (View : in String) return Navigation_Access is
         Pos : constant Rule_Map.Cursor := Nav_Rules.Rules.Find (To_Unbounded_String (View));
      begin
         if not Rule_Map.Has_Element (Pos) then
            return null;
         end if;

         return Rule_Map.Element (Pos).Find_Navigation (Action, Outcome, Context);
      end Find_Navigation;

      Navigator : Navigation_Access;
   begin
      Log.Info ("Navigate from view {0} and action {1} with outcome {2}", Name, Action, Outcome);

      --  Find an exact match
      Navigator := Find_Navigation (Name);

      --  Find a wildcard match
      if Navigator = null then
         declare
            Last : Natural := Name'Last;
            N    : Natural;
         begin
            loop
               N := Util.Strings.Rindex (Name, '/', Last);
               exit when N = 0;

               Navigator := Find_Navigation (Name (Name'First .. N) & "*");
               exit when Navigator /= null or N = Name'First;
               Last := N - 1;
            end loop;
         end;
      end if;

      --  Execute the navigation action.
      if Navigator /= null then
         Navigator.Navigate (Context);
      end if;
   end Handle_Navigation;

   --  ------------------------------
   --  Initialize the the lifecycle handler.
   --  ------------------------------
   procedure Initialize (Handler : in out Navigation_Handler;
                         App     : access ASF.Applications.Main.Application'Class) is
   begin
      Handler.Rules := new Navigation_Rules;
      Handler.Application := App;
   end Initialize;

   --  ------------------------------
   --  Free the storage used by the navigation handler.
   --  ------------------------------
   overriding
   procedure Finalize (Handler : in out Navigation_Handler) is
   begin
      null;
   end Finalize;

   --  ------------------------------
   --  Add a navigation case to navigate from the view identifier by From
   --  to the result view identified by To.  Some optional conditions are evaluated
   --  The Outcome must match unless it is empty.
   --  The Action must match unless it is empty.
   --  The Condition expression must evaluate to True.
   --  ------------------------------
   procedure Add_Navigation_Case (Handler   : in out Navigation_Handler;
                                  From      : in String;
                                  To        : in String;
                                  Outcome   : in String := "";
                                  Action    : in String := "";
                                  Condition : in String := "") is

      C : constant Navigation_Access := Render.Create_Render_Navigator (To);
   begin
      if Outcome'Length > 0 then
         C.Outcome := new String '(Outcome);
      end if;
      if Action'Length > 0 then
         C.Action := new String '(Action);
      end if;

      C.View_Handler := Handler.Application.Get_View_Handler;
      declare
         View : constant Unbounded_String := To_Unbounded_String (From);
         Pos  : constant Rule_Map.Cursor := Handler.Rules.Rules.Find (View);
         R    : Rule_Access;
      begin
         if not Rule_Map.Has_Element (Pos) then
            R := new Rule;
            Handler.Rules.Rules.Include (Key      => View,
                                         New_Item => R);
         else
            R := Rule_Map.Element (Pos);
         end if;

         R.Navigators.Append (C);
      end;
   end Add_Navigation_Case;

end ASF.Navigations;

Fix navigation resolution

Fix navigation resolution