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

with Util.Log.Loggers;

with ASF.Applications.Main;

with Security.Contexts;
with Security.Policies.URLs;
package body ASF.Security.Filters.OAuth is

   use Ada.Strings.Unbounded;
   use Servers;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Filters.OAuth");

   function Get_Access_Token (Request : in ASF.Requests.Request'Class) return String;

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   procedure Initialize (Server  : in out Auth_Filter;
                         Config  : in ASF.Servlets.Filter_Config) is
      use ASF.Applications;

      Context : constant Servlets.Servlet_Registry_Access := Servlets.Get_Servlet_Context (Config);
   begin
      if Context.all in Main.Application'Class then
         Server.Set_Permission_Manager (Main.Application'Class (Context.all).Get_Security_Manager);
      end if;
   end Initialize;

   --  ------------------------------
   --  Set the permission manager that must be used to verify the permission.
   --  ------------------------------
   procedure Set_Permission_Manager (Filter  : in out Auth_Filter;
                                     Manager : in Policies.Policy_Manager_Access) is
   begin
      Filter.Manager := Manager;
   end Set_Permission_Manager;

   function Get_Access_Token (Request : in ASF.Requests.Request'Class) return String is
      Header : constant String := Request.Get_Header (AUTHORIZATION_HEADER_NAME);
   begin
      if Header'Length > 0 then
         return Header;
      end if;
      return Header;
   end Get_Access_Token;

   --  ------------------------------
   --  Filter the request to make sure the user is authenticated.
   --  Invokes the Do_Login procedure if there is no user.
   --  If a permission manager is defined, check that the user has the permission
   --  to view the page.  Invokes the Do_Deny procedure if the permission
   --  is denied.
   --  ------------------------------
   procedure Do_Filter (F        : in Auth_Filter;
                        Request  : in out ASF.Requests.Request'Class;
                        Response : in out ASF.Responses.Response'Class;
                        Chain    : in out ASF.Servlets.Filter_Chain) is
      use Policies.URLs;
      use type Policies.Policy_Manager_Access;

      Servlet : constant String := Request.Get_Servlet_Path;
      URL     : constant String := Servlet & Request.Get_Path_Info;
   begin
      if F.Realm = null then
         Log.Error ("Deny access on {0} due to missing realm", URL);
         Auth_Filter'Class (F).Do_Deny (Request, Response);
         return;
      end if;
      declare
         Bearer  : constant String := Get_Access_Token (Request);
         Auth    : Principal_Access;
         Grant   : Servers.Grant_Type;
         Context : aliased Contexts.Security_Context;
      begin
         if Bearer'Length = 0 then
            Log.Info ("Ask authentication on {0} due to missing access token", URL);
            Auth_Filter'Class (F).Do_Login (Request, Response);
            return;
         end if;
         F.Realm.Authenticate (Bearer, Grant);
         if Grant.Status /= Valid_Grant then
            Log.Info ("Ask authentication on {0} due to missing access token", URL);
            Auth_Filter'Class (F).Do_Deny (Request, Response);
            return;
         end if;

         --  OAuth_Permission
         --  if not F.Manager.Has_Permission (Context, Perm) then
         --     -- deny
         --  Request.Set_Attribute ("application", Grant.Application);
         --  Request is authorized, proceed to the next filter.
         ASF.Servlets.Do_Filter (Chain    => Chain,
                                 Request  => Request,
                                 Response => Response);
      end;
   end Do_Filter;

   --  ------------------------------
   --  Display or redirects the user to the login page.  This procedure is called when
   --  the user is not authenticated.
   --  ------------------------------
   procedure Do_Login (F        : in Auth_Filter;
                       Request  : in out ASF.Requests.Request'Class;
                       Response : in out ASF.Responses.Response'Class) is
      pragma Unreferenced (F, Request);
   begin
      Response.Send_Error (ASF.Responses.SC_UNAUTHORIZED);
   end Do_Login;

   --  ------------------------------
   --  Display the forbidden access page.  This procedure is called when the user is not
   --  authorized to see the page.  The default implementation returns the SC_FORBIDDEN error.
   --  ------------------------------
   procedure Do_Deny (F        : in Auth_Filter;
                      Request  : in out ASF.Requests.Request'Class;
                      Response : in out ASF.Responses.Response'Class) is
      pragma Unreferenced (Request);
   begin
      Response.Add_Header (WWW_AUTHENTICATE_HEADER_NAME,
                           "Bearer realm=""" & To_String (F.Realm_URL)
                           & """, error=""invalid_token""");
      Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
   end Do_Deny;

end ASF.Security.Filters.OAuth;

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

with Util.Log.Loggers;

with ASF.Applications.Main;

with Security.Policies.URLs;
package body ASF.Security.Filters.OAuth is

   use Ada.Strings.Unbounded;
   use Servers;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Filters.OAuth");

   function Get_Access_Token (Request : in ASF.Requests.Request'Class) return String;

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   procedure Initialize (Server  : in out Auth_Filter;
                         Config  : in ASF.Servlets.Filter_Config) is
      use ASF.Applications;

      Context : constant Servlets.Servlet_Registry_Access := Servlets.Get_Servlet_Context (Config);
   begin
      if Context.all in Main.Application'Class then
         Server.Set_Permission_Manager (Main.Application'Class (Context.all).Get_Security_Manager);
      end if;
   end Initialize;

   --  ------------------------------
   --  Set the permission manager that must be used to verify the permission.
   --  ------------------------------
   procedure Set_Permission_Manager (Filter  : in out Auth_Filter;
                                     Manager : in Policies.Policy_Manager_Access) is
   begin
      Filter.Manager := Manager;
   end Set_Permission_Manager;

   function Get_Access_Token (Request : in ASF.Requests.Request'Class) return String is
      Header : constant String := Request.Get_Header (AUTHORIZATION_HEADER_NAME);
   begin
      if Header'Length > 0 then
         return Header;
      end if;
      return Header;
   end Get_Access_Token;

   --  ------------------------------
   --  Filter the request to make sure the user is authenticated.
   --  Invokes the Do_Login procedure if there is no user.
   --  If a permission manager is defined, check that the user has the permission
   --  to view the page.  Invokes the Do_Deny procedure if the permission
   --  is denied.
   --  ------------------------------
   procedure Do_Filter (F        : in Auth_Filter;
                        Request  : in out ASF.Requests.Request'Class;
                        Response : in out ASF.Responses.Response'Class;
                        Chain    : in out ASF.Servlets.Filter_Chain) is
      use Policies.URLs;
      use type Policies.Policy_Manager_Access;

      Servlet : constant String := Request.Get_Servlet_Path;
      URL     : constant String := Servlet & Request.Get_Path_Info;
   begin
      if F.Realm = null then
         Log.Error ("Deny access on {0} due to missing realm", URL);
         Auth_Filter'Class (F).Do_Deny (Request, Response);
         return;
      end if;
      declare
         Bearer  : constant String := Get_Access_Token (Request);
         --  Auth    : Principal_Access;
         Grant   : Servers.Grant_Type;
         --  Context : aliased Contexts.Security_Context;
      begin
         if Bearer'Length = 0 then
            Log.Info ("Ask authentication on {0} due to missing access token", URL);
            Auth_Filter'Class (F).Do_Login (Request, Response);
            return;
         end if;
         F.Realm.Authenticate (Bearer, Grant);
         if Grant.Status /= Valid_Grant then
            Log.Info ("Ask authentication on {0} due to missing access token", URL);
            Auth_Filter'Class (F).Do_Deny (Request, Response);
            return;
         end if;

         --  OAuth_Permission
         --  if not F.Manager.Has_Permission (Context, Perm) then
         --     -- deny
         --  Request.Set_Attribute ("application", Grant.Application);
         --  Request is authorized, proceed to the next filter.
         ASF.Servlets.Do_Filter (Chain    => Chain,
                                 Request  => Request,
                                 Response => Response);
      end;
   end Do_Filter;

   --  ------------------------------
   --  Display or redirects the user to the login page.  This procedure is called when
   --  the user is not authenticated.
   --  ------------------------------
   procedure Do_Login (F        : in Auth_Filter;
                       Request  : in out ASF.Requests.Request'Class;
                       Response : in out ASF.Responses.Response'Class) is
      pragma Unreferenced (F, Request);
   begin
      Response.Send_Error (ASF.Responses.SC_UNAUTHORIZED);
   end Do_Login;

   --  ------------------------------
   --  Display the forbidden access page.  This procedure is called when the user is not
   --  authorized to see the page.  The default implementation returns the SC_FORBIDDEN error.
   --  ------------------------------
   procedure Do_Deny (F        : in Auth_Filter;
                      Request  : in out ASF.Requests.Request'Class;
                      Response : in out ASF.Responses.Response'Class) is
      pragma Unreferenced (Request);
   begin
      Response.Add_Header (WWW_AUTHENTICATE_HEADER_NAME,
                           "Bearer realm=""" & To_String (F.Realm_URL)
                           & """, error=""invalid_token""");
      Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
   end Do_Deny;

end ASF.Security.Filters.OAuth;

Fix compilation warnings

Fix compilation warnings


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

with System;

with Ada.Exceptions;
with Ada.Real_Time;
with Ada.Unchecked_Deallocation;

with GL.Low_Level.Enums;
with GL.Types;
with GL.Pixels.Queries;

with Orka.Logging;
with Orka.KTX;

package body Orka.Resources.Textures.KTX is

   use Orka.Logging;
   package Messages is new Orka.Logging.Messages (Resource_Loader);

   type KTX_Load_Job is new Jobs.Abstract_Job and Jobs.GPU_Job with record
      Data    : Loaders.Resource_Data;
      Manager : Managers.Manager_Ptr;
   end record;

   overriding
   procedure Execute
     (Object  : KTX_Load_Job;
      Enqueue : not null access procedure (Element : Jobs.Job_Ptr));

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

   use all type Ada.Real_Time.Time;

   overriding
   procedure Execute
     (Object  : KTX_Load_Job;
      Enqueue : not null access procedure (Element : Jobs.Job_Ptr))
   is
      Bytes : Byte_Array_Pointers.Constant_Reference := Object.Data.Bytes.Get;
      Path  : String renames SU.To_String (Object.Data.Path);

      T1 : Ada.Real_Time.Time renames Object.Data.Start_Time;
      T2 : constant Ada.Real_Time.Time := Clock;

      use Ada.Streams;
      use GL.Low_Level.Enums;
      use type GL.Types.Size;

      T3, T4, T5, T6 : Ada.Real_Time.Time;
   begin
      if not Orka.KTX.Valid_Identifier (Bytes) then
         raise Texture_Load_Error with Path & " is not a KTX file";
      end if;

      declare
         Header : constant Orka.KTX.Header := Orka.KTX.Get_Header (Bytes);
         Levels : constant GL.Types.Size   := GL.Types.Size'Max (1, Header.Mipmap_Levels);

         Resource : constant Texture_Ptr := new Texture'(others => <>);
         Texture  : GL.Objects.Textures.Texture (Header.Kind);

         Width  : constant GL.Types.Size := Header.Width;
         Height :          GL.Types.Size := Header.Height;
         Depth  :          GL.Types.Size := Header.Depth;
      begin
         T3 := Clock;

         --  Allocate storage
         case Header.Kind is
            when Texture_2D_Array =>
               Depth := Header.Array_Elements;
            when Texture_1D_Array =>
               Height := Header.Array_Elements;
               pragma Assert (Depth = 0);
            when Texture_Cube_Map_Array =>
               --  For a cube map array, depth is the number of layer-faces
               Depth := Header.Array_Elements * 6;
            when Texture_3D =>
               null;
            when Texture_2D | Texture_Cube_Map =>
               pragma Assert (Depth = 0);
            when Texture_1D =>
               if Header.Compressed then
                  raise Texture_Load_Error with Path & " has unknown 1D compressed format";
               end if;
               pragma Assert (Height = 0);
               pragma Assert (Depth = 0);
            when others =>
               raise Program_Error;
         end case;

         if Header.Compressed then
            Texture.Allocate_Storage (Levels, 1, Header.Compressed_Format,
              Width, Height, Depth);
         else
            Texture.Allocate_Storage (Levels, 1, Header.Internal_Format,
              Width, Height, Depth);
         end if;

         case Header.Kind is
            when Texture_1D =>
               Height := 1;
               Depth  := 1;
            when Texture_1D_Array | Texture_2D =>
               Depth := 1;
            when Texture_2D_Array | Texture_3D =>
               null;
            when Texture_Cube_Map | Texture_Cube_Map_Array =>
               --  Texture_Cube_Map uses 2D storage, but 3D load operation
               --  according to table 8.15 of the OpenGL specification

               --  For a cube map, depth is the number of faces, for
               --  a cube map array, depth is the number of layer-faces
               Depth := GL.Types.Size'Max (1, Header.Array_Elements) * 6;
            when others =>
               raise Program_Error;
         end case;
         T4 := Clock;

         --  TODO Handle KTXorientation key value pair

         --  Upload texture data
         declare
            Image_Size_Index : Stream_Element_Offset
              := Orka.KTX.Get_Data_Offset (Bytes, Header.Bytes_Key_Value);

            Cube_Map : constant Boolean := Header.Kind = Texture_Cube_Map;
         begin
            for Level in 0 .. Levels - 1 loop
               declare
                  Face_Size : constant Natural := Orka.KTX.Get_Length (Bytes, Image_Size_Index);
                  --  If not Cube_Map, then Face_Size is the size of the whole level

                  Cube_Padding : constant Natural := 3 - ((Face_Size + 3) mod 4);
                  Image_Size   : constant Natural
                    := (if Cube_Map then (Face_Size + Cube_Padding) * 6 else Face_Size);
                  -- If Cube_Map then Levels = 1 so no need to add it to the expression

                  --  Compute size of the whole mipmap level
                  Mip_Padding : constant Natural := 3 - ((Image_Size + 3) mod 4);
                  Mipmap_Size : constant Natural := 4 + Image_Size + Mip_Padding;

                  Offset : constant Stream_Element_Offset := Image_Size_Index + 4;
                  pragma Assert
                    (Offset + Stream_Element_Offset (Image_Size) - 1 <= Bytes.Value'Last);
                  Image_Data : constant System.Address := Bytes (Offset)'Address;
                  --  TODO Unpack_Alignment must be 4, but Load_From_Data wants 1 | 2 | 4
                  --  depending on Header.Data_Type

                  Level_Width  : constant GL.Types.Size := Texture.Width  (Level);
                  Level_Height :          GL.Types.Size := Texture.Height (Level);
                  Level_Depth  :          GL.Types.Size := Texture.Depth  (Level);
               begin
                  if Header.Compressed then
                     Texture.Load_From_Data (Level, 0, 0, 0, Level_Width, Level_Height, Level_Depth,
                       Header.Compressed_Format, GL.Types.Int (Image_Size), Image_Data);
                  else
                     Texture.Load_From_Data (Level, 0, 0, 0, Level_Width, Level_Height, Level_Depth,
                       Header.Format, Header.Data_Type, Image_Data);
                  end if;

                  Image_Size_Index := Image_Size_Index + Stream_Element_Offset (Mipmap_Size);
               end;
            end loop;
         end;
         T5 := Clock;

         --  Generate a full mipmap pyramid if Mipmap_Levels = 0
         if Header.Mipmap_Levels = 0 then
            Texture.Generate_Mipmap;
         end if;
         T6 := Clock;

         Resource.Texture.Replace_Element (Texture);

         --  Register resource at the resource manager
         Object.Manager.Add_Resource (Path, Resource_Ptr (Resource));

         Messages.Insert (Info, "Loaded texture " & Path & " in " &
           Logging.Trim (Logging.Image (T6 - T1)));
         Messages.Insert (Info, "  size:   " &
            Logging.Trim (Width'Image) & " x " &
            Logging.Trim (Height'Image) & " x " &
            Logging.Trim (Depth'Image) &
            ", mipmap levels:" & Levels'Image);
         Messages.Insert (Info, "  kind:   " & Header.Kind'Image);
         if Header.Compressed then
            Messages.Insert (Info, "  format: " & Header.Compressed_Format'Image);
         else
            Messages.Insert (Info, "  format: " & Header.Internal_Format'Image);
         end if;

         Messages.Insert (Info, "  statistics:");
         Messages.Insert (Info, "    reading file:   " & Logging.Image (T2 - T1));
         Messages.Insert (Info, "    parsing header: " & Logging.Image (T3 - T2));
         Messages.Insert (Info, "    storage:        " & Logging.Image (T4 - T3));
         Messages.Insert (Info, "    buffers:        " & Logging.Image (T5 - T4));
         if Header.Mipmap_Levels = 0 then
            Messages.Insert (Info, "    generating mipmap:" & Logging.Image (T6 - T5));
         end if;
      end;
   exception
      when Error : Orka.KTX.Invalid_Enum_Error =>
         declare
            Message : constant String := Ada.Exceptions.Exception_Message (Error);
         begin
            raise Texture_Load_Error with Path & " has " & Message;
         end;
   end Execute;

   -----------------------------------------------------------------------------
   --                                 Loader                                  --
   -----------------------------------------------------------------------------

   type KTX_Loader is limited new Loaders.Loader with record
      Manager : Managers.Manager_Ptr;
   end record;

   overriding
   function Extension (Object : KTX_Loader) return Loaders.Extension_String is ("ktx");

   overriding
   procedure Load
     (Object   : KTX_Loader;
      Data     : Loaders.Resource_Data;
      Enqueue  : not null access procedure (Element : Jobs.Job_Ptr);
      Location : Locations.Location_Ptr)
   is
      Job : constant Jobs.Job_Ptr := new KTX_Load_Job'
        (Jobs.Abstract_Job with
          Data    => Data,
          Manager => Object.Manager);
   begin
      Enqueue (Job);
   end Load;

   function Create_Loader
     (Manager : Managers.Manager_Ptr) return Loaders.Loader_Ptr
   is (new KTX_Loader'(Manager => Manager));

   -----------------------------------------------------------------------------
   --                                 Writer                                  --
   -----------------------------------------------------------------------------

   procedure Write_Texture
     (Texture  : GL.Objects.Textures.Texture;
      Location : Locations.Writable_Location_Ptr;
      Path     : String)
   is
      package Textures renames GL.Objects.Textures;
      package Pointers is new Textures.Texture_Pointers (Byte_Pointers);

      Format    : GL.Pixels.Format    := GL.Pixels.RGBA;
      Data_Type : GL.Pixels.Data_Type := GL.Pixels.Float;
      --  Note: unused if texture is compressed

      Base_Level : constant := 0;

      use Ada.Streams;
      use all type GL.Low_Level.Enums.Texture_Kind;
      use type GL.Types.Size;

      Compressed : constant Boolean := Texture.Compressed;

      Header : Orka.KTX.Header (Compressed);

      function Convert
        (Bytes : in out GL.Types.UByte_Array_Access) return Byte_Array_Pointers.Pointer
      is
         Pointer : Byte_Array_Pointers.Pointer;
         Result  : constant Byte_Array_Access := new Byte_Array (1 .. Bytes'Length);

         procedure Free is new Ada.Unchecked_Deallocation
           (Object => GL.Types.UByte_Array, Name => GL.Types.UByte_Array_Access);
      begin
         for Index in Bytes'Range loop
            declare
               Target_Index : constant Stream_Element_Offset
                 := Stream_Element_Offset (Index - Bytes'First + 1);
            begin
               Result (Target_Index) := Stream_Element (Bytes (Index));
            end;
         end loop;
         Free (Bytes);
         Pointer.Set (Result);
         return Pointer;
      end Convert;

      function Convert
        (Bytes : in out Pointers.Element_Array_Access) return Byte_Array_Pointers.Pointer
      is
         Pointer : Byte_Array_Pointers.Pointer;
         Result  : constant Byte_Array_Access := new Byte_Array (1 .. Bytes'Length);
      begin
         Result.all := Bytes.all;
         Pointers.Free (Bytes);
         Pointer.Set (Result);
         return Pointer;
      end Convert;

      function Get_Data
        (Level : Textures.Mipmap_Level) return Byte_Array_Pointers.Pointer
      is
         Data : Pointers.Element_Array_Access;
      begin
         Data := Pointers.Get_Data (Texture, Level, 0, 0, 0,
           Texture.Width (Level), Texture.Height (Level), Texture.Depth (Level),
           Format, Data_Type);
         return Convert (Data);
      end Get_Data;

      function Get_Compressed_Data
        (Level : Textures.Mipmap_Level) return Byte_Array_Pointers.Pointer
      is
         Data : GL.Types.UByte_Array_Access;
      begin
         Data := Textures.Get_Compressed_Data (Texture, Level, 0, 0, 0,
           Texture.Width (Level), Texture.Height (Level), Texture.Depth (Level),
           Texture.Compressed_Format);
         return Convert (Data);
      end Get_Compressed_Data;
   begin
      Header.Kind := Texture.Kind;

      Header.Width := Texture.Width (Base_Level);
      case Texture.Kind is
         when Texture_3D =>
            Header.Height := Texture.Height (Base_Level);
            Header.Depth  := Texture.Depth (Base_Level);
         when Texture_2D | Texture_2D_Array | Texture_Cube_Map | Texture_Cube_Map_Array =>
            Header.Height := Texture.Height (Base_Level);
            Header.Depth  := 0;
         when Texture_1D | Texture_1D_Array =>
            Header.Height := 0;
            Header.Depth  := 0;
         when others =>
            raise Program_Error;
      end case;

      case Texture.Kind is
         when Texture_1D_Array =>
            Header.Array_Elements := Texture.Height (Base_Level);
         when Texture_2D_Array =>
            Header.Array_Elements := Texture.Depth (Base_Level);
         when Texture_Cube_Map_Array =>
            Header.Array_Elements := Texture.Depth (Base_Level) / 6;
         when Texture_1D | Texture_2D | Texture_3D | Texture_Cube_Map =>
            Header.Array_Elements := 0;
         when others =>
            raise Program_Error;
      end case;

      Header.Mipmap_Levels   := Texture.Mipmap_Levels;
      Header.Bytes_Key_Value := 0;

      if Compressed then
         Header.Compressed_Format := Texture.Compressed_Format;
      else
         declare
            Internal_Format : constant GL.Pixels.Internal_Format
              := Texture.Internal_Format;
         begin
            Format := GL.Pixels.Queries.Get_Texture_Format (Internal_Format, Texture.Kind);
            Data_Type := GL.Pixels.Queries.Get_Texture_Type (Internal_Format, Texture.Kind);

            Header.Internal_Format := Internal_Format;
            Header.Format    := Format;
            Header.Data_Type := Data_Type;
         end;
      end if;

      declare
         function Get_Level_Data
           (Level : Textures.Mipmap_Level) return Byte_Array_Pointers.Pointer
         is (if Compressed then Get_Compressed_Data (Level) else Get_Data (Level));

         Bytes : constant Byte_Array_Pointers.Pointer
           := Orka.KTX.Create_KTX_Bytes (Header, Get_Level_Data'Access);
      begin
         Location.Write_Data (Path, Bytes.Get);
      end;
   end Write_Texture;

end Orka.Resources.Textures.KTX;

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

with System;

with Ada.Exceptions;
with Ada.Real_Time;
with Ada.Unchecked_Deallocation;

with GL.Low_Level.Enums;
with GL.Types;
with GL.Pixels.Queries;

with Orka.Logging;
with Orka.KTX;

package body Orka.Resources.Textures.KTX is

   use Orka.Logging;
   package Messages is new Orka.Logging.Messages (Resource_Loader);

   type KTX_Load_Job is new Jobs.Abstract_Job and Jobs.GPU_Job with record
      Data    : Loaders.Resource_Data;
      Manager : Managers.Manager_Ptr;
   end record;

   overriding
   procedure Execute
     (Object  : KTX_Load_Job;
      Enqueue : not null access procedure (Element : Jobs.Job_Ptr));

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

   use all type Ada.Real_Time.Time;

   overriding
   procedure Execute
     (Object  : KTX_Load_Job;
      Enqueue : not null access procedure (Element : Jobs.Job_Ptr))
   is
      Bytes : Byte_Array_Pointers.Constant_Reference := Object.Data.Bytes.Get;
      Path  : String renames SU.To_String (Object.Data.Path);

      T1 : Ada.Real_Time.Time renames Object.Data.Start_Time;
      T2 : constant Ada.Real_Time.Time := Clock;

      use Ada.Streams;
      use GL.Low_Level.Enums;
      use type GL.Types.Size;

      T3, T4, T5, T6 : Ada.Real_Time.Time;
   begin
      if not Orka.KTX.Valid_Identifier (Bytes) then
         raise Texture_Load_Error with Path & " is not a KTX file";
      end if;

      declare
         Header : constant Orka.KTX.Header := Orka.KTX.Get_Header (Bytes);
         Levels : constant GL.Types.Size   := GL.Types.Size'Max (1, Header.Mipmap_Levels);

         Resource : constant Texture_Ptr := new Texture'(others => <>);
         Texture  : GL.Objects.Textures.Texture (Header.Kind);

         Width  : constant GL.Types.Size := Header.Width;
         Height :          GL.Types.Size := Header.Height;
         Depth  :          GL.Types.Size := Header.Depth;
      begin
         T3 := Clock;

         --  Allocate storage
         case Header.Kind is
            when Texture_2D_Array =>
               Depth := Header.Array_Elements;
            when Texture_1D_Array =>
               Height := Header.Array_Elements;
               pragma Assert (Depth = 0);
            when Texture_Cube_Map_Array =>
               --  For a cube map array, depth is the number of layer-faces
               Depth := Header.Array_Elements * 6;
            when Texture_3D =>
               null;
            when Texture_2D | Texture_Cube_Map =>
               pragma Assert (Depth = 0);
            when Texture_1D =>
               if Header.Compressed then
                  raise Texture_Load_Error with Path & " has unknown 1D compressed format";
               end if;
               pragma Assert (Height = 0);
               pragma Assert (Depth = 0);
            when others =>
               raise Program_Error;
         end case;

         if Header.Compressed then
            Texture.Allocate_Storage (Levels, 1, Header.Compressed_Format,
              Width, Height, Depth);
         else
            Texture.Allocate_Storage (Levels, 1, Header.Internal_Format,
              Width, Height, Depth);
         end if;

         case Header.Kind is
            when Texture_1D =>
               Height := 1;
               Depth  := 1;
            when Texture_1D_Array | Texture_2D =>
               Depth := 1;
            when Texture_2D_Array | Texture_3D =>
               null;
            when Texture_Cube_Map | Texture_Cube_Map_Array =>
               --  Texture_Cube_Map uses 2D storage, but 3D load operation
               --  according to table 8.15 of the OpenGL specification

               --  For a cube map, depth is the number of faces, for
               --  a cube map array, depth is the number of layer-faces
               Depth := GL.Types.Size'Max (1, Header.Array_Elements) * 6;
            when others =>
               raise Program_Error;
         end case;
         T4 := Clock;

         --  TODO Handle KTXorientation key value pair

         --  Upload texture data
         declare
            Image_Size_Index : Stream_Element_Offset
              := Orka.KTX.Get_Data_Offset (Bytes, Header.Bytes_Key_Value);

            Cube_Map : constant Boolean := Header.Kind = Texture_Cube_Map;
         begin
            for Level in 0 .. Levels - 1 loop
               declare
                  Face_Size : constant Natural := Orka.KTX.Get_Length (Bytes, Image_Size_Index);
                  --  If not Cube_Map, then Face_Size is the size of the whole level

                  Cube_Padding : constant Natural := 3 - ((Face_Size + 3) mod 4);
                  Image_Size   : constant Natural
                    := (if Cube_Map then (Face_Size + Cube_Padding) * 6 else Face_Size);
                  -- If Cube_Map then Levels = 1 so no need to add it to the expression

                  --  Compute size of the whole mipmap level
                  Mip_Padding : constant Natural := 3 - ((Image_Size + 3) mod 4);
                  Mipmap_Size : constant Natural := 4 + Image_Size + Mip_Padding;

                  Offset : constant Stream_Element_Offset := Image_Size_Index + 4;
                  pragma Assert
                    (Offset + Stream_Element_Offset (Image_Size) - 1 <= Bytes.Value'Last);
                  Image_Data : constant System.Address := Bytes (Offset)'Address;
                  --  TODO Unpack_Alignment must be 4, but Load_From_Data wants 1 | 2 | 4
                  --  depending on Header.Data_Type

                  Level_Width  : constant GL.Types.Size := Texture.Width  (Level);
                  Level_Height : constant GL.Types.Size := Texture.Height (Level);
                  Level_Depth  : constant GL.Types.Size := Texture.Depth  (Level);
               begin
                  if Header.Compressed then
                     Texture.Load_From_Data (Level, 0, 0, 0, Level_Width, Level_Height, Level_Depth,
                       Header.Compressed_Format, GL.Types.Int (Image_Size), Image_Data);
                  else
                     Texture.Load_From_Data (Level, 0, 0, 0, Level_Width, Level_Height, Level_Depth,
                       Header.Format, Header.Data_Type, Image_Data);
                  end if;

                  Image_Size_Index := Image_Size_Index + Stream_Element_Offset (Mipmap_Size);
               end;
            end loop;
         end;
         T5 := Clock;

         --  Generate a full mipmap pyramid if Mipmap_Levels = 0
         if Header.Mipmap_Levels = 0 then
            Texture.Generate_Mipmap;
         end if;
         T6 := Clock;

         Resource.Texture.Replace_Element (Texture);

         --  Register resource at the resource manager
         Object.Manager.Add_Resource (Path, Resource_Ptr (Resource));

         Messages.Insert (Info, "Loaded texture " & Path & " in " &
           Logging.Trim (Logging.Image (T6 - T1)));
         Messages.Insert (Info, "  size:   " &
            Logging.Trim (Width'Image) & " x " &
            Logging.Trim (Height'Image) & " x " &
            Logging.Trim (Depth'Image) &
            ", mipmap levels:" & Levels'Image);
         Messages.Insert (Info, "  kind:   " & Header.Kind'Image);
         if Header.Compressed then
            Messages.Insert (Info, "  format: " & Header.Compressed_Format'Image);
         else
            Messages.Insert (Info, "  format: " & Header.Internal_Format'Image);
         end if;

         Messages.Insert (Info, "  statistics:");
         Messages.Insert (Info, "    reading file:   " & Logging.Image (T2 - T1));
         Messages.Insert (Info, "    parsing header: " & Logging.Image (T3 - T2));
         Messages.Insert (Info, "    storage:        " & Logging.Image (T4 - T3));
         Messages.Insert (Info, "    buffers:        " & Logging.Image (T5 - T4));
         if Header.Mipmap_Levels = 0 then
            Messages.Insert (Info, "    generating mipmap:" & Logging.Image (T6 - T5));
         end if;
      end;
   exception
      when Error : Orka.KTX.Invalid_Enum_Error =>
         declare
            Message : constant String := Ada.Exceptions.Exception_Message (Error);
         begin
            raise Texture_Load_Error with Path & " has " & Message;
         end;
   end Execute;

   -----------------------------------------------------------------------------
   --                                 Loader                                  --
   -----------------------------------------------------------------------------

   type KTX_Loader is limited new Loaders.Loader with record
      Manager : Managers.Manager_Ptr;
   end record;

   overriding
   function Extension (Object : KTX_Loader) return Loaders.Extension_String is ("ktx");

   overriding
   procedure Load
     (Object   : KTX_Loader;
      Data     : Loaders.Resource_Data;
      Enqueue  : not null access procedure (Element : Jobs.Job_Ptr);
      Location : Locations.Location_Ptr)
   is
      Job : constant Jobs.Job_Ptr := new KTX_Load_Job'
        (Jobs.Abstract_Job with
          Data    => Data,
          Manager => Object.Manager);
   begin
      Enqueue (Job);
   end Load;

   function Create_Loader
     (Manager : Managers.Manager_Ptr) return Loaders.Loader_Ptr
   is (new KTX_Loader'(Manager => Manager));

   -----------------------------------------------------------------------------
   --                                 Writer                                  --
   -----------------------------------------------------------------------------

   procedure Write_Texture
     (Texture  : GL.Objects.Textures.Texture;
      Location : Locations.Writable_Location_Ptr;
      Path     : String)
   is
      package Textures renames GL.Objects.Textures;
      package Pointers is new Textures.Texture_Pointers (Byte_Pointers);

      Format    : GL.Pixels.Format    := GL.Pixels.RGBA;
      Data_Type : GL.Pixels.Data_Type := GL.Pixels.Float;
      --  Note: unused if texture is compressed

      Base_Level : constant := 0;

      use Ada.Streams;
      use all type GL.Low_Level.Enums.Texture_Kind;
      use type GL.Types.Size;

      Compressed : constant Boolean := Texture.Compressed;

      Header : Orka.KTX.Header (Compressed);

      function Convert
        (Bytes : in out GL.Types.UByte_Array_Access) return Byte_Array_Pointers.Pointer
      is
         Pointer : Byte_Array_Pointers.Pointer;
         Result  : constant Byte_Array_Access := new Byte_Array (1 .. Bytes'Length);

         procedure Free is new Ada.Unchecked_Deallocation
           (Object => GL.Types.UByte_Array, Name => GL.Types.UByte_Array_Access);
      begin
         for Index in Bytes'Range loop
            declare
               Target_Index : constant Stream_Element_Offset
                 := Stream_Element_Offset (Index - Bytes'First + 1);
            begin
               Result (Target_Index) := Stream_Element (Bytes (Index));
            end;
         end loop;
         Free (Bytes);
         Pointer.Set (Result);
         return Pointer;
      end Convert;

      function Convert
        (Bytes : in out Pointers.Element_Array_Access) return Byte_Array_Pointers.Pointer
      is
         Pointer : Byte_Array_Pointers.Pointer;
         Result  : constant Byte_Array_Access := new Byte_Array (1 .. Bytes'Length);
      begin
         Result.all := Bytes.all;
         Pointers.Free (Bytes);
         Pointer.Set (Result);
         return Pointer;
      end Convert;

      function Get_Data
        (Level : Textures.Mipmap_Level) return Byte_Array_Pointers.Pointer
      is
         Data : Pointers.Element_Array_Access;
      begin
         Data := Pointers.Get_Data (Texture, Level, 0, 0, 0,
           Texture.Width (Level), Texture.Height (Level), Texture.Depth (Level),
           Format, Data_Type);
         return Convert (Data);
      end Get_Data;

      function Get_Compressed_Data
        (Level : Textures.Mipmap_Level) return Byte_Array_Pointers.Pointer
      is
         Data : GL.Types.UByte_Array_Access;
      begin
         Data := Textures.Get_Compressed_Data (Texture, Level, 0, 0, 0,
           Texture.Width (Level), Texture.Height (Level), Texture.Depth (Level),
           Texture.Compressed_Format);
         return Convert (Data);
      end Get_Compressed_Data;
   begin
      Header.Kind := Texture.Kind;

      Header.Width := Texture.Width (Base_Level);
      case Texture.Kind is
         when Texture_3D =>
            Header.Height := Texture.Height (Base_Level);
            Header.Depth  := Texture.Depth (Base_Level);
         when Texture_2D | Texture_2D_Array | Texture_Cube_Map | Texture_Cube_Map_Array =>
            Header.Height := Texture.Height (Base_Level);
            Header.Depth  := 0;
         when Texture_1D | Texture_1D_Array =>
            Header.Height := 0;
            Header.Depth  := 0;
         when others =>
            raise Program_Error;
      end case;

      case Texture.Kind is
         when Texture_1D_Array =>
            Header.Array_Elements := Texture.Height (Base_Level);
         when Texture_2D_Array =>
            Header.Array_Elements := Texture.Depth (Base_Level);
         when Texture_Cube_Map_Array =>
            Header.Array_Elements := Texture.Depth (Base_Level) / 6;
         when Texture_1D | Texture_2D | Texture_3D | Texture_Cube_Map =>
            Header.Array_Elements := 0;
         when others =>
            raise Program_Error;
      end case;

      Header.Mipmap_Levels   := Texture.Mipmap_Levels;
      Header.Bytes_Key_Value := 0;

      if Compressed then
         Header.Compressed_Format := Texture.Compressed_Format;
      else
         declare
            Internal_Format : constant GL.Pixels.Internal_Format
              := Texture.Internal_Format;
         begin
            Format := GL.Pixels.Queries.Get_Texture_Format (Internal_Format, Texture.Kind);
            Data_Type := GL.Pixels.Queries.Get_Texture_Type (Internal_Format, Texture.Kind);

            Header.Internal_Format := Internal_Format;
            Header.Format    := Format;
            Header.Data_Type := Data_Type;
         end;
      end if;

      declare
         function Get_Level_Data
           (Level : Textures.Mipmap_Level) return Byte_Array_Pointers.Pointer
         is (if Compressed then Get_Compressed_Data (Level) else Get_Data (Level));

         Bytes : constant Byte_Array_Pointers.Pointer
           := Orka.KTX.Create_KTX_Bytes (Header, Get_Level_Data'Access);
      begin
         Location.Write_Data (Path, Bytes.Get);
      end;
   end Write_Texture;

end Orka.Resources.Textures.KTX;

Make some variables constant

orka: Make some variables constant

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


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

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

package body Util.Systems.DLLs is

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

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

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

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

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

   pragma Linker_Options ("-ldl");

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

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

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

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

end Util.Systems.DLLs;

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

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

package body Util.Systems.DLLs is

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

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

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

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

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

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

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

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

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

end Util.Systems.DLLs;

Move the linker option in the generated Util.Systems.Constants package


-----------------------------------------------------------------------
--  ADO Drivers -- Database Drivers
--  Copyright (C) 2010, 2011, 2012, 2013, 2015, 2016, 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 Util.Log.Loggers;
with Util.Systems.DLLs;

with System;
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Exceptions;

package body ADO.Drivers.Connections is

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

   --  Load the database driver.
   procedure Load_Driver (Name : in String);

   --  ------------------------------
   --  Get the driver index that corresponds to the driver for this database connection string.
   --  ------------------------------
   function Get_Driver (Config : in Configuration) return Driver_Index is
      Driver  : constant Driver_Access := Get_Driver (Config.Get_Driver);
   begin
      if Driver = null then
         return Driver_Index'First;
      else
         return Driver.Get_Driver_Index;
      end if;
   end Get_Driver;

   --  ------------------------------
   --  Create a new connection using the configuration parameters.
   --  ------------------------------
   procedure Create_Connection (Config : in Configuration'Class;
                                Result : in out Ref.Ref'Class) is
      Driver  : Driver_Access;
      Log_URI : constant String := Config.Get_Log_URI;
   begin
      Driver := Get_Driver (Config.Get_Driver);
      if Driver = null then
         Log.Error ("No driver found for connection {0}", Log_URI);
         raise ADO.Configs.Connection_Error with
           "Data source is not initialized: driver '" & Config.Get_Driver & "' not found";
      end if;
      Driver.Create_Connection (Config, Result);
      Log.Info ("Created connection to '{0}' -> {1}", Log_URI, Result.Value.Ident);

   exception
      when others =>
         Log.Info ("Failed to create connection to '{0}'", Log_URI);
         raise;

   end Create_Connection;

   --  Get the database driver index.
   function Get_Driver_Index (Database : in Database_Connection) return Driver_Index is
      Driver : constant ADO.Drivers.Connections.Driver_Access
         := Database_Connection'Class (Database).Get_Driver;
   begin
      return Driver.Get_Driver_Index;
   end Get_Driver_Index;

   package Driver_List is
     new Ada.Containers.Doubly_Linked_Lists (Element_Type => Driver_Access);

   Next_Index : Driver_Index := 1;
   Drivers    : Driver_List.List;

   --  ------------------------------
   --  Get the driver unique index.
   --  ------------------------------
   function Get_Driver_Index (D : in Driver) return Driver_Index is
   begin
      return D.Index;
   end Get_Driver_Index;

   --  ------------------------------
   --  Get the driver name.
   --  ------------------------------
   function Get_Driver_Name (D : in Driver) return String is
   begin
      return D.Name.all;
   end Get_Driver_Name;

   --  ------------------------------
   --  Register a database driver.
   --  ------------------------------
   procedure Register (Driver : in Driver_Access) is
   begin
      Log.Info ("Register driver {0}", Driver.Name.all);

      Driver_List.Prepend (Container => Drivers, New_Item => Driver);
      Driver.Index := Next_Index;
      Next_Index := Next_Index + 1;
   end Register;

   --  ------------------------------
   --  Load the database driver.
   --  ------------------------------
   procedure Load_Driver (Name : in String) is
      Lib    : constant String := "libada_ado_" & Name & Util.Systems.DLLs.Extension;
      Symbol : constant String := "ado__drivers__connections__" & Name & "__initialize";
      Handle : Util.Systems.DLLs.Handle;
      Addr   : System.Address;

   begin
      Log.Debug ("Loading driver {0}", Lib);
      Handle := Util.Systems.DLLs.Load (Lib);
      Addr := Util.Systems.DLLs.Get_Symbol (Handle, Symbol);

      declare
         procedure Init;
         pragma Import (C, Init);
         for Init'Address use Addr;
      begin
         Log.Info ("Initialising driver {0}", Lib);
         Init;
      end;
   exception
      when Util.Systems.DLLs.Not_Found =>
         Log.Error ("Driver for {0} was loaded but does not define the initialization symbol",
                    Name);

      when E : Util.Systems.DLLs.Load_Error =>
         Log.Error ("Driver for {0} was not found: {1}",
                    Name, Ada.Exceptions.Exception_Message (E));

   end Load_Driver;

   --  ------------------------------
   --  Get a database driver given its name.
   --  ------------------------------
   function Get_Driver (Name : in String) return Driver_Access is
   begin
      Log.Debug ("Get driver {0}", Name);

      if Name'Length = 0 then
         return null;
      end if;

      for Retry in 0 .. 2 loop
         if Retry = 1 then
            ADO.Drivers.Initialize;
         elsif Retry = 2 then
            Load_Driver (Name);
         end if;
         declare
            Iter : Driver_List.Cursor := Driver_List.First (Drivers);
         begin
            while Driver_List.Has_Element (Iter) loop
               declare
                  D : constant Driver_Access := Driver_List.Element (Iter);
               begin
                  if Name = D.Name.all then
                     return D;
                  end if;
               end;
               Driver_List.Next (Iter);
            end loop;
         end;
      end loop;
      return null;
   end Get_Driver;

end ADO.Drivers.Connections;

-----------------------------------------------------------------------
--  ADO Drivers -- Database Drivers
--  Copyright (C) 2010, 2011, 2012, 2013, 2015, 2016, 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 Util.Log.Loggers;
with Util.Systems.DLLs;

with System;
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Exceptions;

package body ADO.Drivers.Connections is

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

   --  Load the database driver.
   procedure Load_Driver (Name : in String);

   --  ------------------------------
   --  Get the driver index that corresponds to the driver for this database connection string.
   --  ------------------------------
   function Get_Driver (Config : in Configuration) return Driver_Index is
      Driver  : constant Driver_Access := Get_Driver (Config.Get_Driver);
   begin
      if Driver = null then
         return Driver_Index'First;
      else
         return Driver.Get_Driver_Index;
      end if;
   end Get_Driver;

   --  ------------------------------
   --  Create a new connection using the configuration parameters.
   --  ------------------------------
   procedure Create_Connection (Config : in Configuration'Class;
                                Result : in out Ref.Ref'Class) is
      Driver  : Driver_Access;
      Log_URI : constant String := Config.Get_Log_URI;
   begin
      Driver := Get_Driver (Config.Get_Driver);
      if Driver = null then
         Log.Error ("No driver found for connection {0}", Log_URI);
         raise ADO.Configs.Connection_Error with
           "Data source is not initialized: driver '" & Config.Get_Driver & "' not found";
      end if;
      Driver.Create_Connection (Config, Result);
      Log.Info ("Created connection to '{0}' -> {1}", Log_URI, Result.Value.Ident);

   exception
      when others =>
         Log.Info ("Failed to create connection to '{0}'", Log_URI);
         raise;

   end Create_Connection;

   --  ------------------------------
   --  Get the database driver index.
   --  ------------------------------
   function Get_Driver_Index (Database : in Database_Connection) return Driver_Index is
      Driver : constant ADO.Drivers.Connections.Driver_Access
         := Database_Connection'Class (Database).Get_Driver;
   begin
      return Driver.Get_Driver_Index;
   end Get_Driver_Index;

   package Driver_List is
     new Ada.Containers.Doubly_Linked_Lists (Element_Type => Driver_Access);

   Next_Index : Driver_Index := 1;
   Drivers    : Driver_List.List;

   --  ------------------------------
   --  Get the driver unique index.
   --  ------------------------------
   function Get_Driver_Index (D : in Driver) return Driver_Index is
   begin
      return D.Index;
   end Get_Driver_Index;

   --  ------------------------------
   --  Get the driver name.
   --  ------------------------------
   function Get_Driver_Name (D : in Driver) return String is
   begin
      return D.Name.all;
   end Get_Driver_Name;

   --  ------------------------------
   --  Register a database driver.
   --  ------------------------------
   procedure Register (Driver : in Driver_Access) is
   begin
      Log.Info ("Register driver {0}", Driver.Name.all);

      Driver_List.Prepend (Container => Drivers, New_Item => Driver);
      Driver.Index := Next_Index;
      Next_Index := Next_Index + 1;
   end Register;

   --  ------------------------------
   --  Load the database driver.
   --  ------------------------------
   procedure Load_Driver (Name : in String) is
      Lib    : constant String := "libada_ado_" & Name & Util.Systems.DLLs.Extension;
      Symbol : constant String := "ado__drivers__connections__" & Name & "__initialize";
      Handle : Util.Systems.DLLs.Handle;
      Addr   : System.Address;
      Dynamic_Load : constant String := Get_Config (ADO.Configs.DYNAMIC_DRIVER_LOAD);
   begin
      if Dynamic_Load /= "1" and Dynamic_Load /= "true" then
         Log.Warn ("Dynamic loading of driver '{0}' is disabled", Name);
         return;
      end if;
      Log.Debug ("Loading driver '{0}' from {1}", Name, Lib);
      Handle := Util.Systems.DLLs.Load (Lib);
      Addr := Util.Systems.DLLs.Get_Symbol (Handle, Symbol);

      declare
         procedure Init;
         pragma Import (C, Init);
         for Init'Address use Addr;
      begin
         Log.Info ("Initialising driver {0}", Lib);
         Init;
      end;
   exception
      when Util.Systems.DLLs.Not_Found =>
         Log.Error ("Driver for {0} was loaded but does not define the initialization symbol",
                    Name);

      when E : Util.Systems.DLLs.Load_Error =>
         Log.Error ("Driver for {0} was not found: {1}",
                    Name, Ada.Exceptions.Exception_Message (E));

   end Load_Driver;

   --  ------------------------------
   --  Get a database driver given its name.
   --  ------------------------------
   function Get_Driver (Name : in String) return Driver_Access is
   begin
      Log.Debug ("Get driver {0}", Name);

      if Name'Length = 0 then
         return null;
      end if;

      for Retry in 0 .. 2 loop
         if Retry = 1 then
            ADO.Drivers.Initialize;
         elsif Retry = 2 then
            Load_Driver (Name);
         end if;
         declare
            Iter : Driver_List.Cursor := Driver_List.First (Drivers);
         begin
            while Driver_List.Has_Element (Iter) loop
               declare
                  D : constant Driver_Access := Driver_List.Element (Iter);
               begin
                  if Name = D.Name.all then
                     return D;
                  end if;
               end;
               Driver_List.Next (Iter);
            end loop;
         end;
      end loop;
      return null;
   end Get_Driver;

end ADO.Drivers.Connections;

Check for DYNAMIC_DRIVER_LOAD configuration parameter to test if we are allowed to load dynamically a database driver


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

package Glfw.Input.Keys is
   pragma Preelaborate;

   type Action is (Release, Press, Repeat);

   type Key is (Unknown,
                Space,
                Apostrophe,
                Comma,
                Minus,
                Period,
                Slash,
                Key_0,
                Key_1,
                Key_2,
                Key_3,
                Key_4,
                Key_5,
                Key_6,
                Key_7,
                Key_8,
                Key_9,
                Semicolon,
                Equal,
                A,
                B,
                C,
                D,
                E,
                F,
                G,
                H,
                I,
                J,
                K,
                L,
                M,
                N,
                O,
                P,
                Q,
                R,
                S,
                T,
                U,
                V,
                W,
                X,
                Y,
                Z,
                Left_Bracket,
                Backslash,
                Right_Bracket,
                Grave_Accent,
                World_1,
                World_2,
                Escape,
                Enter,
                Tab,
                Backspace,
                Insert,
                Delete,
                Right,
                Left,
                Down,
                Up,
                Page_Up,
                Page_Down,
                Home,
                Key_End,
                Caps_Lock,
                Scroll_Lock,
                Print_Screen,
                Pause,
                F1,
                F2,
                F3,
                F4,
                F5,
                F6,
                F7,
                F8,
                F9,
                F10,
                F11,
                F12,
                F13,
                F14,
                F15,
                F16,
                F17,
                F18,
                F19,
                F20,
                F21,
                F22,
                F23,
                F24,
                F25,
                Numpad_0,
                Numpad_1,
                Numpad_2,
                Numpad_3,
                Numpad_4,
                Numpad_5,
                Numpad_6,
                Numpad_7,
                Numpad_8,
                Numpad_9,
                Numpad_Decimal,
                Numpad_Divide,
                Numpad_Multiply,
                Numpad_Substract,
                Numpad_Add,
                Numpad_Enter,
                Numpad_Equal,
                Left_Shift,
                Left_Control,
                Left_Alt,
                Left_Super,
                Right_Shift,
                Right_Control,
                Right_Alt,
                Right_Super,
                Menu);

   type Modifiers is record
      Shift   : Boolean;
      Control : Boolean;
      Alt     : Boolean;
      Super   : Boolean;
   end record;

   type Scancode is new Interfaces.C.int;

private
   for Action use (Release => 0,
                   Press   => 1,
                   Repeat  => 2);
   for Action'Size use Interfaces.C.int'Size;

   for Key use (Unknown       => -1,
                Space         => 32,
                Apostrophe    => 39,
                Comma         => 44,
                Minus         => 45,
                Period        => 46,
                Slash         => 47,
                Key_0         => 48,
                Key_1         => 49,
                Key_2         => 50,
                Key_3         => 51,
                Key_4         => 52,
                Key_5         => 53,
                Key_6         => 54,
                Key_7         => 55,
                Key_8         => 56,
                Key_9         => 57,
                Semicolon     => 59,
                Equal         => 61,
                A             => 65,
                B             => 66,
                C             => 67,
                D             => 68,
                E             => 69,
                F             => 70,
                G             => 71,
                H             => 72,
                I             => 73,
                J             => 74,
                K             => 75,
                L             => 76,
                M             => 77,
                N             => 78,
                O             => 79,
                P             => 80,
                Q             => 81,
                R             => 82,
                S             => 83,
                T             => 84,
                U             => 85,
                V             => 86,
                W             => 87,
                X             => 88,
                Y             => 89,
                Z             => 90,
                Left_Bracket  => 91,
                Backslash     => 92,
                Right_Bracket => 93,
                Grave_Accent  => 96,
                World_1       => 161,
                World_2       => 162,
                Escape        => 256,
                Enter         => 257,
                Tab           => 258,
                Backspace     => 259,
                Insert        => 260,
                Delete        => 261,
                Right         => 262,
                Left          => 263,
                Down          => 264,
                Up            => 265,
                Page_Up       => 266,
                Page_Down     => 267,
                Home          => 268,
                Key_End       => 269,
                Caps_Lock     => 280,
                Scroll_Lock   => 281,
                Print_Screen  => 283,
                Pause         => 284,
                F1            => 290,
                F2            => 291,
                F3            => 292,
                F4            => 293,
                F5            => 294,
                F6            => 295,
                F7            => 296,
                F8            => 297,
                F9            => 298,
                F10           => 299,
                F11           => 300,
                F12           => 301,
                F13           => 302,
                F14           => 303,
                F15           => 304,
                F16           => 305,
                F17           => 306,
                F18           => 307,
                F19           => 308,
                F20           => 309,
                F21           => 310,
                F22           => 311,
                F23           => 312,
                F24           => 313,
                F25           => 314,
                Numpad_0      => 320,
                Numpad_1      => 321,
                Numpad_2      => 322,
                Numpad_3      => 323,
                Numpad_4      => 324,
                Numpad_5      => 325,
                Numpad_6      => 326,
                Numpad_7      => 327,
                Numpad_8      => 328,
                Numpad_9      => 329,
                Numpad_Decimal   => 330,
                Numpad_Divide    => 331,
                Numpad_Multiply  => 332,
                Numpad_Substract => 333,
                Numpad_Add       => 334,
                Numpad_Enter     => 335,
                Numpad_Equal     => 336,
                Left_Shift       => 340,
                Left_Control     => 341,
                Left_Alt         => 342,
                Left_Super       => 343,
                Right_Shift      => 344,
                Right_Control    => 345,
                Right_Alt        => 346,
                Right_Super      => 347,
                Menu             => 348);
   for Key'Size use Interfaces.C.int'Size;

   for Modifiers use record
      Shift   at 0 range 0 .. 0;
      Control at 0 range 1 .. 1;
      Alt     at 0 range 2 .. 2;
      Super   at 0 range 3 .. 3;
   end record;
   pragma Warnings (Off);
   for Modifiers'Size use Interfaces.C.int'Size;
   pragma Warnings (On);
   pragma Convention (C_Pass_By_Copy, Modifiers);

   for Scancode'Size use Interfaces.C.int'Size;

end Glfw.Input.Keys;

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

package Glfw.Input.Keys is
   pragma Preelaborate;

   type Action is (Release, Press, Repeat);

   type Key is (Unknown,
                Space,
                Apostrophe,
                Comma,
                Minus,
                Period,
                Slash,
                Key_0,
                Key_1,
                Key_2,
                Key_3,
                Key_4,
                Key_5,
                Key_6,
                Key_7,
                Key_8,
                Key_9,
                Semicolon,
                Equal,
                A,
                B,
                C,
                D,
                E,
                F,
                G,
                H,
                I,
                J,
                K,
                L,
                M,
                N,
                O,
                P,
                Q,
                R,
                S,
                T,
                U,
                V,
                W,
                X,
                Y,
                Z,
                Left_Bracket,
                Backslash,
                Right_Bracket,
                Grave_Accent,
                World_1,
                World_2,
                Escape,
                Enter,
                Tab,
                Backspace,
                Insert,
                Delete,
                Right,
                Left,
                Down,
                Up,
                Page_Up,
                Page_Down,
                Home,
                Key_End,
                Caps_Lock,
                Scroll_Lock,
                Num_Lock,
                Print_Screen,
                Pause,
                F1,
                F2,
                F3,
                F4,
                F5,
                F6,
                F7,
                F8,
                F9,
                F10,
                F11,
                F12,
                F13,
                F14,
                F15,
                F16,
                F17,
                F18,
                F19,
                F20,
                F21,
                F22,
                F23,
                F24,
                F25,
                Numpad_0,
                Numpad_1,
                Numpad_2,
                Numpad_3,
                Numpad_4,
                Numpad_5,
                Numpad_6,
                Numpad_7,
                Numpad_8,
                Numpad_9,
                Numpad_Decimal,
                Numpad_Divide,
                Numpad_Multiply,
                Numpad_Substract,
                Numpad_Add,
                Numpad_Enter,
                Numpad_Equal,
                Left_Shift,
                Left_Control,
                Left_Alt,
                Left_Super,
                Right_Shift,
                Right_Control,
                Right_Alt,
                Right_Super,
                Menu);

   type Modifiers is record
      Shift   : Boolean;
      Control : Boolean;
      Alt     : Boolean;
      Super   : Boolean;
   end record;

   type Scancode is new Interfaces.C.int;

private
   for Action use (Release => 0,
                   Press   => 1,
                   Repeat  => 2);
   for Action'Size use Interfaces.C.int'Size;

   for Key use (Unknown       => -1,
                Space         => 32,
                Apostrophe    => 39,
                Comma         => 44,
                Minus         => 45,
                Period        => 46,
                Slash         => 47,
                Key_0         => 48,
                Key_1         => 49,
                Key_2         => 50,
                Key_3         => 51,
                Key_4         => 52,
                Key_5         => 53,
                Key_6         => 54,
                Key_7         => 55,
                Key_8         => 56,
                Key_9         => 57,
                Semicolon     => 59,
                Equal         => 61,
                A             => 65,
                B             => 66,
                C             => 67,
                D             => 68,
                E             => 69,
                F             => 70,
                G             => 71,
                H             => 72,
                I             => 73,
                J             => 74,
                K             => 75,
                L             => 76,
                M             => 77,
                N             => 78,
                O             => 79,
                P             => 80,
                Q             => 81,
                R             => 82,
                S             => 83,
                T             => 84,
                U             => 85,
                V             => 86,
                W             => 87,
                X             => 88,
                Y             => 89,
                Z             => 90,
                Left_Bracket  => 91,
                Backslash     => 92,
                Right_Bracket => 93,
                Grave_Accent  => 96,
                World_1       => 161,
                World_2       => 162,
                Escape        => 256,
                Enter         => 257,
                Tab           => 258,
                Backspace     => 259,
                Insert        => 260,
                Delete        => 261,
                Right         => 262,
                Left          => 263,
                Down          => 264,
                Up            => 265,
                Page_Up       => 266,
                Page_Down     => 267,
                Home          => 268,
                Key_End       => 269,
                Caps_Lock     => 280,
                Scroll_Lock   => 281,
                Num_Lock      => 282,
                Print_Screen  => 283,
                Pause         => 284,
                F1            => 290,
                F2            => 291,
                F3            => 292,
                F4            => 293,
                F5            => 294,
                F6            => 295,
                F7            => 296,
                F8            => 297,
                F9            => 298,
                F10           => 299,
                F11           => 300,
                F12           => 301,
                F13           => 302,
                F14           => 303,
                F15           => 304,
                F16           => 305,
                F17           => 306,
                F18           => 307,
                F19           => 308,
                F20           => 309,
                F21           => 310,
                F22           => 311,
                F23           => 312,
                F24           => 313,
                F25           => 314,
                Numpad_0      => 320,
                Numpad_1      => 321,
                Numpad_2      => 322,
                Numpad_3      => 323,
                Numpad_4      => 324,
                Numpad_5      => 325,
                Numpad_6      => 326,
                Numpad_7      => 327,
                Numpad_8      => 328,
                Numpad_9      => 329,
                Numpad_Decimal   => 330,
                Numpad_Divide    => 331,
                Numpad_Multiply  => 332,
                Numpad_Substract => 333,
                Numpad_Add       => 334,
                Numpad_Enter     => 335,
                Numpad_Equal     => 336,
                Left_Shift       => 340,
                Left_Control     => 341,
                Left_Alt         => 342,
                Left_Super       => 343,
                Right_Shift      => 344,
                Right_Control    => 345,
                Right_Alt        => 346,
                Right_Super      => 347,
                Menu             => 348);
   for Key'Size use Interfaces.C.int'Size;

   for Modifiers use record
      Shift   at 0 range 0 .. 0;
      Control at 0 range 1 .. 1;
      Alt     at 0 range 2 .. 2;
      Super   at 0 range 3 .. 3;
   end record;
   pragma Warnings (Off);
   for Modifiers'Size use Interfaces.C.int'Size;
   pragma Warnings (On);
   pragma Convention (C_Pass_By_Copy, Modifiers);

   for Scancode'Size use Interfaces.C.int'Size;

end Glfw.Input.Keys;

Add missing Num_Lock key

glfw: Add missing Num_Lock key

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


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

package body Util.Beans.Objects.Records is

   use Util.Concurrent.Counters;

   --  ------------------------------
   --  Bean Type
   --  ------------------------------
   type Record_Bean_Type is new Bean_Type with null record;

   --  Get the type name
   function Get_Name (Type_Def : in Record_Bean_Type) return String;

   --  Convert the value into a boolean.
   function To_Boolean (Type_Def : in Record_Bean_Type;
                        Value    : in Object_Value) return Boolean;

   --  ------------------------------
   --  Get the type name
   --  ------------------------------
   function Get_Name (Type_Def : in Record_Bean_Type) return String is
      pragma Unreferenced (Type_Def);
   begin
      return "Bean_Record";
   end Get_Name;

   --  ------------------------------
   --  Convert the value into a boolean.
   --  ------------------------------
   function To_Boolean (Type_Def : in Record_Bean_Type;
                        Value    : in Object_Value) return Boolean is
      pragma Unreferenced (Type_Def);
   begin
      return Value.Proxy /= null;
   end To_Boolean;

   Bn_Type : aliased Record_Bean_Type := Record_Bean_Type '(others => <>);

   --  ------------------------------
   --  Create an object which holds a record of the type <b>Element_Type</b>.
   --  ------------------------------
   function Create return Object is
   begin
      return Object '(Controlled with
        V => Object_Value '(Of_Type => TYPE_BEAN,
                            Proxy   => new Element_Proxy '(Ref_Counter => ONE,
                                                           others => <>)),
        Type_Def   => Bn_Type'Access);
   end Create;

   --  ------------------------------
   --  Create an object which is initialized with the given value.
   --  ------------------------------
   function To_Object (Value : in Element_Type) return Object is
   begin
      return Object '(Controlled with
        V => Object_Value '(Of_Type => TYPE_BEAN,
                            Proxy   => new Element_Proxy '(Ref_Counter => ONE,
                                                           Value       => Value)),
        Type_Def   => Bn_Type'Access);
   end To_Object;

   --  ------------------------------
   --  Returns the element
   --  ------------------------------
   function To_Element (Value : in Object) return Element_Type is
   begin
      if Value.V.Of_Type /= TYPE_BEAN then
         raise Conversion_Error with "Object is not a bean";
      end if;
      declare
         Proxy : constant Bean_Proxy_Access := Value.V.Proxy;
      begin
         if Proxy = null then
            raise Conversion_Error with "Object is null";
         end if;
         if not (Proxy.all in Element_Proxy'Class) then
            raise Conversion_Error with "Object is not of the good type";
         end if;
         return Element_Proxy'Class (Proxy.all).Value;
      end;
   end To_Element;

   --  ------------------------------
   --  Returns an access to the element.
   --  ------------------------------
   function To_Element_Access (Value : in Object) return Element_Type_Access is
   begin
      if Value.V.Of_Type /= TYPE_BEAN then
         return null;
      end if;
      declare
         Proxy : constant Bean_Proxy_Access := Value.V.Proxy;
      begin
         if Proxy = null then
            return null;
         end if;
         if not (Proxy.all in Element_Proxy'Class) then
            return null;
         end if;
         return Element_Proxy'Class (Proxy.all).Value'Access;
      end;
   end To_Element_Access;

end Util.Beans.Objects.Records;

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

package body Util.Beans.Objects.Records is

   use Util.Concurrent.Counters;

   --  ------------------------------
   --  Bean Type
   --  ------------------------------
   type Record_Bean_Type is new Bean_Type with null record;

   --  Get the type name
   function Get_Name (Type_Def : in Record_Bean_Type) return String;

   --  Convert the value into a boolean.
   function To_Boolean (Type_Def : in Record_Bean_Type;
                        Value    : in Object_Value) return Boolean;

   --  ------------------------------
   --  Get the type name
   --  ------------------------------
   function Get_Name (Type_Def : in Record_Bean_Type) return String is
      pragma Unreferenced (Type_Def);
   begin
      return "Bean_Record";
   end Get_Name;

   --  ------------------------------
   --  Convert the value into a boolean.
   --  ------------------------------
   function To_Boolean (Type_Def : in Record_Bean_Type;
                        Value    : in Object_Value) return Boolean is
      pragma Unreferenced (Type_Def);
   begin
      return Value.Proxy /= null;
   end To_Boolean;

   Bn_Type : aliased Record_Bean_Type := Record_Bean_Type '(null record);

   --  ------------------------------
   --  Create an object which holds a record of the type <b>Element_Type</b>.
   --  ------------------------------
   function Create return Object is
   begin
      return Object '(Controlled with
        V => Object_Value '(Of_Type => TYPE_BEAN,
                            Proxy   => new Element_Proxy '(Ref_Counter => ONE,
                                                           others => <>)),
        Type_Def   => Bn_Type'Access);
   end Create;

   --  ------------------------------
   --  Create an object which is initialized with the given value.
   --  ------------------------------
   function To_Object (Value : in Element_Type) return Object is
   begin
      return Object '(Controlled with
        V => Object_Value '(Of_Type => TYPE_BEAN,
                            Proxy   => new Element_Proxy '(Ref_Counter => ONE,
                                                           Value       => Value)),
        Type_Def   => Bn_Type'Access);
   end To_Object;

   --  ------------------------------
   --  Returns the element
   --  ------------------------------
   function To_Element (Value : in Object) return Element_Type is
   begin
      if Value.V.Of_Type /= TYPE_BEAN then
         raise Conversion_Error with "Object is not a bean";
      end if;
      declare
         Proxy : constant Bean_Proxy_Access := Value.V.Proxy;
      begin
         if Proxy = null then
            raise Conversion_Error with "Object is null";
         end if;
         if not (Proxy.all in Element_Proxy'Class) then
            raise Conversion_Error with "Object is not of the good type";
         end if;
         return Element_Proxy'Class (Proxy.all).Value;
      end;
   end To_Element;

   --  ------------------------------
   --  Returns an access to the element.
   --  ------------------------------
   function To_Element_Access (Value : in Object) return Element_Type_Access is
   begin
      if Value.V.Of_Type /= TYPE_BEAN then
         return null;
      end if;
      declare
         Proxy : constant Bean_Proxy_Access := Value.V.Proxy;
      begin
         if Proxy = null then
            return null;
         end if;
         if not (Proxy.all in Element_Proxy'Class) then
            return null;
         end if;
         return Element_Proxy'Class (Proxy.all).Value'Access;
      end;
   end To_Element_Access;

end Util.Beans.Objects.Records;

Fix new GNAT compilation warning in initialization records: use null record