-----------------------------------------------------------------------
--  gen-commands-database -- Database creation from application model
--  Copyright (C) 2011, 2012, 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 Ada.Text_IO;
with Ada.Strings.Fixed;
with Ada.IO_Exceptions;
with Ada.Directories;
with Ada.Exceptions;

with Util.Strings;
with Util.Files;
with Util.Log.Loggers;
with Util.Strings.Vectors;

with ADO.Drivers;
with ADO.Sessions.Sources;
with ADO.Schemas.Databases;

package body Gen.Commands.Database is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Gen.Commands.Database");

   function Get_Schema_Path (Model_Dir : in String;
                             Model     : in String;
                             Config    : in ADO.Sessions.Sources.Data_Source) return String;

   function Get_Schema_Path (Model_Dir : in String;
                             Model     : in String;
                             Config    : in ADO.Sessions.Sources.Data_Source) return String is
      Driver : constant String := Config.Get_Driver;
      Dir    : constant String := Util.Files.Compose (Model_Dir, Driver);
   begin
      return Util.Files.Compose (Dir, "create-" & Model & "-" & Driver & ".sql");
   end Get_Schema_Path;

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   overriding
   procedure Execute (Cmd       : in out Command;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Name);

      procedure Create_Database (Model_Dir : in String;
                                 Database  : in String;
                                 Username  : in String;
                                 Password  : in String);

      --  ------------------------------
      --  Create the database, the user and the tables.
      --  ------------------------------
      procedure Create_Database (Model_Dir : in String;
                                 Database  : in String;
                                 Username  : in String;
                                 Password  : in String) is
         Admin    : ADO.Sessions.Sources.Data_Source;
         Config   : ADO.Sessions.Sources.Data_Source;
         Messages : Util.Strings.Vectors.Vector;
      begin
         Config.Set_Connection (Database);
         Admin := Config;
         if Config.Get_Database = "" then
            Generator.Error ("Invalid database connection: no database name specified");
            return;
         end if;

         declare
            Name : constant String := Generator.Get_Project_Name;
            Path : constant String := Get_Schema_Path (Model_Dir, Name, Config);
         begin
            Log.Info ("Creating database tables using schema '{0}'", Path);

            if not Ada.Directories.Exists (Path) then
               Generator.Error ("SQL file '{0}' does not exist.", Path);
               Generator.Error ("Please, run the following command: dynamo generate db");
               return;
            end if;

            if Config.Get_Driver = "mysql" or Config.Get_Driver = "postgresql" then
               if Config.Get_Property ("user") = "" then
                  Generator.Error ("Invalid database connection: missing user property");
                  return;
               end if;
               Admin.Set_Property ("user", Username);
               Admin.Set_Property ("password", Password);

            elsif Config.Get_Driver /= "sqlite" then
               Generator.Error ("Database driver {0} is not supported.", Config.Get_Driver);
               return;
            end if;
            Admin.Set_Database ("");
            ADO.Schemas.Databases.Create_Database (Admin, Config, Path, Messages);

            --  Report the messages
            for Msg of Messages loop
               Log.Error ("{0}", Msg);
            end loop;
         end;
         --  Remember the database connection string.
         Generator.Set_Project_Property ("database", Database);
         Generator.Save_Project;

      exception
         when E : others =>
            Generator.Error (Ada.Exceptions.Exception_Message (E));
      end Create_Database;

      Model  : constant String := (if Args.Get_Count > 0 then Args.Get_Argument (1) else "");
      Arg1   : constant String := (if Args.Get_Count > 1 then Args.Get_Argument (2) else "");
      Arg2   : constant String := (if Args.Get_Count > 2 then Args.Get_Argument (3) else "");
      Arg3   : constant String := (if Args.Get_Count > 3 then Args.Get_Argument (4) else "");
   begin
      Generator.Read_Project ("dynamo.xml");

      --  Initialize the database drivers.
      ADO.Drivers.Initialize (Generator.Get_Properties);

      --  Check if a database is specified in the command line and use it.
      if Ada.Strings.Fixed.Index (Arg1, "://") > 0 or Arg3'Length > 0 then
         Create_Database (Model, Arg1, Arg2, Arg3);
      else
         declare
            Database : constant String := Generator.Get_Project_Property ("database");
         begin
            --  Otherwise, get the database identification from dynamo.xml configuration.
            if Ada.Strings.Fixed.Index (Database, "://") = 0 then
               Generator.Error ("No database specified.");
               return;
            end if;
            Create_Database (Model, Database, Arg1, Arg2);
         end;
      end if;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Cmd       : in out Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
      use Ada.Text_IO;
   begin
      Put_Line ("create-database: Creates the database");
      Put_Line ("Usage: create-database MODEL [CONNECTION] ADMIN-USER [ADMIN-PASSWORD]");
      New_Line;
      Put_Line ("  Create the database specified by the connection string.");
      Put_Line ("  The connection string has the form:");
      Put_Line ("     driver://host[:port]/database");
      New_Line;
      Put_Line ("  The database must not exist.  The user specified in the connection string");
      Put_Line ("  is granted the access to the new database.");
   end Help;

end Gen.Commands.Database;

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

with Ada.Text_IO;
with Ada.Strings.Fixed;
with Ada.Directories;
with Ada.Exceptions;

with Util.Strings;
with Util.Files;
with Util.Log.Loggers;
with Util.Strings.Vectors;

with ADO.Drivers;
with ADO.Sessions.Sources;
with ADO.Schemas.Databases;

