--  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, Header.Compressed_Format,
              Width, Height, Depth);
         else
            Texture.Allocate_Storage (Levels, Header.Internal_Format,
              Width, Height, Depth);
         end if;

         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
               begin
                  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;

                  if Header.Compressed then
                     Texture.Load_From_Data (Level, 0, 0, 0, Width, Height, Depth,
                       Header.Compressed_Format, GL.Types.Int (Image_Size), Image_Data);
                  else
                     Texture.Load_From_Data (Level, 0, 0, 0, Width, Height, 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, "  dimensions: " &
            Logging.Trim (Header.Width'Image) & " x " &
            Logging.Trim (Header.Height'Image) & " x " &
            Logging.Trim (Header.Depth'Image) &
            ", array length:" & Header.Array_Elements'Image &
            ", mipmap levels:" & Levels'Image);
         Messages.Insert (Info, "  kind: " & Header.Kind'Image);
         if Header.Compressed then
            Messages.Insert (Info, "  compressed format: " & Header.Compressed_Format'Image);
         else
            Messages.Insert (Info, "  internal: " & Header.Internal_Format'Image);
            Messages.Insert (Info, "  format: " & Header.Format'Image);
            Messages.Insert (Info, "  type: " & Header.Data_Type'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

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

      Compressed : constant Boolean := Texture.Compressed (0);

      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 (0));
         return Convert (Data);
      end Get_Compressed_Data;
   begin
      Header.Kind := Texture.Kind;

      Header.Width := Texture.Width (0);
      case Texture.Kind is
         when Texture_3D =>
            Header.Height := Texture.Height (0);
            Header.Depth  := Texture.Depth (0);
         when Texture_2D | Texture_2D_Array | Texture_Cube_Map | Texture_Cube_Map_Array =>
            Header.Height := Texture.Height (0);
            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 (0);
         when Texture_2D_Array =>
            Header.Array_Elements := Texture.Depth (0);
         when Texture_Cube_Map_Array =>
            Header.Array_Elements := Texture.Depth (0) / 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   := 1;
      Header.Bytes_Key_Value := 0;

      if Compressed then
         Header.Compressed_Format := Texture.Compressed_Format (0);
      else
         declare
            Internal_Format : constant GL.Pixels.Internal_Format
              := Texture.Internal_Format (0);
         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
         Data : constant Byte_Array_Pointers.Pointer
           := (if Compressed then Get_Compressed_Data (0) else Get_Data (0));

         Bytes : constant Byte_Array_Pointers.Pointer
           := Orka.KTX.Create_KTX_Bytes (Header, Data.Get);
      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, Header.Compressed_Format,
              Width, Height, Depth);
         else
            Texture.Allocate_Storage (Levels, Header.Internal_Format,
              Width, Height, Depth);
         end if;

         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
               begin
                  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;

                  if Header.Compressed then
                     Texture.Load_From_Data (Level, 0, 0, 0, Width, Height, Depth,
                       Header.Compressed_Format, GL.Types.Int (Image_Size), Image_Data);
                  else
                     Texture.Load_From_Data (Level, 0, 0, 0, Width, Height, 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

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

      Compressed : constant Boolean := Texture.Compressed (0);

      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 (0));
         return Convert (Data);
      end Get_Compressed_Data;
   begin
      Header.Kind := Texture.Kind;

      Header.Width := Texture.Width (0);
      case Texture.Kind is
         when Texture_3D =>
            Header.Height := Texture.Height (0);
            Header.Depth  := Texture.Depth (0);
         when Texture_2D | Texture_2D_Array | Texture_Cube_Map | Texture_Cube_Map_Array =>
            Header.Height := Texture.Height (0);
            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 (0);
         when Texture_2D_Array =>
            Header.Array_Elements := Texture.Depth (0);
         when Texture_Cube_Map_Array =>
            Header.Array_Elements := Texture.Depth (0) / 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   := 1;
      Header.Bytes_Key_Value := 0;

      if Compressed then
         Header.Compressed_Format := Texture.Compressed_Format (0);
      else
         declare
            Internal_Format : constant GL.Pixels.Internal_Format
              := Texture.Internal_Format (0);
         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
         Data : constant Byte_Array_Pointers.Pointer
           := (if Compressed then Get_Compressed_Data (0) else Get_Data (0));

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

end Orka.Resources.Textures.KTX;

orka: Simplify debug output of KTX loader a bit

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


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

with MAT.Types;
with MAT.Memory;
with MAT.Expressions.Parser;
package body MAT.Expressions is

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Node_Type,
                                     Name   => Node_Type_Access);

   --  Destroy recursively the node, releasing the storage.
   procedure Destroy (Node : in out Node_Type_Access);

   --  ------------------------------
   --  Create a NOT expression node.
   --  ------------------------------
   function Create_Not (Expr : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_NOT,
                                    Expr        => Expr.Node);
      Util.Concurrent.Counters.Increment (Expr.Node.Ref_Counter);
      return Result;
   end Create_Not;

   --  ------------------------------
   --  Create a AND expression node.
   --  ------------------------------
   function Create_And (Left  : in Expression_Type;
                        Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_AND,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_And;

   --  ------------------------------
   --  Create a OR expression node.
   --  ------------------------------
   function Create_Or (Left  : in Expression_Type;
                       Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_OR,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_Or;

   --  ------------------------------
   --  Create an INSIDE expression node.
   --  ------------------------------
   function Create_Inside (Name : in Ada.Strings.Unbounded.Unbounded_String;
                           Kind : in Inside_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_INSIDE,
                                    Name        => Name,
                                    Inside      => Kind);
      return Result;
   end Create_Inside;

   --  ------------------------------
   --  Create an size range expression node.
   --  ------------------------------
   function Create_Size (Min : in MAT.Types.Target_Size;
                         Max : in MAT.Types.Target_Size) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_SIZE,
                                    Min_Size    => Min,
                                    Max_Size    => Max);
      return Result;
   end Create_Size;

   --  ------------------------------
   --  Create an addr range expression node.
   --  ------------------------------
   function Create_Addr (Min : in MAT.Types.Target_Addr;
                         Max : in MAT.Types.Target_Addr) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_ADDR,
                                    Min_Addr    => Min,
                                    Max_Addr    => Max);
      return Result;
   end Create_Addr;

   --  ------------------------------
   --  Create an time range expression node.
   --  ------------------------------
   function Create_Time (Min : in MAT.Types.Target_Tick_Ref;
                         Max : in MAT.Types.Target_Tick_Ref) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_TIME,
                                    Min_Time    => Min,
                                    Max_Time    => Max);
      return Result;
   end Create_Time;

   --  ------------------------------
   --  Create an event ID range expression node.
   --  ------------------------------
   function Create_Event (Min : in MAT.Events.Targets.Event_Id_Type;
                          Max : in MAT.Events.Targets.Event_Id_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_EVENT,
                                    Min_Event   => Min,
                                    Max_Event   => Max);
      return Result;
   end Create_Event;

   --  ------------------------------
   --  Evaluate the expression to check if the memory slot described by the
   --  context is selected.  Returns True if the memory slot is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Expression_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean is
   begin
      if Node.Node = null then
         return True;
      else
         return Is_Selected (Node.Node.all, Addr, Allocation);
      end if;
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the expression to check if the event described by the
   --  context is selected.  Returns True if the event is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Expression_Type;
                         Event      : in MAT.Events.Targets.Probe_Event_Type) return Boolean is
   begin
      return Is_Selected (Node.Node.all, Event);
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the node against the context.  Returns True if the node expression
   --  selects the memory slot defined by the context.
   --  ------------------------------
   function Is_Selected (Node       : in Node_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean is
      use type MAT.Types.Target_Size;
      use type MAT.Types.Target_Tick_Ref;
   begin
      case Node.Kind is
         when N_NOT =>
            return not Is_Selected (Node.Expr.all, Addr, Allocation);

         when N_AND =>
            return Is_Selected (Node.Left.all, Addr, Allocation)
              and then Is_Selected (Node.Right.all, Addr, Allocation);

         when N_OR =>
            return Is_Selected (Node.Left.all, Addr, Allocation)
              or else Is_Selected (Node.Right.all, Addr, Allocation);

         when N_RANGE_SIZE =>
            return Allocation.Size >= Node.Min_Size
              and Allocation.Size <= Node.Max_Size;

         when N_RANGE_ADDR =>
            return Addr >= Node.Min_Addr
              and Addr <= Node.Max_Addr;

         when N_RANGE_TIME =>
            return Allocation.Time >= Node.Min_Time
              and Allocation.Time <= Node.Max_Time;

         when others =>
            return False;

      end case;
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the expression to check if the event described by the
   --  context is selected.  Returns True if the event is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Node_Type;
                         Event      : in MAT.Events.Targets.Probe_Event_Type) return Boolean is
      use type MAT.Types.Target_Size;
      use type MAT.Types.Target_Tick_Ref;
   begin
      case Node.Kind is
         when N_NOT =>
            return not Is_Selected (Node.Expr.all, Event);

         when N_AND =>
            return Is_Selected (Node.Left.all, Event)
              and then Is_Selected (Node.Right.all, Event);

         when N_OR =>
            return Is_Selected (Node.Left.all, Event)
              or else Is_Selected (Node.Right.all, Event);

         when N_RANGE_SIZE =>
            return Event.Size >= Node.Min_Size
              and Event.Size <= Node.Max_Size;

         when N_RANGE_ADDR =>
            return Event.Addr >= Node.Min_Addr
              and Event.Addr <= Node.Max_Addr;

         when N_RANGE_TIME =>
            return Event.Time >= Node.Min_Time
              and Event.Time <= Node.Max_Time;

         when N_EVENT =>
            return Event.Id >= Node.Min_Event
              and Event.Id <= Node.Max_Event;

         when others =>
            return False;

      end case;
   end Is_Selected;

   --  ------------------------------
   --  Parse the string and return the expression tree.
   --  ------------------------------
   function Parse (Expr : in String) return Expression_Type is
   begin
      return MAT.Expressions.Parser.Parse (Expr);
   end Parse;

   --  ------------------------------
   --  Destroy recursively the node, releasing the storage.
   --  ------------------------------
   procedure Destroy (Node : in out Node_Type_Access) is
      Release : Boolean;
   begin
      if Node /= null then
         Util.Concurrent.Counters.Decrement (Node.Ref_Counter, Release);
         case Node.Kind is
            when N_NOT =>
               Destroy (Node.Expr);

            when N_AND | N_OR =>
               Destroy (Node.Left);
               Destroy (Node.Right);

            when others =>
               null;
         end case;
         if Release then
            Free (Node);
         else
            Node := null;
         end if;
      end if;
   end Destroy;

   --  ------------------------------
   --  Release the reference and destroy the expression tree if it was the last reference.
   --  ------------------------------
   overriding
   procedure Finalize (Obj : in out Expression_Type) is
   begin
      if Obj.Node /= null then
         Destroy (Obj.Node);
      end if;
   end Finalize;

   --  ------------------------------
   --  Update the reference after an assignment.
   --  ------------------------------
   overriding
   procedure Adjust (Obj : in out Expression_Type) is
   begin
      if Obj.Node /= null then
         Util.Concurrent.Counters.Increment (Obj.Node.Ref_Counter);
      end if;
   end Adjust;

end MAT.Expressions;

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

with MAT.Types;
with MAT.Memory;
with MAT.Expressions.Parser;
package body MAT.Expressions is

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Node_Type,
                                     Name   => Node_Type_Access);

   --  Destroy recursively the node, releasing the storage.
   procedure Destroy (Node : in out Node_Type_Access);

   --  ------------------------------
   --  Create a NOT expression node.
   --  ------------------------------
   function Create_Not (Expr : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_NOT,
                                    Expr        => Expr.Node);
      Util.Concurrent.Counters.Increment (Expr.Node.Ref_Counter);
      return Result;
   end Create_Not;

   --  ------------------------------
   --  Create a AND expression node.
   --  ------------------------------
   function Create_And (Left  : in Expression_Type;
                        Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_AND,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_And;

   --  ------------------------------
   --  Create a OR expression node.
   --  ------------------------------
   function Create_Or (Left  : in Expression_Type;
                       Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_OR,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_Or;

   --  ------------------------------
   --  Create an INSIDE expression node.
   --  ------------------------------
   function Create_Inside (Name : in Ada.Strings.Unbounded.Unbounded_String;
                           Kind : in Inside_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_INSIDE,
                                    Name        => Name,
                                    Inside      => Kind);
      return Result;
   end Create_Inside;

   --  ------------------------------
   --  Create an size range expression node.
   --  ------------------------------
   function Create_Size (Min : in MAT.Types.Target_Size;
                         Max : in MAT.Types.Target_Size) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_SIZE,
                                    Min_Size    => Min,
                                    Max_Size    => Max);
      return Result;
   end Create_Size;

   --  ------------------------------
   --  Create an addr range expression node.
   --  ------------------------------
   function Create_Addr (Min : in MAT.Types.Target_Addr;
                         Max : in MAT.Types.Target_Addr) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_ADDR,
                                    Min_Addr    => Min,
                                    Max_Addr    => Max);
      return Result;
   end Create_Addr;

   --  ------------------------------
   --  Create an time range expression node.
   --  ------------------------------
   function Create_Time (Min : in MAT.Types.Target_Tick_Ref;
                         Max : in MAT.Types.Target_Tick_Ref) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_TIME,
                                    Min_Time    => Min,
                                    Max_Time    => Max);
      return Result;
   end Create_Time;

   --  ------------------------------
   --  Create an event ID range expression node.
   --  ------------------------------
   function Create_Event (Min : in MAT.Events.Targets.Event_Id_Type;
                          Max : in MAT.Events.Targets.Event_Id_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_EVENT,
                                    Min_Event   => Min,
                                    Max_Event   => Max);
      return Result;
   end Create_Event;

   --  ------------------------------
   --  Evaluate the expression to check if the memory slot described by the
   --  context is selected.  Returns True if the memory slot is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Expression_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean is
   begin
      if Node.Node = null then
         return True;
      else
         return Is_Selected (Node.Node.all, Addr, Allocation);
      end if;
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the expression to check if the event described by the
   --  context is selected.  Returns True if the event is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Expression_Type;
                         Event      : in MAT.Events.Targets.Probe_Event_Type) return Boolean is
   begin
      return Is_Selected (Node.Node.all, Event);
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the node against the context.  Returns True if the node expression
   --  selects the memory slot defined by the context.
   --  ------------------------------
   function Is_Selected (Node       : in Node_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean is
      use type MAT.Types.Target_Size;
      use type MAT.Types.Target_Tick_Ref;
   begin
      case Node.Kind is
         when N_NOT =>
            return not Is_Selected (Node.Expr.all, Addr, Allocation);

         when N_AND =>
            return Is_Selected (Node.Left.all, Addr, Allocation)
              and then Is_Selected (Node.Right.all, Addr, Allocation);

         when N_OR =>
            return Is_Selected (Node.Left.all, Addr, Allocation)
              or else Is_Selected (Node.Right.all, Addr, Allocation);

         when N_RANGE_SIZE =>
            return Allocation.Size >= Node.Min_Size
              and Allocation.Size <= Node.Max_Size;

         when N_RANGE_ADDR =>
            return Addr >= Node.Min_Addr
              and Addr <= Node.Max_Addr;

         when N_RANGE_TIME =>
            return Allocation.Time >= Node.Min_Time
              and Allocation.Time <= Node.Max_Time;

         when others =>
            return False;

      end case;
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the expression to check if the event described by the
   --  context is selected.  Returns True if the event is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Node_Type;
                         Event      : in MAT.Events.Targets.Probe_Event_Type) return Boolean is
      use type MAT.Types.Target_Size;
      use type MAT.Types.Target_Tick_Ref;
      use type MAT.Events.Targets.Event_Id_Type;
   begin
      case Node.Kind is
         when N_NOT =>
            return not Is_Selected (Node.Expr.all, Event);

         when N_AND =>
            return Is_Selected (Node.Left.all, Event)
              and then Is_Selected (Node.Right.all, Event);

         when N_OR =>
            return Is_Selected (Node.Left.all, Event)
              or else Is_Selected (Node.Right.all, Event);

         when N_RANGE_SIZE =>
            return Event.Size >= Node.Min_Size
              and Event.Size <= Node.Max_Size;

         when N_RANGE_ADDR =>
            return Event.Addr >= Node.Min_Addr
              and Event.Addr <= Node.Max_Addr;

         when N_RANGE_TIME =>
            return Event.Time >= Node.Min_Time
              and Event.Time <= Node.Max_Time;

         when N_EVENT =>
            return Event.Id >= Node.Min_Event
              and Event.Id <= Node.Max_Event;

         when others =>
            return False;

      end case;
   end Is_Selected;

   --  ------------------------------
   --  Parse the string and return the expression tree.
   --  ------------------------------
   function Parse (Expr : in String) return Expression_Type is
   begin
      return MAT.Expressions.Parser.Parse (Expr);
   end Parse;

   --  ------------------------------
   --  Destroy recursively the node, releasing the storage.
   --  ------------------------------
   procedure Destroy (Node : in out Node_Type_Access) is
      Release : Boolean;
   begin
      if Node /= null then
         Util.Concurrent.Counters.Decrement (Node.Ref_Counter, Release);
         case Node.Kind is
            when N_NOT =>
               Destroy (Node.Expr);

            when N_AND | N_OR =>
               Destroy (Node.Left);
               Destroy (Node.Right);

            when others =>
               null;
         end case;
         if Release then
            Free (Node);
         else
            Node := null;
         end if;
      end if;
   end Destroy;

   --  ------------------------------
   --  Release the reference and destroy the expression tree if it was the last reference.
   --  ------------------------------
   overriding
   procedure Finalize (Obj : in out Expression_Type) is
   begin
      if Obj.Node /= null then
         Destroy (Obj.Node);
      end if;
   end Finalize;

   --  ------------------------------
   --  Update the reference after an assignment.
   --  ------------------------------
   overriding
   procedure Adjust (Obj : in out Expression_Type) is
   begin
      if Obj.Node /= null then
         Util.Concurrent.Counters.Increment (Obj.Node.Ref_Counter);
      end if;
   end Adjust;

end MAT.Expressions;

Fix compilation

Fix compilation


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

with Util.Serialize.Mappers.Record_Mapper;
package body Security.Controllers.Roles is

   --  ------------------------------
   --  Returns true if the user associated with the security context Context has
   --  one of the role defined in the Handler.
   --  ------------------------------
   function Has_Permission (Handler    : in Role_Controller;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean is
      use type Security.Principal_Access;

      P : constant Security.Principal_Access := Context.Get_User_Principal;
   begin
      if P /= null then
         for I in Handler.Roles'Range loop
--              if P.Has_Role (Handler.Roles (I)) then
               return True;
--              end if;
         end loop;
      end if;
      return False;
   end Has_Permission;

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Manager.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Permissions.Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
            begin
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Permissions.Role_Type;
            begin
               Into.Manager.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.  For example:
   --
   --  <security-role>
   --    <role-name>admin</role-name>
   --  </security-role>
   --  <role-permission>
   --     <name>create-workspace</name>
   --     <role>admin</role>
   --     <role>manager</role>
   --  </role-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  user has either the admin or the manager role.
   --  ------------------------------
   package body Reader_Config is
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Manager;
      Config_Mapper.Set_Context (Reader, Config'Unchecked_Access);
   end Reader_Config;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Controllers.Roles;

-----------------------------------------------------------------------
--  security-controllers-roles -- Simple role base security
--  Copyright (C) 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.
-----------------------------------------------------------------------

package body Security.Controllers.Roles is

   --  ------------------------------
   --  Returns true if the user associated with the security context Context has
   --  one of the role defined in the Handler.
   --  ------------------------------
   function Has_Permission (Handler    : in Role_Controller;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean is
      use type Security.Principal_Access;

      P : constant Security.Principal_Access := Context.Get_User_Principal;
   begin
      if P /= null then
         for I in Handler.Roles'Range loop
--              if P.Has_Role (Handler.Roles (I)) then
               return True;
--              end if;
         end loop;
      end if;
      return False;
   end Has_Permission;

end Security.Controllers.Roles;

Remove the XML configuration reader which is now in Security.Policy.Roles


-----------------------------------------------------------------------
--  gen-model-tables -- Database table model representation
--  Copyright (C) 2009, 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.
-----------------------------------------------------------------------

with Ada.Strings;
with Util.Strings;
with Util.Log.Loggers;
package body Gen.Model.Tables is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Gen.Model.Tables");

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : Column_Definition;
                       Name : String) return Util.Beans.Objects.Object is
      use type Gen.Model.Mappings.Mapping_Definition_Access;
   begin

      if Name = "type" then
         declare
            T    : constant Gen.Model.Mappings.Mapping_Definition_Access := From.Get_Type_Mapping;
         begin
            if T = null then
               return Util.Beans.Objects.Null_Object;
            end if;
            return Util.Beans.Objects.To_Object (T.all'Access, Util.Beans.Objects.STATIC);
         end;

      elsif Name = "type" then
         return Util.Beans.Objects.To_Object (From.Type_Name);

      elsif Name = "index" then
         return Util.Beans.Objects.To_Object (From.Number);

      elsif Name = "isUnique" then
         return Util.Beans.Objects.To_Object (From.Unique);

      elsif Name = "isNull" then
         return Util.Beans.Objects.To_Object (not From.Not_Null);

      elsif Name = "isInserted" then
         return Util.Beans.Objects.To_Object (From.Is_Inserted);

      elsif Name = "isUpdated" then
         return Util.Beans.Objects.To_Object (From.Is_Updated);

      elsif Name = "sqlType" then
         if Length (From.Sql_Type) > 0 then
            return Util.Beans.Objects.To_Object (From.Sql_Type);
         end if;
         declare
            T    : constant Gen.Model.Mappings.Mapping_Definition_Access := From.Get_Type_Mapping;
         begin
            if T = null then
               return Util.Beans.Objects.Null_Object;
            end if;
            return T.Get_Value ("name");
         end;

      elsif Name = "sqlName" then
         return Util.Beans.Objects.To_Object (From.Sql_Name);

      elsif Name = "isVersion" then
         return Util.Beans.Objects.To_Object (From.Is_Version);

      elsif Name = "isReadable" then
         return Util.Beans.Objects.To_Object (From.Is_Readable);

      elsif Name = "isPrimaryKey" then
         return Util.Beans.Objects.To_Object (From.Is_Key);

      elsif Name = "isPrimitiveType" then
         return Util.Beans.Objects.To_Object (From.Is_Basic_Type);

      elsif Name = "generator" then
         return From.Generator;

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Returns true if the column type is a basic type.
   --  ------------------------------
   function Is_Basic_Type (From : in Column_Definition) return Boolean is
      use type Gen.Model.Mappings.Mapping_Definition_Access;
      use type Gen.Model.Mappings.Basic_Type;

      T    : constant Gen.Model.Mappings.Mapping_Definition_Access := From.Get_Type_Mapping;
      Name : constant String := To_String (From.Type_Name);
   begin
      if T /= null then
         return T.Kind /= Gen.Model.Mappings.T_BLOB;
      end if;
      return Name = "int" or Name = "String"
        or Name = "ADO.Identifier" or Name = "Timestamp"
        or Name = "Integer"
        or Name = "long" or Name = "Long" or Name = "Date" or Name = "Time";
   end Is_Basic_Type;

   --  ------------------------------
   --  Returns the column type.
   --  ------------------------------
   function Get_Type (From : in Column_Definition) return String is
      use type Gen.Model.Mappings.Mapping_Definition_Access;
      T : constant Gen.Model.Mappings.Mapping_Definition_Access := From.Get_Type_Mapping;
   begin
      if T /= null then
         return To_String (T.Target);
      else
         return To_String (From.Type_Name);
      end if;
   end Get_Type;

   --  ------------------------------
   --  Returns the column type mapping.
   --  ------------------------------
   function Get_Type_Mapping (From : in Column_Definition)
                              return Gen.Model.Mappings.Mapping_Definition_Access is
      use type Mappings.Mapping_Definition_Access;

      Result : Gen.Model.Mappings.Mapping_Definition_Access := null;
      Pos    : constant Natural := Ada.Strings.Unbounded.Index (From.Type_Name, ".");
   begin
      if Pos = 0 then
         Result := Gen.Model.Mappings.Find_Type (From.Type_Name);
      end if;
      if From.Type_Name = "Gen.Tests.Tables.Test_Enum" then
         Log.Debug ("Found enum");
      end if;
      if Result = null then
         Result := From.Table.Package_Def.Find_Type (From.Type_Name);
      end if;
      return Result;
   end Get_Type_Mapping;

   --  ------------------------------
   --  Prepare the generation of the model.
   --  ------------------------------
   overriding
   procedure Prepare (O : in out Column_Definition) is
      use type Mappings.Mapping_Definition_Access;
   begin
--        O.Type_Mapping := Gen.Model.Mappings.Find_Type (O.Type_Name);
--        if O.Type_Mapping = null then
--           O.Type_Mapping := O.Table.Package_Def.Find_Type (O.Type_Name);
--        end if;
      null;
   end Prepare;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : Association_Definition;
                       Name : String) return Util.Beans.Objects.Object is
   begin
      return Column_Definition (From).Get_Value (Name);
   end Get_Value;

   --  ------------------------------
   --  Initialize the table definition instance.
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Table_Definition) is
   begin
      O.Members_Bean := Util.Beans.Objects.To_Object (O.Members'Unchecked_Access,
                                                      Util.Beans.Objects.STATIC);
      O.Operations_Bean := Util.Beans.Objects.To_Object (O.Operations'Unchecked_Access,
                                                         Util.Beans.Objects.STATIC);
   end Initialize;

   --  ------------------------------
   --  Create a table with the given name.
   --  ------------------------------
   function Create_Table (Name : in Unbounded_String) return Table_Definition_Access is
      Table : constant Table_Definition_Access := new Table_Definition;
   begin
      Table.Name := Name;
      declare
         Pos : constant Natural := Index (Table.Name, ".", Ada.Strings.Backward);
      begin
         if Pos > 0 then
            Table.Pkg_Name := Unbounded_Slice (Table.Name, 1, Pos - 1);
            Table.Type_Name := Unbounded_Slice (Table.Name, Pos + 1, Length (Table.Name));
         else
            Table.Pkg_Name := To_Unbounded_String ("ADO");
            Table.Type_Name := Table.Name;
         end if;
         Table.Table_Name := Table.Type_Name;
      end;
      return Table;
   end Create_Table;

   --  ------------------------------
   --  Create a table column with the given name and add it to the table.
   --  ------------------------------
   procedure Add_Column (Table  : in out Table_Definition;
                         Name   : in Unbounded_String;
                         Column : out Column_Definition_Access) is
   begin
      Column := new Column_Definition;
      Column.Name     := Name;
      Column.Sql_Name := Name;
      Column.Number   := Table.Members.Get_Count;
      Column.Table    := Table'Unchecked_Access;
      Table.Members.Append (Column);
      if Name = "version" then
         Table.Version_Column := Column;
         Column.Is_Version  := True;
         Column.Is_Updated  := False;
         Column.Is_Inserted := False;

      elsif Name = "id" then
         Table.Id_Column := Column;
         Column.Is_Key := True;

      end if;
   end Add_Column;

   --  ------------------------------
   --  Create a table association with the given name and add it to the table.
   --  ------------------------------
   procedure Add_Association (Table  : in out Table_Definition;
                              Name   : in Unbounded_String;
                              Assoc  : out Association_Definition_Access) is
   begin
      Assoc := new Association_Definition;
      Assoc.Name   := Name;
      Assoc.Number := Table.Members.Get_Count;
      Assoc.Table  := Table'Unchecked_Access;
      Assoc.Sql_Name := Name;
      Table.Members.Append (Assoc.all'Access);
      Table.Has_Associations := True;
   end Add_Association;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Table_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "members" or Name = "columns" then
         return From.Members_Bean;

      elsif Name = "operations" then
         return From.Operations_Bean;

      elsif Name = "id" and From.Id_Column /= null then
         declare
            Bean : constant Util.Beans.Basic.Readonly_Bean_Access := From.Id_Column.all'Access;
         begin
            return Util.Beans.Objects.To_Object (Bean, Util.Beans.Objects.STATIC);
         end;

      elsif Name = "version" and From.Version_Column /= null then
         declare
            Bean : constant Util.Beans.Basic.Readonly_Bean_Access
              := From.Version_Column.all'Unchecked_Access;
         begin
            return Util.Beans.Objects.To_Object (Bean, Util.Beans.Objects.STATIC);
         end;

      elsif Name = "hasAssociations" then
         return Util.Beans.Objects.To_Object (From.Has_Associations);

      elsif Name = "type" then
         return Util.Beans.Objects.To_Object (From.Type_Name);

      elsif Name = "table" then
         return Util.Beans.Objects.To_Object (From.Table_Name);

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Prepare the generation of the model.
   --  ------------------------------
   overriding
   procedure Prepare (O : in out Table_Definition) is
      Iter : Column_List.Cursor := O.Members.First;
   begin
      while Column_List.Has_Element (Iter) loop
         Column_List.Element (Iter).Prepare;
         Column_List.Next (Iter);
      end loop;
   end Prepare;

   --  ------------------------------
   --  Set the table name and determines the package name.
   --  ------------------------------
   procedure Set_Table_Name (Table : in out Table_Definition;
                             Name  : in String) is
      Pos : constant Natural := Util.Strings.Rindex (Name, '.');
   begin
      Table.Name := To_Unbounded_String (Name);
      if Pos > 0 then
         Table.Pkg_Name := To_Unbounded_String (Name (Name'First .. Pos - 1));
         Table.Type_Name := To_Unbounded_String (Name (Pos + 1 .. Name'Last));
      else
         Table.Pkg_Name := To_Unbounded_String ("ADO");
         Table.Type_Name := Table.Name;
      end if;
   end Set_Table_Name;

end Gen.Model.Tables;

-----------------------------------------------------------------------
--  gen-model-tables -- Database table model representation
--  Copyright (C) 2009, 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.
-----------------------------------------------------------------------

with Ada.Strings;
with Util.Strings;
with Util.Log.Loggers;
package body Gen.Model.Tables is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Gen.Model.Tables");

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : Column_Definition;
                       Name : String) return Util.Beans.Objects.Object is
      use type Gen.Model.Mappings.Mapping_Definition_Access;
   begin

      if Name = "type" then
         declare
            T    : constant Gen.Model.Mappings.Mapping_Definition_Access := From.Get_Type_Mapping;
         begin
            if T = null then
               return Util.Beans.Objects.Null_Object;
            end if;
            return Util.Beans.Objects.To_Object (T.all'Access, Util.Beans.Objects.STATIC);
         end;

      elsif Name = "type" then
         return Util.Beans.Objects.To_Object (From.Type_Name);

      elsif Name = "index" then
         return Util.Beans.Objects.To_Object (From.Number);

      elsif Name = "isUnique" then
         return Util.Beans.Objects.To_Object (From.Unique);

      elsif Name = "isNull" then
         return Util.Beans.Objects.To_Object (not From.Not_Null);

      elsif Name = "isInserted" then
         return Util.Beans.Objects.To_Object (From.Is_Inserted);

      elsif Name = "isUpdated" then
         return Util.Beans.Objects.To_Object (From.Is_Updated);

      elsif Name = "sqlType" then
         if Length (From.Sql_Type) > 0 then
            return Util.Beans.Objects.To_Object (From.Sql_Type);
         end if;
         declare
            T    : constant Gen.Model.Mappings.Mapping_Definition_Access := From.Get_Type_Mapping;
         begin
            if T = null then
               return Util.Beans.Objects.Null_Object;
            end if;
            return T.Get_Value ("name");
         end;

      elsif Name = "sqlName" then
         return Util.Beans.Objects.To_Object (From.Sql_Name);

      elsif Name = "isVersion" then
         return Util.Beans.Objects.To_Object (From.Is_Version);

      elsif Name = "isReadable" then
         return Util.Beans.Objects.To_Object (From.Is_Readable);

      elsif Name = "isPrimaryKey" then
         return Util.Beans.Objects.To_Object (From.Is_Key);

      elsif Name = "isPrimitiveType" then
         return Util.Beans.Objects.To_Object (From.Is_Basic_Type);

      elsif Name = "generator" then
         return From.Generator;

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Returns true if the column type is a basic type.
   --  ------------------------------
   function Is_Basic_Type (From : in Column_Definition) return Boolean is
      use type Gen.Model.Mappings.Mapping_Definition_Access;
      use type Gen.Model.Mappings.Basic_Type;

      T    : constant Gen.Model.Mappings.Mapping_Definition_Access := From.Get_Type_Mapping;
      Name : constant String := To_String (From.Type_Name);
   begin
      if T /= null then
         return T.Kind /= Gen.Model.Mappings.T_BLOB;
      end if;
      return Name = "int" or Name = "String"
        or Name = "ADO.Identifier" or Name = "Timestamp"
        or Name = "Integer"
        or Name = "long" or Name = "Long" or Name = "Date" or Name = "Time";
   end Is_Basic_Type;

   --  ------------------------------
   --  Returns the column type.
   --  ------------------------------
   function Get_Type (From : in Column_Definition) return String is
      use type Gen.Model.Mappings.Mapping_Definition_Access;
      T : constant Gen.Model.Mappings.Mapping_Definition_Access := From.Get_Type_Mapping;
   begin
      if T /= null then
         return To_String (T.Target);
      else
         return To_String (From.Type_Name);
      end if;
   end Get_Type;

   --  ------------------------------
   --  Returns the column type mapping.
   --  ------------------------------
   function Get_Type_Mapping (From : in Column_Definition)
                              return Gen.Model.Mappings.Mapping_Definition_Access is
      use type Mappings.Mapping_Definition_Access;

      Result : Gen.Model.Mappings.Mapping_Definition_Access := null;
      Pos    : constant Natural := Ada.Strings.Unbounded.Index (From.Type_Name, ".");
   begin
      if Pos = 0 then
         Result := Gen.Model.Mappings.Find_Type (From.Type_Name);
      end if;
      if From.Type_Name = "Gen.Tests.Tables.Test_Enum" then
         Log.Debug ("Found enum");
      end if;
      if Result = null then
         Result := From.Table.Package_Def.Find_Type (From.Type_Name);
      end if;
      return Result;
   end Get_Type_Mapping;

   --  ------------------------------
   --  Prepare the generation of the model.
   --  ------------------------------
   overriding
   procedure Prepare (O : in out Column_Definition) is
      use type Mappings.Mapping_Definition_Access;
   begin
--        O.Type_Mapping := Gen.Model.Mappings.Find_Type (O.Type_Name);
--        if O.Type_Mapping = null then
--           O.Type_Mapping := O.Table.Package_Def.Find_Type (O.Type_Name);
--        end if;
      null;
   end Prepare;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : Association_Definition;
                       Name : String) return Util.Beans.Objects.Object is
   begin
      return Column_Definition (From).Get_Value (Name);
   end Get_Value;

   --  ------------------------------
   --  Initialize the table definition instance.
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Table_Definition) is
   begin
      O.Members_Bean := Util.Beans.Objects.To_Object (O.Members'Unchecked_Access,
                                                      Util.Beans.Objects.STATIC);
      O.Operations_Bean := Util.Beans.Objects.To_Object (O.Operations'Unchecked_Access,
                                                         Util.Beans.Objects.STATIC);
   end Initialize;

   --  ------------------------------
   --  Create a table with the given name.
   --  ------------------------------
   function Create_Table (Name : in Unbounded_String) return Table_Definition_Access is
      Table : constant Table_Definition_Access := new Table_Definition;
   begin
      Table.Name := Name;
      Table.Kind := Gen.Model.Mappings.T_TABLE;
      declare
         Pos : constant Natural := Index (Table.Name, ".", Ada.Strings.Backward);
      begin
         if Pos > 0 then
            Table.Pkg_Name := Unbounded_Slice (Table.Name, 1, Pos - 1);
            Table.Type_Name := Unbounded_Slice (Table.Name, Pos + 1, Length (Table.Name));
         else
            Table.Pkg_Name := To_Unbounded_String ("ADO");
            Table.Type_Name := Table.Name;
         end if;
         Table.Table_Name := Table.Type_Name;
      end;
      return Table;
   end Create_Table;

   --  ------------------------------
   --  Create a table column with the given name and add it to the table.
   --  ------------------------------
   procedure Add_Column (Table  : in out Table_Definition;
                         Name   : in Unbounded_String;
                         Column : out Column_Definition_Access) is
   begin
      Column := new Column_Definition;
      Column.Name     := Name;
      Column.Sql_Name := Name;
      Column.Number   := Table.Members.Get_Count;
      Column.Table    := Table'Unchecked_Access;
      Table.Members.Append (Column);
      if Name = "version" then
         Table.Version_Column := Column;
         Column.Is_Version  := True;
         Column.Is_Updated  := False;
         Column.Is_Inserted := False;

      elsif Name = "id" then
         Table.Id_Column := Column;
         Column.Is_Key := True;

      end if;
   end Add_Column;

   --  ------------------------------
   --  Create a table association with the given name and add it to the table.
   --  ------------------------------
   procedure Add_Association (Table  : in out Table_Definition;
                              Name   : in Unbounded_String;
                              Assoc  : out Association_Definition_Access) is
   begin
      Assoc := new Association_Definition;
      Assoc.Name   := Name;
      Assoc.Number := Table.Members.Get_Count;
      Assoc.Table  := Table'Unchecked_Access;
      Assoc.Sql_Name := Name;
      Table.Members.Append (Assoc.all'Access);
      Table.Has_Associations := True;
   end Add_Association;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Table_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "members" or Name = "columns" then
         return From.Members_Bean;

      elsif Name = "operations" then
         return From.Operations_Bean;

      elsif Name = "id" and From.Id_Column /= null then
         declare
            Bean : constant Util.Beans.Basic.Readonly_Bean_Access := From.Id_Column.all'Access;
         begin
            return Util.Beans.Objects.To_Object (Bean, Util.Beans.Objects.STATIC);
         end;

      elsif Name = "version" and From.Version_Column /= null then
         declare
            Bean : constant Util.Beans.Basic.Readonly_Bean_Access
              := From.Version_Column.all'Unchecked_Access;
         begin
            return Util.Beans.Objects.To_Object (Bean, Util.Beans.Objects.STATIC);
         end;

      elsif Name = "hasAssociations" then
         return Util.Beans.Objects.To_Object (From.Has_Associations);

      elsif Name = "type" then
         return Util.Beans.Objects.To_Object (From.Type_Name);

      elsif Name = "table" then
         return Util.Beans.Objects.To_Object (From.Table_Name);

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Prepare the generation of the model.
   --  ------------------------------
   overriding
   procedure Prepare (O : in out Table_Definition) is
      Iter : Column_List.Cursor := O.Members.First;
   begin
      while Column_List.Has_Element (Iter) loop
         Column_List.Element (Iter).Prepare;
         Column_List.Next (Iter);
      end loop;
   end Prepare;

   --  ------------------------------
   --  Set the table name and determines the package name.
   --  ------------------------------
   procedure Set_Table_Name (Table : in out Table_Definition;
                             Name  : in String) is
      Pos : constant Natural := Util.Strings.Rindex (Name, '.');
   begin
      Table.Name := To_Unbounded_String (Name);
      if Pos > 0 then
         Table.Pkg_Name := To_Unbounded_String (Name (Name'First .. Pos - 1));
         Table.Type_Name := To_Unbounded_String (Name (Pos + 1 .. Name'Last));
      else
         Table.Pkg_Name := To_Unbounded_String ("ADO");
         Table.Type_Name := Table.Name;
      end if;
   end Set_Table_Name;

end Gen.Model.Tables;

Mark the table type mapping as a T_TABLE