package body Gen.Commands.Database is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Gen.Commands.Database");

   function Get_Schema_Path (Model_Dir : in String;
                             Model     : in String;
                             Config    : in ADO.Sessions.Sources.Data_Source) return String;

   function Get_Schema_Path (Model_Dir : in String;
                             Model     : in String;
                             Config    : in ADO.Sessions.Sources.Data_Source) return String is
      Driver : constant String := Config.Get_Driver;
      Dir    : constant String := Util.Files.Compose (Model_Dir, Driver);
   begin
      return Util.Files.Compose (Dir, "create-" & Model & "-" & Driver & ".sql");
   end Get_Schema_Path;

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   overriding
   procedure Execute (Cmd       : in out Command;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Name);

      procedure Create_Database (Model_Dir : in String;
                                 Database  : in String;
                                 Username  : in String;
                                 Password  : in String);

      --  ------------------------------
      --  Create the database, the user and the tables.
      --  ------------------------------
      procedure Create_Database (Model_Dir : in String;
                                 Database  : in String;
                                 Username  : in String;
                                 Password  : in String) is
         Admin    : ADO.Sessions.Sources.Data_Source;
         Config   : ADO.Sessions.Sources.Data_Source;
         Messages : Util.Strings.Vectors.Vector;
      begin
         Config.Set_Connection (Database);
         Admin := Config;
         if Config.Get_Database = "" then
            Generator.Error ("Invalid database connection: no database name specified");
            return;
         end if;

         declare
            Name : constant String := Generator.Get_Project_Name;
            Path : constant String := Get_Schema_Path (Model_Dir, Name, Config);
         begin
            Log.Info ("Creating database tables using schema '{0}'", Path);

            if not Ada.Directories.Exists (Path) then
               Generator.Error ("SQL file '{0}' does not exist.", Path);
               Generator.Error ("Please, run the following command: dynamo generate db");
               return;
            end if;

            if Config.Get_Driver = "mysql" or Config.Get_Driver = "postgresql" then
               if Config.Get_Property ("user") = "" then
                  Generator.Error ("Invalid database connection: missing user property");
                  return;
               end if;
               Admin.Set_Property ("user", Username);
               Admin.Set_Property ("password", Password);

            elsif Config.Get_Driver /= "sqlite" then
               Generator.Error ("Database driver {0} is not supported.", Config.Get_Driver);
               return;
            end if;
            Admin.Set_Database ("");
            ADO.Schemas.Databases.Create_Database (Admin, Config, Path, Messages);

            --  Report the messages
            for Msg of Messages loop
               Log.Error ("{0}", Msg);
            end loop;
         end;
         --  Remember the database connection string.
         Generator.Set_Project_Property ("database", Database);
         Generator.Save_Project;

      exception
         when E : others =>
            Generator.Error (Ada.Exceptions.Exception_Message (E));
      end Create_Database;

      Model  : constant String := (if Args.Get_Count > 0 then Args.Get_Argument (1) else "");
      Arg1   : constant String := (if Args.Get_Count > 1 then Args.Get_Argument (2) else "");
      Arg2   : constant String := (if Args.Get_Count > 2 then Args.Get_Argument (3) else "");
      Arg3   : constant String := (if Args.Get_Count > 3 then Args.Get_Argument (4) else "");
   begin
      Generator.Read_Project ("dynamo.xml");

      --  Initialize the database drivers.
      ADO.Drivers.Initialize (Generator.Get_Properties);

      --  Check if a database is specified in the command line and use it.
      if Ada.Strings.Fixed.Index (Arg1, "://") > 0 or Arg3'Length > 0 then
         Create_Database (Model, Arg1, Arg2, Arg3);
      else
         declare
            Database : constant String := Generator.Get_Project_Property ("database");
         begin
            --  Otherwise, get the database identification from dynamo.xml configuration.
            if Ada.Strings.Fixed.Index (Database, "://") = 0 then
               Generator.Error ("No database specified.");
               return;
            end if;
            Create_Database (Model, Database, Arg1, Arg2);
         end;
      end if;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Cmd       : in out Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
      use Ada.Text_IO;
   begin
      Put_Line ("create-database: Creates the database");
      Put_Line ("Usage: create-database MODEL [CONNECTION] ADMIN-USER [ADMIN-PASSWORD]");
      New_Line;
      Put_Line ("  Create the database specified by the connection string.");
      Put_Line ("  The connection string has the form:");
      Put_Line ("     driver://host[:port]/database");
      New_Line;
      Put_Line ("  The database must not exist.  The user specified in the connection string");
      Put_Line ("  is granted the access to the new database.");
   end Help;

end Gen.Commands.Database;

Remove unecessary with Ada.IO_Exceptions


--  Copyright (c) 2012 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.

with Interfaces.C.Pointers;

private with GL.Low_Level.Enums;

package GL.Objects.Buffers is
   pragma Preelaborate;

   function Minimum_Alignment return Types.Size
     with Post => Minimum_Alignment'Result >= 64;
   --  Minimum byte alignment of pointers returned by Map_Range
   --  (at least 64 bytes to support SIMD CPU instructions)

   type Access_Kind is (Read_Only, Write_Only, Read_Write);

   type Access_Bits is record
      Read              : Boolean := False;
      Write             : Boolean := False;
      Invalidate_Range  : Boolean := False;
      Invalidate_Buffer : Boolean := False;
      Flush_Explicit    : Boolean := False;
      Unsynchronized    : Boolean := False;
      Persistent        : Boolean := False;
      Coherent          : Boolean := False;
   end record;

   type Storage_Bits is record
      Read              : Boolean := False;
      Write             : Boolean := False;
      Persistent        : Boolean := False;
      Coherent          : Boolean := False;
      Dynamic_Storage   : Boolean := False;
      Client_Storage    : Boolean := False;
   end record;

   type Buffer_Target (<>) is tagged limited private;

   type Buffer is new GL_Object with private;

   procedure Bind (Target : Buffer_Target; Object : Buffer'Class);
   --  Bind the buffer object to the target

   procedure Bind_Base (Target : Buffer_Target; Object : Buffer'Class; Index : Natural);
   --  Bind the buffer object to the index of the target as well as to
   --  the target itself.
   --
   --  Target must be one of the following:
   --
   --    * Atomic_Counter_Buffer
   --    * Transform_Feedback_Buffer
   --    * Uniform_Buffer
   --    * Shader_Storage_Buffer

   procedure Allocate (Object : Buffer; Number_Of_Elements : Long;
                       Kind : Numeric_Type; Storage_Flags : Storage_Bits);
   --  Use this instead of Load_To_Immutable_Buffer when you don't want
   --  to copy any data

   function Current_Object (Target : Buffer_Target) return Buffer'Class;

   function Access_Type   (Object : Buffer) return Access_Kind;
   function Immutable     (Object : Buffer) return Boolean;
   function Mapped        (Object : Buffer) return Boolean;
   function Size          (Object : Buffer) return Long_Size;
   function Storage_Flags (Object : Buffer) return Storage_Bits;

   overriding
   procedure Initialize_Id (Object : in out Buffer);

   overriding
   procedure Delete_Id (Object : in out Buffer);

   overriding
   function Identifier (Object : Buffer) return Types.Debug.Identifier is
     (Types.Debug.Buffer);

   procedure Unmap (Object : in out Buffer);

   procedure Clear_With_Zeros (Object : Buffer);

   procedure Invalidate_Data (Object : in out Buffer);

   generic
      with package Pointers is new Interfaces.C.Pointers (<>);
   package Buffer_Pointers is

      subtype Pointer is Pointers.Pointer;

      procedure Bind_Range (Target : Buffer_Target; Object : Buffer'Class; Index : Natural;
                            Offset, Length : Types.Size);
      --  Bind a part of the buffer object to the index of the target as
      --  well as to the target itself.
      --
      --  Target must be one of the following:
      --
      --    * Atomic_Counter_Buffer
      --    * Transform_Feedback_Buffer
      --    * Uniform_Buffer
      --    * Shader_Storage_Buffer

      procedure Load_To_Immutable_Buffer (Object : Buffer;
                                          Data   : Pointers.Element_Array;
                                          Storage_Flags : Storage_Bits);

      procedure Map_Range (Object : in out Buffer; Access_Flags : Access_Bits;
                           Offset, Length : Types.Size;
                           Pointer : out Pointers.Pointer);

      function Get_Mapped_Data
        (Pointer : not null Pointers.Pointer;
         Offset, Length : Types.Size) return Pointers.Element_Array
      with Pre  => Length > 0,
           Post => Get_Mapped_Data'Result'Length = Length;

      procedure Set_Mapped_Data
        (Pointer : not null Pointers.Pointer;
         Offset  : Types.Size;
         Data    : Pointers.Element_Array)
      with Pre => Data'Length > 0;

      procedure Set_Mapped_Data
        (Pointer : not null Pointers.Pointer;
         Offset  : Types.Size;
         Value   : Pointers.Element);

      procedure Flush_Buffer_Range (Object : in out Buffer;
                                    Offset, Length : Types.Size);

      function To_Pointer (Object : Buffer) return Pointers.Pointer;

      procedure Clear_Data
        (Object : Buffer;
         Kind : Numeric_Type;
         Data : in out Pointers.Element_Array)
      with Pre => Data'Length in 1 .. 4
        and then Kind /= Double_Type
        and then (if Data'Length = 3 then
          Kind not in Byte_Type | UByte_Type | Short_Type | UShort_Type | Half_Type);

      procedure Clear_Sub_Data
        (Object : Buffer;
         Offset, Length : Types.Size;
         Kind : Numeric_Type;
         Data : in out Pointers.Element_Array)
      with Pre => Data'Length in 1 .. 4
        and then Kind /= Double_Type
        and then (if Data'Length = 3 then
          Kind not in Byte_Type | UByte_Type | Short_Type | UShort_Type | Half_Type);

      procedure Clear_With_Zeros (Object : Buffer; Offset, Length : Types.Size);

      procedure Copy_Sub_Data (Object, Target_Object : Buffer;
                               Read_Offset, Write_Offset, Length : Types.Size);

      procedure Set_Sub_Data (Object : Buffer;
                              Offset : Types.Size;
                              Data   : in out Pointers.Element_Array);

      procedure Get_Sub_Data (Object : Buffer;
                              Offset : Types.Size;
                              Data   : out Pointers.Element_Array);

      procedure Invalidate_Sub_Data (Object : Buffer;
                                     Offset, Length : Types.Size);

   end Buffer_Pointers;

   Array_Buffer              : constant Buffer_Target;
   Element_Array_Buffer      : constant Buffer_Target;
   Pixel_Pack_Buffer         : constant Buffer_Target;
   Pixel_Unpack_Buffer       : constant Buffer_Target;
   Uniform_Buffer            : constant Buffer_Target;
   Texture_Buffer            : constant Buffer_Target;
   Transform_Feedback_Buffer : constant Buffer_Target;
   Copy_Read_Buffer          : constant Buffer_Target;
   Copy_Write_Buffer         : constant Buffer_Target;
   Draw_Indirect_Buffer      : constant Buffer_Target;
   Parameter_Buffer          : constant Buffer_Target;
   Shader_Storage_Buffer     : constant Buffer_Target;
   Dispatch_Indirect_Buffer  : constant Buffer_Target;
   Query_Buffer              : constant Buffer_Target;
   Atomic_Counter_Buffer     : constant Buffer_Target;

private

   for Access_Kind use (Read_Only  => 16#88B8#,
                        Write_Only => 16#88B9#,
                        Read_Write => 16#88BA#);
   for Access_Kind'Size use Low_Level.Enum'Size;

   for Access_Bits use record
      Read              at 0 range 0 .. 0;
      Write             at 0 range 1 .. 1;
      Invalidate_Range  at 0 range 2 .. 2;
      Invalidate_Buffer at 0 range 3 .. 3;
      Flush_Explicit    at 0 range 4 .. 4;
      Unsynchronized    at 0 range 5 .. 5;
      Persistent        at 0 range 6 .. 6;
      Coherent          at 0 range 7 .. 7;
   end record;
   for Access_Bits'Size use Low_Level.Bitfield'Size;

   for Storage_Bits use record
      Read              at 0 range 0 .. 0;
      Write             at 0 range 1 .. 1;
      Persistent        at 0 range 6 .. 6;
      Coherent          at 0 range 7 .. 7;
      Dynamic_Storage   at 0 range 8 .. 8;
      Client_Storage    at 0 range 9 .. 9;
   end record;
   for Storage_Bits'Size use Low_Level.Bitfield'Size;

   type Buffer_Target (Kind : Low_Level.Enums.Buffer_Kind) is
     tagged limited null record;

   type Buffer is new GL_Object with null record;

   Array_Buffer              : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Array_Buffer);
   Element_Array_Buffer      : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Element_Array_Buffer);
   Pixel_Pack_Buffer         : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Pixel_Pack_Buffer);
   Pixel_Unpack_Buffer       : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Pixel_Unpack_Buffer);
   Uniform_Buffer            : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Uniform_Buffer);
   Texture_Buffer            : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Texture_Buffer);
   Transform_Feedback_Buffer : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Transform_Feedback_Buffer);
   Copy_Read_Buffer          : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Copy_Read_Buffer);
   Copy_Write_Buffer         : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Copy_Write_Buffer);
   Draw_Indirect_Buffer      : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Draw_Indirect_Buffer);
   Parameter_Buffer          : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Parameter_Buffer);
   Shader_Storage_Buffer     : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Shader_Storage_Buffer);
   Dispatch_Indirect_Buffer  : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Dispatch_Indirect_Buffer);
   Query_Buffer              : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Query_Buffer);
   Atomic_Counter_Buffer     : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Atomic_Counter_Buffer);

end GL.Objects.Buffers;

--  Copyright (c) 2012 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.

with Interfaces.C.Pointers;

private with GL.Low_Level.Enums;

package GL.Objects.Buffers is
   pragma Preelaborate;

   function Minimum_Alignment return Types.Size
     with Post => Minimum_Alignment'Result >= 64;
   --  Minimum byte alignment of pointers returned by Map_Range
   --  (at least 64 bytes to support SIMD CPU instructions)

   type Access_Kind is (Read_Only, Write_Only, Read_Write);

   type Access_Bits is record
      Read              : Boolean := False;
      Write             : Boolean := False;
      Invalidate_Range  : Boolean := False;
      Invalidate_Buffer : Boolean := False;
      Flush_Explicit    : Boolean := False;
      Unsynchronized    : Boolean := False;
      Persistent        : Boolean := False;
      Coherent          : Boolean := False;
   end record;

   type Storage_Bits is record
      Read              : Boolean := False;
      Write             : Boolean := False;
      Persistent        : Boolean := False;
      Coherent          : Boolean := False;
      Dynamic_Storage   : Boolean := False;
      Client_Storage    : Boolean := False;
   end record
     with Dynamic_Predicate => (if Storage_Bits.Coherent then Storage_Bits.Persistent)
       and (if Storage_Bits.Persistent then Storage_Bits.Read or Storage_Bits.Write);

   type Buffer_Target (<>) is tagged limited private;

   type Buffer is new GL_Object with private;

   procedure Bind (Target : Buffer_Target; Object : Buffer'Class);
   --  Bind the buffer object to the target

   procedure Bind_Base (Target : Buffer_Target; Object : Buffer'Class; Index : Natural);
   --  Bind the buffer object to the index of the target as well as to
   --  the target itself.
   --
   --  Target must be one of the following:
   --
   --    * Atomic_Counter_Buffer
   --    * Transform_Feedback_Buffer
   --    * Uniform_Buffer
   --    * Shader_Storage_Buffer

   procedure Allocate (Object : Buffer; Number_Of_Elements : Long;
                       Kind : Numeric_Type; Storage_Flags : Storage_Bits);
   --  Use this instead of Load_To_Immutable_Buffer when you don't want
   --  to copy any data

   function Current_Object (Target : Buffer_Target) return Buffer'Class;

   function Access_Type   (Object : Buffer) return Access_Kind;
   function Immutable     (Object : Buffer) return Boolean;
   function Mapped        (Object : Buffer) return Boolean;
   function Size          (Object : Buffer) return Long_Size;
   function Storage_Flags (Object : Buffer) return Storage_Bits;

   overriding
   procedure Initialize_Id (Object : in out Buffer);

   overriding
   procedure Delete_Id (Object : in out Buffer);

   overriding
   function Identifier (Object : Buffer) return Types.Debug.Identifier is
     (Types.Debug.Buffer);

   procedure Unmap (Object : in out Buffer);

   procedure Clear_With_Zeros (Object : Buffer);

   procedure Invalidate_Data (Object : in out Buffer);

   generic
      with package Pointers is new Interfaces.C.Pointers (<>);
   package Buffer_Pointers is

      subtype Pointer is Pointers.Pointer;

      procedure Bind_Range (Target : Buffer_Target; Object : Buffer'Class; Index : Natural;
                            Offset, Length : Types.Size);
      --  Bind a part of the buffer object to the index of the target as
      --  well as to the target itself.
      --
      --  Target must be one of the following:
      --
      --    * Atomic_Counter_Buffer
      --    * Transform_Feedback_Buffer
      --    * Uniform_Buffer
      --    * Shader_Storage_Buffer

      procedure Load_To_Immutable_Buffer (Object : Buffer;
                                          Data   : Pointers.Element_Array;
                                          Storage_Flags : Storage_Bits);

      procedure Map_Range (Object : in out Buffer; Access_Flags : Access_Bits;
                           Offset, Length : Types.Size;
                           Pointer : out Pointers.Pointer);

      function Get_Mapped_Data
        (Pointer : not null Pointers.Pointer;
         Offset, Length : Types.Size) return Pointers.Element_Array
      with Pre  => Length > 0,
           Post => Get_Mapped_Data'Result'Length = Length;

      procedure Set_Mapped_Data
        (Pointer : not null Pointers.Pointer;
         Offset  : Types.Size;
         Data    : Pointers.Element_Array)
      with Pre => Data'Length > 0;

      procedure Set_Mapped_Data
        (Pointer : not null Pointers.Pointer;
         Offset  : Types.Size;
         Value   : Pointers.Element);

      procedure Flush_Buffer_Range (Object : in out Buffer;
                                    Offset, Length : Types.Size);

      function To_Pointer (Object : Buffer) return Pointers.Pointer;

      procedure Clear_Data
        (Object : Buffer;
         Kind : Numeric_Type;
         Data : in out Pointers.Element_Array)
      with Pre => Data'Length in 1 .. 4
        and then Kind /= Double_Type
        and then (if Data'Length = 3 then
          Kind not in Byte_Type | UByte_Type | Short_Type | UShort_Type | Half_Type);

      procedure Clear_Sub_Data
        (Object : Buffer;
         Offset, Length : Types.Size;
         Kind : Numeric_Type;
         Data : in out Pointers.Element_Array)
      with Pre => Data'Length in 1 .. 4
        and then Kind /= Double_Type
        and then (if Data'Length = 3 then
          Kind not in Byte_Type | UByte_Type | Short_Type | UShort_Type | Half_Type);

      procedure Clear_With_Zeros (Object : Buffer; Offset, Length : Types.Size);

      procedure Copy_Sub_Data (Object, Target_Object : Buffer;
                               Read_Offset, Write_Offset, Length : Types.Size);

      procedure Set_Sub_Data (Object : Buffer;
                              Offset : Types.Size;
                              Data   : in out Pointers.Element_Array);

      procedure Get_Sub_Data (Object : Buffer;
                              Offset : Types.Size;
                              Data   : out Pointers.Element_Array);

      procedure Invalidate_Sub_Data (Object : Buffer;
                                     Offset, Length : Types.Size);

   end Buffer_Pointers;

   Array_Buffer              : constant Buffer_Target;
   Element_Array_Buffer      : constant Buffer_Target;
   Pixel_Pack_Buffer         : constant Buffer_Target;
   Pixel_Unpack_Buffer       : constant Buffer_Target;
   Uniform_Buffer            : constant Buffer_Target;
   Texture_Buffer            : constant Buffer_Target;
   Transform_Feedback_Buffer : constant Buffer_Target;
   Copy_Read_Buffer          : constant Buffer_Target;
   Copy_Write_Buffer         : constant Buffer_Target;
   Draw_Indirect_Buffer      : constant Buffer_Target;
   Parameter_Buffer          : constant Buffer_Target;
   Shader_Storage_Buffer     : constant Buffer_Target;
   Dispatch_Indirect_Buffer  : constant Buffer_Target;
   Query_Buffer              : constant Buffer_Target;
   Atomic_Counter_Buffer     : constant Buffer_Target;

private

   for Access_Kind use (Read_Only  => 16#88B8#,
                        Write_Only => 16#88B9#,
                        Read_Write => 16#88BA#);
   for Access_Kind'Size use Low_Level.Enum'Size;

   for Access_Bits use record
      Read              at 0 range 0 .. 0;
      Write             at 0 range 1 .. 1;
      Invalidate_Range  at 0 range 2 .. 2;
      Invalidate_Buffer at 0 range 3 .. 3;
      Flush_Explicit    at 0 range 4 .. 4;
      Unsynchronized    at 0 range 5 .. 5;
      Persistent        at 0 range 6 .. 6;
      Coherent          at 0 range 7 .. 7;
   end record;
   for Access_Bits'Size use Low_Level.Bitfield'Size;

   for Storage_Bits use record
      Read              at 0 range 0 .. 0;
      Write             at 0 range 1 .. 1;
      Persistent        at 0 range 6 .. 6;
      Coherent          at 0 range 7 .. 7;
      Dynamic_Storage   at 0 range 8 .. 8;
      Client_Storage    at 0 range 9 .. 9;
   end record;
   for Storage_Bits'Size use Low_Level.Bitfield'Size;

   type Buffer_Target (Kind : Low_Level.Enums.Buffer_Kind) is
     tagged limited null record;

   type Buffer is new GL_Object with null record;

   Array_Buffer              : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Array_Buffer);
   Element_Array_Buffer      : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Element_Array_Buffer);
   Pixel_Pack_Buffer         : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Pixel_Pack_Buffer);
   Pixel_Unpack_Buffer       : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Pixel_Unpack_Buffer);
   Uniform_Buffer            : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Uniform_Buffer);
   Texture_Buffer            : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Texture_Buffer);
   Transform_Feedback_Buffer : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Transform_Feedback_Buffer);
   Copy_Read_Buffer          : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Copy_Read_Buffer);
   Copy_Write_Buffer         : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Copy_Write_Buffer);
   Draw_Indirect_Buffer      : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Draw_Indirect_Buffer);
   Parameter_Buffer          : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Parameter_Buffer);
   Shader_Storage_Buffer     : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Shader_Storage_Buffer);
   Dispatch_Indirect_Buffer  : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Dispatch_Indirect_Buffer);
   Query_Buffer              : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Query_Buffer);
   Atomic_Counter_Buffer     : constant Buffer_Target
     := Buffer_Target'(Kind => Low_Level.Enums.Atomic_Counter_Buffer);

end GL.Objects.Buffers;

gl: Add dynamic predicate to type Storage_Bits

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


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

with EL.Contexts.Default;
with Ada.Unchecked_Deallocation;
package body ASF.Components is

   --  ------------------------------
   --  Get the parent component.
   --  Returns null if the node is the root element.
   --  ------------------------------
   function Get_Parent (UI : UIComponent) return UIComponent_Access is
   begin
      return UI.Parent;
   end Get_Parent;

   --  ------------------------------
   --  Return a client-side identifier for this component, generating
   --  one if necessary.
   --  ------------------------------
   function Get_Client_Id (UI : UIComponent) return Unbounded_String is
   begin
      return UI.Id;
   end Get_Client_Id;

   --  ------------------------------
   --  Get the list of children.
   --  ------------------------------
   function Get_Children (UI : UIComponent) return UIComponent_List is
      Result : UIComponent_List;
   begin
      Result.Child := UI.First_Child;
      return Result;
   end Get_Children;

   function Create_UIComponent (Parent : UIComponent_Access;
                                Tag    : access ASF.Views.Nodes.Tag_Node'Class)
                                return UIComponent_Access is
      Result : UIComponent_Access := new UIComponent;
   begin
      Append (Parent, Result, Tag);
      return Result;
   end Create_UIComponent;

   procedure Append (UI    : in UIComponent_Access;
                     Child : in UIComponent_Access;
                     Tag   : access ASF.Views.Nodes.Tag_Node'Class) is
   begin
      Child.Tag    := Tag;
      Child.Parent := UI;
      Child.Next   := null;
      if UI.Last_Child = null then
         UI.First_Child := Child;
      else
         UI.Last_Child.Next := Child;
      end if;
      UI.Last_Child := Child;
   end Append;

   --  ------------------------------
   --  Search for and return the {@link UIComponent} with an id
   --  that matches the specified search expression (if any), according to
   --  the algorithm described below.
   --  ------------------------------
   function Find (UI : UIComponent;
                  Name : String) return UIComponent_Access is
   begin
      return null;
   end Find;

   function Get_Context (UI : in UIComponent)
                         return ASF.Contexts.Faces.Faces_Context_Access is
   begin
      return ASF.Contexts.Faces.Current;
   end Get_Context;

   --  ------------------------------
   --  Check whether the component and its children must be rendered.
   --  ------------------------------
   function Is_Rendered (UI : UIComponent;
                         Context : Faces_Context'Class) return Boolean is
      Attr : constant EL.Objects.Object := UI.Get_Attribute (Context, "rendered");
   begin
      return EL.Objects.To_Boolean (Attr);
   end Is_Rendered;

   --  ------------------------------
   --  Set whether the component is rendered.
   --  ------------------------------
   procedure Set_Rendered (UI       : in out UIComponent;
                           Rendered : in Boolean) is
   begin
      null;
   end Set_Rendered;

   function Get_Attribute (UI      : UIComponent;
                           Context : Faces_Context'Class;
                           Name    : String) return EL.Objects.Object is
      N : Unbounded_String;
   begin
--        N := ASF.Views.Nodes.Get_Name (UI.Tag.all);
      if UI.Tag = null then
         return EL.Objects.Null_Object;
      end if;
--        Attr := ASF.Views.Nodes.Get_Attribute (UI.Tag.all, Name);
      raise Constraint_Error;
   end Get_Attribute;

   --  ------------------------------
   --  Get the attribute tag
   --  ------------------------------
   function Get_Attribute (UI      : UIComponent;
                           Name    : String)
                           return access ASF.Views.Nodes.Tag_Attribute is
   begin
      return null;
   end Get_Attribute;

   procedure Set_Attribute (UI    : in out UIComponent;
                            Name  : in String;
                            Value : in EL.Objects.Object) is
   begin
      null;
   end Set_Attribute;

   procedure Encode_Begin (UI      : in UIComponent;
                           Context : in out Faces_Context'Class) is
   begin
      null;
   end Encode_Begin;

   procedure Encode_Children (UI      : in UIComponent;
                              Context : in out Faces_Context'Class) is
      Child : UIComponent_Access := UI.First_Child;
   begin
      while Child /= null loop
         Child.Encode_All (Context);
         Child := Child.Next;
      end loop;
   end Encode_Children;

   procedure Encode_End (UI      : in UIComponent;
                         Context : in out Faces_Context'Class) is
   begin
      null;
   end Encode_End;

   procedure Encode_All (UI      : in UIComponent'Class;
                         Context : in out Faces_Context'Class) is
   begin
      UI.Encode_Begin (Context);
      UI.Encode_Children (Context);
      UI.Encode_End (Context);
   end Encode_All;

   function Get_Value (Attr : UIAttribute;
                       UI   : UIComponent'Class) return EL.Objects.Object is
   begin
      return EL.Objects.Null_Object;
--        if not Is_Null (Attr.Object) then
--           return Attr.Object;
--        else
--           return Attr.Definition.Binding.Get_Value (UI.Get_Context);
--        end if;
   end Get_Value;

   procedure Free_Component is
     new Ada.Unchecked_Deallocation (Object => UIComponent'Class,
                                     Name   => UIComponent_Access);

   --  ------------------------------
   --  Delete the component tree recursively.
   --  ------------------------------
   procedure Delete (UI : in out UIComponent_Access) is
   begin
      if UI /= null then
         declare
            C : UIComponent_Access := UI.First_Child;
         begin
            while C /= null loop
               UI.First_Child := C.Next;
               Delete (C);
               C := UI.First_Child;
            end loop;
         end;
         Free_Component (UI);
      end if;
   end Delete;

end ASF.Components;

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

with Ada.Unchecked_Deallocation;
with ASF.Views.Nodes;
package body ASF.Components is

   --  ------------------------------
   --  Get the parent component.
   --  Returns null if the node is the root element.
   --  ------------------------------
   function Get_Parent (UI : UIComponent) return UIComponent_Access is
   begin
      return UI.Parent;
   end Get_Parent;

   --  ------------------------------
   --  Return a client-side identifier for this component, generating
   --  one if necessary.
   --  ------------------------------
   function Get_Client_Id (UI : UIComponent) return Unbounded_String is
   begin
      return UI.Id;
   end Get_Client_Id;

   --  ------------------------------
   --  Get the list of children.
   --  ------------------------------
   function Get_Children (UI : UIComponent) return UIComponent_List is
      Result : UIComponent_List;
   begin
      Result.Child := UI.First_Child;
      return Result;
   end Get_Children;

   function Create_UIComponent (Parent : UIComponent_Access;
                                Tag    : access ASF.Views.Nodes.Tag_Node'Class)
                                return UIComponent_Access is
      Result : constant UIComponent_Access := new UIComponent;
   begin
      Append (Parent, Result, Tag);
      return Result;
   end Create_UIComponent;

   procedure Append (UI    : in UIComponent_Access;
                     Child : in UIComponent_Access;
                     Tag   : access ASF.Views.Nodes.Tag_Node'Class) is
   begin
      Child.Tag    := Tag;
      Child.Parent := UI;
      Child.Next   := null;
      if UI.Last_Child = null then
         UI.First_Child := Child;
      else
         UI.Last_Child.Next := Child;
      end if;
      UI.Last_Child := Child;
   end Append;

   --  ------------------------------
   --  Search for and return the {@link UIComponent} with an id
   --  that matches the specified search expression (if any), according to
   --  the algorithm described below.
   --  ------------------------------
   function Find (UI : UIComponent;
                  Name : String) return UIComponent_Access is
   begin
      return null;
   end Find;

   function Get_Context (UI : in UIComponent)
                         return ASF.Contexts.Faces.Faces_Context_Access is
   begin
      return ASF.Contexts.Faces.Current;
   end Get_Context;

   --  ------------------------------
   --  Check whether the component and its children must be rendered.
   --  ------------------------------
   function Is_Rendered (UI : UIComponent;
                         Context : Faces_Context'Class) return Boolean is
      Attr : constant EL.Objects.Object := UI.Get_Attribute (Context, "rendered");
   begin
      return EL.Objects.To_Boolean (Attr);
   end Is_Rendered;

   --  ------------------------------
   --  Set whether the component is rendered.
   --  ------------------------------
   procedure Set_Rendered (UI       : in out UIComponent;
                           Rendered : in Boolean) is
   begin
      null;
   end Set_Rendered;

   function Get_Attribute (UI      : UIComponent;
                           Context : Faces_Context'Class;
                           Name    : String) return EL.Objects.Object is
      Attr : constant access ASF.Views.Nodes.Tag_Attribute := UI.Get_Attribute (Name);
   begin
      if Attr = null then
         return EL.Objects.Null_Object;
      end if;
      return ASF.Views.Nodes.Get_Value (Attr.all, UI);
   end Get_Attribute;

   --  ------------------------------
   --  Get the attribute tag
   --  ------------------------------
   function Get_Attribute (UI      : UIComponent;
                           Name    : String)
                           return access ASF.Views.Nodes.Tag_Attribute is
   begin
      return null;
   end Get_Attribute;

   procedure Set_Attribute (UI    : in out UIComponent;
                            Name  : in String;
                            Value : in EL.Objects.Object) is
   begin
      null;
   end Set_Attribute;

   procedure Encode_Begin (UI      : in UIComponent;
                           Context : in out Faces_Context'Class) is
   begin
      null;
   end Encode_Begin;

   procedure Encode_Children (UI      : in UIComponent;
                              Context : in out Faces_Context'Class) is
      Child : UIComponent_Access := UI.First_Child;
   begin
      while Child /= null loop
         Child.Encode_All (Context);
         Child := Child.Next;
      end loop;
   end Encode_Children;

   procedure Encode_End (UI      : in UIComponent;
                         Context : in out Faces_Context'Class) is
   begin
      null;
   end Encode_End;

   procedure Encode_All (UI      : in UIComponent'Class;
                         Context : in out Faces_Context'Class) is
   begin
      UI.Encode_Begin (Context);
      UI.Encode_Children (Context);
      UI.Encode_End (Context);
   end Encode_All;

   --  ------------------------------
   --  Get the attribute value.
   --  ------------------------------
   function Get_Value (Attr : UIAttribute;
                       UI   : UIComponent'Class) return EL.Objects.Object is
   begin
      if not EL.Objects.Is_Null (Attr.Value) then
         return Attr.Value;
      else
         return ASF.Views.Nodes.Get_Value (Attr.Definition.all, UI);
      end if;
   end Get_Value;

   procedure Free_Component is
     new Ada.Unchecked_Deallocation (Object => UIComponent'Class,
                                     Name   => UIComponent_Access);

   --  ------------------------------
   --  Delete the component tree recursively.
   --  ------------------------------
   procedure Delete (UI : in out UIComponent_Access) is
   begin
      if UI /= null then
         declare
            C : UIComponent_Access := UI.First_Child;
         begin
            while C /= null loop
               UI.First_Child := C.Next;
               Delete (C);
               C := UI.First_Child;
            end loop;
         end;
         Free_Component (UI);
      end if;
   end Delete;

end ASF.Components;

Implement UIComponent.Get_Attribute

Implement UIComponent.Get_Attribute


-----------------------------------------------------------------------
--  gen-model-beans -- Ada Bean declarations
--  Copyright (C) 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.Unbounded;

with Util.Beans.Objects;

with Gen.Model.Tables;
with Gen.Model.Operations;
package Gen.Model.Beans is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Bean Definition
   --  ------------------------------
   type Bean_Definition is new Tables.Table_Definition with null record;
   type Bean_Definition_Access is access all Bean_Definition'Class;

   --  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 Bean_Definition;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Prepare the generation of the model.
   overriding
   procedure Prepare (O : in out Bean_Definition);

   --  Initialize the table definition instance.
   overriding
   procedure Initialize (O : in out Bean_Definition);

   --  Create an attribute with the given name and add it to the bean.
   procedure Add_Attribute (Bean   : in out Bean_Definition;
                            Name   : in Unbounded_String;
                            Column : out Gen.Model.Tables.Column_Definition_Access);

   --  Create a bean with the given name.
   function Create_Bean (Name : in Unbounded_String) return Bean_Definition_Access;

end Gen.Model.Beans;

-----------------------------------------------------------------------
--  gen-model-beans -- Ada Bean declarations
--  Copyright (C) 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.Unbounded;

with Util.Beans.Objects;

with Gen.Model.Tables;
package Gen.Model.Beans is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Bean Definition
   --  ------------------------------
   type Bean_Definition is new Tables.Table_Definition with null record;
   type Bean_Definition_Access is access all Bean_Definition'Class;

   --  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 Bean_Definition;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Prepare the generation of the model.
   overriding
   procedure Prepare (O : in out Bean_Definition);

   --  Initialize the table definition instance.
   overriding
   procedure Initialize (O : in out Bean_Definition);

   --  Create an attribute with the given name and add it to the bean.
   procedure Add_Attribute (Bean   : in out Bean_Definition;
                            Name   : in Unbounded_String;
                            Column : out Gen.Model.Tables.Column_Definition_Access);

   --  Create a bean with the given name.
   function Create_Bean (Name : in Unbounded_String) return Bean_Definition_Access;

end Gen.Model.Beans;

Fix compilation warning

Fix compilation warning


-----------------------------------------------------------------------
--  security-openid -- Open ID 2.0 Support
--  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.Unbounded;
with Ada.Calendar;
with Ada.Finalization;

--  == OpenID ==
--  The Security.Openid package implements an authentication framework based
--  on OpenID 2.0.
--
--  See OpenID Authentication 2.0 - Final
--  http://openid.net/specs/openid-authentication-2_0.html
--
--  There are basically two steps that an application must implement:
--
--    * Discovery to resolve and use the OpenID provider and redirect the user to the
--      provider authentication form.
--    * Verify to decode the authentication and check its result.
--
--  [http://ada-security.googlecode.com/svn/wiki/OpenID.png]
--
--  The authentication process is the following:
--
--    * The Initialize procedure is called to configure the OpenID realm and set the
--      OpenID return callback CB.
--    * The Discover procedure is called to retrieve from the OpenID provider the XRDS
--      stream and identify the provider.  An End_Point is returned.
--    * The Associate procedure is called to make the association with the End_Point.
--      The Association record holds session, and authentication.
--    * The Get_Authentication_URL builds the provider OpenID authentication
--      URL for the association.
--    * The application should redirect the user to the authentication URL.
--    * The OpenID provider authenticate the user and redirects the user to the callback CB.
--    * The association is decoded from the callback parameter.
--    * The Verify procedure is called with the association to check the result and
--      obtain the authentication results.
--
--
--  == Discovery: creating the authentication URL ==
--  The first step is to create an authentication URL to which the user must be redirected.
--  In this step, we have to create an OpenId manager, discover the OpenID provider,
--  do the association and get an End_Point.
--
--    Mgr   : Openid.Manager;
--    OP    : Openid.End_Point;
--    Assoc : constant Association_Access := new Association;
--
--  The
--
--    Server.Initialize (Mgr);
--    Mgr.Discover (Provider, OP);  --  Yadis discovery (get the XRDS file).
--    Mgr.Associate (OP, Assoc.all);--  Associate and get an end-point with a key.
--
--  After this first step, you must manage to save the association in the HTTP session.
--  Then you must redirect to the authentication URL that is obtained by using:
--
--    Auth_URL : constant String := Mgr.Get_Authentication_URL (OP, Assoc.all);
--
--  == Verify: acknowledge the authentication in the callback URL ==
--  The second step is done when the user has finished the authentication successfully or not.
--  For this step, the application must get back the association that was saved in the session.
--  It must also prepare a parameters object that allows the OpenID framework to get the
--  URI parameters from the return callback.
--
--    Mgr     : Openid.Manager;
--    Assoc   : Association_Access := ...;  --  Get the association saved in the session.
--    Auth    : Openid.Authentication;
--    Params  : Auth_Params;
--
--  The OpenID manager must be initialized and the Verify procedure is called with
--  the association, parameters and the authentication result.  The Get_Status function
--  must be used to check that the authentication succeeded.
--
--    Server.Initialize (Mgr);
--    Mgr.Verify (Assoc.all, Params, Auth);
--    if Openid.Get_Status (Auth) /= Openid.AUTHENTICATED then ...  -- Failure.
--
--
--
package Security.Openid is

   Invalid_End_Point : exception;

   Service_Error     : exception;

   type Parameters is limited interface;

   function Get_Parameter (Params : in Parameters;
                           Name   : in String) return String is abstract;

   --  ------------------------------
   --  OpenID provider
   --  ------------------------------
   --  The End_Point represents the OpenID provider that will authenticate
   --  the user.
   type End_Point is private;

   function To_String (OP : End_Point) return String;

   --  ------------------------------
   --  Association
   --  ------------------------------
   --  The OpenID association contains the shared secret between the relying party
   --  and the OpenID provider.  The association can be cached and reused to authenticate
   --  different users using the same OpenID provider.  The association also has an
   --  expiration date.
   type Association is private;

   --  Dump the association as a string (for debugging purposes)
   function To_String (Assoc : Association) return String;

   type Auth_Result is (AUTHENTICATED, CANCEL, SETUP_NEEDED, UNKNOWN, INVALID_SIGNATURE);

   --  ------------------------------
   --  OpenID provider
   --  ------------------------------
   --
   type Authentication is private;

   --  Get the email address
   function Get_Email (Auth : in Authentication) return String;

   --  Get the user first name.
   function Get_First_Name (Auth : in Authentication) return String;

   --  Get the user last name.
   function Get_Last_Name (Auth : in Authentication) return String;

   --  Get the user full name.
   function Get_Full_Name (Auth : in Authentication) return String;

   --  Get the user identity.
   function Get_Identity (Auth : in Authentication) return String;

   --  Get the user claimed identity.
   function Get_Claimed_Id (Auth : in Authentication) return String;

   --  Get the user language.
   function Get_Language (Auth : in Authentication) return String;

   --  Get the user country.
   function Get_Country (Auth : in Authentication) return String;

   --  Get the result of the authentication.
   function Get_Status (Auth : in Authentication) return Auth_Result;

   --  ------------------------------
   --  OpenID Default principal
   --  ------------------------------
   type Principal is new Security.Principal with private;
   type Principal_Access is access all Principal'Class;

   --  Get the principal name.
   function Get_Name (From : in Principal) return String;

   --  Get the user email address.
   function Get_Email (From : in Principal) return String;

   --  Get the authentication data.
   function Get_Authentication (From : in Principal) return Authentication;

   --  Create a principal with the given authentication results.
   function Create_Principal (Auth : in Authentication) return Principal_Access;

   --  ------------------------------
   --  OpenID Manager
   --  ------------------------------
   --  The Manager provides the core operations for the OpenID process.
   type Manager is tagged limited private;

   --  Initialize the OpenID realm.
   procedure Initialize (Realm     : in out Manager;
                         Name      : in String;
                         Return_To : in String);

   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  (See OpenID Section 7.3 Discovery)
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point);

   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association);

   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String;

   --  Verify the authentication result
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication);

   --  Verify the authentication result
   procedure Verify_Discovered (Realm   : in out Manager;
                                Assoc   : in Association;
                                Request : in Parameters'Class;
                                Result  : out Authentication);

   --  Verify the signature part of the result
   procedure Verify_Signature (Realm   : in Manager;
                               Assoc   : in Association;
                               Request : in Parameters'Class;
                               Result  : in out Authentication);

   --  Read the XRDS document from the URI and initialize the OpenID provider end point.
   procedure Discover_XRDS (Realm  : in out Manager;
                            URI    : in String;
                            Result : out End_Point);

   --  Extract from the XRDS content the OpenID provider URI.
   --  The default implementation is very basic as it returns the first <URI>
   --  available in the stream without validating the XRDS document.
   --  Raises the Invalid_End_Point exception if the URI cannot be found.
   procedure Extract_XRDS (Realm   : in out Manager;
                           Content : in String;
                           Result  : out End_Point);

private

   use Ada.Strings.Unbounded;

   type Association is record
      Session_Type : Unbounded_String;
      Assoc_Type   : Unbounded_String;
      Assoc_Handle : Unbounded_String;
      Mac_Key      : Unbounded_String;
      Expired      : Ada.Calendar.Time;
   end record;

   type Authentication is record
      Status     : Auth_Result;
      Identity   : Unbounded_String;
      Claimed_Id : Unbounded_String;
      Email      : Unbounded_String;
      Full_Name  : Unbounded_String;
      First_Name : Unbounded_String;
      Last_Name  : Unbounded_String;
      Language   : Unbounded_String;
      Country    : Unbounded_String;
      Gender     : Unbounded_String;
      Timezone   : Unbounded_String;
      Nickname   : Unbounded_String;
   end record;

   type End_Point is record
      URL        : Unbounded_String;
      Alias      : Unbounded_String;
      Expired    : Ada.Calendar.Time;
   end record;

   type Manager is new Ada.Finalization.Limited_Controlled with record
      Realm     : Unbounded_String;
      Return_To : Unbounded_String;
   end record;

   type Principal is new Security.Principal with record
      Auth : Authentication;
   end record;

end Security.Openid;

-----------------------------------------------------------------------
--  security-openid -- Open ID 2.0 Support
--  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.Unbounded;
with Ada.Calendar;
with Ada.Finalization;

--  == OpenID ==
--  The Security.Openid package implements an authentication framework based
--  on OpenID 2.0.
--
--  See OpenID Authentication 2.0 - Final
--  http://openid.net/specs/openid-authentication-2_0.html
--
--  There are basically two steps that an application must implement:
--
--    * Discovery: to resolve and use the OpenID provider and redirect the user to the
--      provider authentication form.
--    * Verify: to decode the authentication and check its result.
--
--  [http://ada-security.googlecode.com/svn/wiki/OpenID.png]
--
--  The authentication process is the following:
--
--    * The application should redirect the user to the authentication URL.
--    * The OpenID provider authenticate the user and redirects the user to the callback CB.
--    * The association is decoded from the callback parameter.
--    * The Verify procedure is called with the association to check the result and
--      obtain the authentication results.
--
--  === Initialization ===
--  The initialization process must be done before each two steps (discovery and verify).
--  The OpenID manager must be declared and configured.
--
--    Mgr   : Openid.Manager;
--
--  For the configuration, the Initialize procedure is called to configure
--  the OpenID realm and set the OpenID return callback CB.  The return callback
--  must be a valid URL that is based on the realm.  Example:
--
--    Mgr.Initialize (Name      => "http://app.site.com/auth",
--                    Return_To => "http://app.site.com/auth/verify");
--
--  After this initialization, the OpenID manager can be used in the authentication process.
--
--  === Discovery: creating the authentication URL ===
--  The first step is to create an authentication URL to which the user must be redirected.
--  In this step, we have to create an OpenId manager, discover the OpenID provider,
--  do the association and get an End_Point.
--
--    OP    : Openid.End_Point;
--    Assoc : constant Association_Access := new Association;
--
--  The following steps are performed:
--
--    * The Discover procedure is called to retrieve from the OpenID provider the XRDS
--      stream and identify the provider.  An End_Point is returned in <tt>OP</tt>.
--    * The Associate procedure is called to make the association with the End_Point.
--      The Association record holds session, and authentication.
--
--    Mgr.Discover (Provider, OP);  --  Yadis discovery (get the XRDS file).
--    Mgr.Associate (OP, Assoc.all);--  Associate and get an end-point with a key.
--
--  After this first step, you must manage to save the association in the HTTP session.
--  Then you must redirect to the authentication URL that is obtained by using:
--
--    Auth_URL : constant String := Mgr.Get_Authentication_URL (OP, Assoc.all);
--
--  === Verify: acknowledge the authentication in the callback URL ===
--  The second step is done when the user has finished the authentication successfully or not.
--  For this step, the application must get back the association that was saved in the session.
--  It must also prepare a parameters object that allows the OpenID framework to get the
--  URI parameters from the return callback.
--
--    Assoc   : Association_Access := ...;  --  Get the association saved in the session.
--    Auth    : Openid.Authentication;
--    Params  : Auth_Params;
--
--  The OpenID manager must be initialized and the Verify procedure is called with
--  the association, parameters and the authentication result.  The Get_Status function
--  must be used to check that the authentication succeeded.
--
--    Mgr.Verify (Assoc.all, Params, Auth);
--    if Openid.Get_Status (Auth) /= Openid.AUTHENTICATED then ...  -- Failure.
--
--
--
package Security.Openid is

   Invalid_End_Point : exception;

   Service_Error     : exception;

   type Parameters is limited interface;

   function Get_Parameter (Params : in Parameters;
                           Name   : in String) return String is abstract;

   --  ------------------------------
   --  OpenID provider
   --  ------------------------------
   --  The End_Point represents the OpenID provider that will authenticate
   --  the user.
   type End_Point is private;

   function To_String (OP : End_Point) return String;

   --  ------------------------------
   --  Association
   --  ------------------------------
   --  The OpenID association contains the shared secret between the relying party
   --  and the OpenID provider.  The association can be cached and reused to authenticate
   --  different users using the same OpenID provider.  The association also has an
   --  expiration date.
   type Association is private;

   --  Dump the association as a string (for debugging purposes)
   function To_String (Assoc : Association) return String;

   type Auth_Result is (AUTHENTICATED, CANCEL, SETUP_NEEDED, UNKNOWN, INVALID_SIGNATURE);

   --  ------------------------------
   --  OpenID provider
   --  ------------------------------
   --
   type Authentication is private;

   --  Get the email address
   function Get_Email (Auth : in Authentication) return String;

   --  Get the user first name.
   function Get_First_Name (Auth : in Authentication) return String;

   --  Get the user last name.
   function Get_Last_Name (Auth : in Authentication) return String;

   --  Get the user full name.
   function Get_Full_Name (Auth : in Authentication) return String;

   --  Get the user identity.
   function Get_Identity (Auth : in Authentication) return String;

   --  Get the user claimed identity.
   function Get_Claimed_Id (Auth : in Authentication) return String;

   --  Get the user language.
   function Get_Language (Auth : in Authentication) return String;

   --  Get the user country.
   function Get_Country (Auth : in Authentication) return String;

   --  Get the result of the authentication.
   function Get_Status (Auth : in Authentication) return Auth_Result;

   --  ------------------------------
   --  OpenID Default principal
   --  ------------------------------
   type Principal is new Security.Principal with private;
   type Principal_Access is access all Principal'Class;

   --  Get the principal name.
   function Get_Name (From : in Principal) return String;

   --  Get the user email address.
   function Get_Email (From : in Principal) return String;

   --  Get the authentication data.
   function Get_Authentication (From : in Principal) return Authentication;

   --  Create a principal with the given authentication results.
   function Create_Principal (Auth : in Authentication) return Principal_Access;

   --  ------------------------------
   --  OpenID Manager
   --  ------------------------------
   --  The Manager provides the core operations for the OpenID process.
   type Manager is tagged limited private;

   --  Initialize the OpenID realm.
   procedure Initialize (Realm     : in out Manager;
                         Name      : in String;
                         Return_To : in String);

   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  (See OpenID Section 7.3 Discovery)
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point);

   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association);

   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String;

   --  Verify the authentication result
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication);

   --  Verify the authentication result
   procedure Verify_Discovered (Realm   : in out Manager;
                                Assoc   : in Association;
                                Request : in Parameters'Class;
                                Result  : out Authentication);

   --  Verify the signature part of the result
   procedure Verify_Signature (Realm   : in Manager;
                               Assoc   : in Association;
                               Request : in Parameters'Class;
                               Result  : in out Authentication);

   --  Read the XRDS document from the URI and initialize the OpenID provider end point.
   procedure Discover_XRDS (Realm  : in out Manager;
                            URI    : in String;
                            Result : out End_Point);

   --  Extract from the XRDS content the OpenID provider URI.
   --  The default implementation is very basic as it returns the first <URI>
   --  available in the stream without validating the XRDS document.
   --  Raises the Invalid_End_Point exception if the URI cannot be found.
   procedure Extract_XRDS (Realm   : in out Manager;
                           Content : in String;
                           Result  : out End_Point);

private

   use Ada.Strings.Unbounded;

   type Association is record
      Session_Type : Unbounded_String;
      Assoc_Type   : Unbounded_String;
      Assoc_Handle : Unbounded_String;
      Mac_Key      : Unbounded_String;
      Expired      : Ada.Calendar.Time;
   end record;

   type Authentication is record
      Status     : Auth_Result;
      Identity   : Unbounded_String;
      Claimed_Id : Unbounded_String;
      Email      : Unbounded_String;
      Full_Name  : Unbounded_String;
      First_Name : Unbounded_String;
      Last_Name  : Unbounded_String;
      Language   : Unbounded_String;
      Country    : Unbounded_String;
      Gender     : Unbounded_String;
      Timezone   : Unbounded_String;
      Nickname   : Unbounded_String;
   end record;

   type End_Point is record
      URL        : Unbounded_String;
      Alias      : Unbounded_String;
      Expired    : Ada.Calendar.Time;
   end record;

   type Manager is new Ada.Finalization.Limited_Controlled with record
      Realm     : Unbounded_String;
      Return_To : Unbounded_String;
   end record;

   type Principal is new Security.Principal with record
      Auth : Authentication;
   end record;

end Security.Openid;

Update the documentation

Update the documentation