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

package body Util.Serialize.Mappers.Vector_Mapper is

   use Vectors;
   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Util.Serialize.Mappers.Vector_Mapper",
                                                    Util.Log.WARN_LEVEL);

   Key : Util.Serialize.Contexts.Data_Key;

   --  -----------------------
   --  Data context
   --  -----------------------
   --  Data context to get access to the target element.

   --  -----------------------
   --  Get the vector object.
   --  -----------------------
   function Get_Vector (Data : in Vector_Data) return Vector_Type_Access is
   begin
      return Data.Vector;
   end Get_Vector;

   --  -----------------------
   --  Set the vector object.
   --  -----------------------
   procedure Set_Vector (Data   : in out Vector_Data;
                         Vector : in Vector_Type_Access) is
   begin
      Data.Vector := Vector;
   end Set_Vector;

   --  -----------------------
   --  Record mapper
   --  -----------------------

   --  -----------------------
   --  Set the Data vector in the context.
   --  -----------------------
   procedure Set_Context (Ctx  : in out Util.Serialize.Contexts.Context'Class;
                          Data : in Vector_Type_Access) is
      Data_Context : Vector_Data_Access := new Vector_Data;
   begin
      Data_Context.Vector   := Data;
      Data_Context.Position := Index_Type'First;
      Ctx.Set_Data (Key => Key, Content => Data_Context.all'Unchecked_Access);
   end Set_Context;

   --  -----------------------
   --  Execute the mapping operation on the object associated with the current context.
   --  The object is extracted from the context and the Execute operation is called.
   --  -----------------------
   procedure Execute (Handler : in Mapper;
                      Map     : in Mapping'Class;
                      Ctx     : in out Util.Serialize.Contexts.Context'Class;
                      Value   : in Util.Beans.Objects.Object) is
      pragma Unreferenced (Handler);

      procedure Process (Element : in out Element_Type);

      procedure Process (Element : in out Element_Type) is
      begin
         Element_Mapper.Set_Member (Map, Element, Value);
      end Process;

      D : constant Contexts.Data_Access := Ctx.Get_Data (Key);
   begin
      Log.Debug ("Updating vector element");

      if not (D.all in Vector_Data'Class) then
         raise Util.Serialize.Contexts.No_Data;
      end if;
      declare
         DE : constant Vector_Data_Access := Vector_Data'Class (D.all)'Access;
      begin
         if DE.Vector = null then
            raise Util.Serialize.Contexts.No_Data;
         end if;
         --  Update the element through the generic procedure
         Update_Element (DE.Vector.all, DE.Position - 1, Process'Access);
      end;
   end Execute;

   procedure Set_Mapping (Into  : in out Mapper;
                          Inner : in Element_Mapper.Mapper_Access) is
   begin
      Into.Mapper := Inner.all'Unchecked_Access;
      Into.Map.Bind (Inner);
   end Set_Mapping;

   --  -----------------------
   --  Find the mapper associated with the given name.
   --  Returns null if there is no mapper.
   --  -----------------------
   function Find_Mapper (Controller : in Mapper;
                         Name       : in String) return Util.Serialize.Mappers.Mapper_Access is
   begin
      return Controller.Mapper.Find_Mapper (Name);
   end Find_Mapper;

   overriding
   procedure Initialize (Controller : in out Mapper) is
   begin
      Controller.Mapper := Controller.Map'Unchecked_Access;
   end Initialize;

   procedure Start_Object (Handler : in Mapper;
                           Context : in out Util.Serialize.Contexts.Context'Class;
                           Name    : in String) is
      pragma Unreferenced (Handler);

      procedure Set_Context (Item : in out Element_Type);

      D : constant Contexts.Data_Access := Context.Get_Data (Key);

      procedure Set_Context (Item : in out Element_Type) is
      begin
         Element_Mapper.Set_Context (Ctx => Context, Element => Item'Unrestricted_Access);
      end Set_Context;

   begin
      Log.Debug ("Creating vector element {0}", Name);

      if not (D.all in Vector_Data'Class) then
         raise Util.Serialize.Contexts.No_Data;
      end if;
      declare
         DE : constant Vector_Data_Access := Vector_Data'Class (D.all)'Access;
      begin
         if DE.Vector = null then
            raise Util.Serialize.Contexts.No_Data;
         end if;
         Insert_Space (DE.Vector.all, DE.Position);
         DE.Vector.Update_Element (Index => DE.Position, Process => Set_Context'Access);
         DE.Position := DE.Position + 1;
      end;
   end Start_Object;

   procedure Finish_Object (Handler : in Mapper;
                            Context : in out Util.Serialize.Contexts.Context'Class;
                            Name    : in String) is
   begin
      null;
   end Finish_Object;

   --  -----------------------
   --  Write the element on the stream using the mapper description.
   --  -----------------------
   procedure Write (Handler : in Mapper;
                    Stream  : in out Util.Serialize.IO.Output_Stream'Class;
                    Element : in Vectors.Vector) is
      Pos : Vectors.Cursor := Element.First;
   begin
      Stream.Start_Array (Element.Length);
      while Vectors.Has_Element (Pos) loop
         Element_Mapper.Write (Handler.Mapper.all, Handler.Map.Get_Getter,
                               Stream, Vectors.Element (Pos));
         Vectors.Next (Pos);
      end loop;
      Stream.End_Array;
   end Write;

begin
   --  Allocate the unique data key.
   Util.Serialize.Contexts.Allocate (Key);
end Util.Serialize.Mappers.Vector_Mapper;

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

package body Util.Serialize.Mappers.Vector_Mapper is

   use Vectors;
   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Util.Serialize.Mappers.Vector_Mapper",
                                                    Util.Log.WARN_LEVEL);

   Key : Util.Serialize.Contexts.Data_Key;

   --  -----------------------
   --  Data context
   --  -----------------------
   --  Data context to get access to the target element.

   --  -----------------------
   --  Get the vector object.
   --  -----------------------
   function Get_Vector (Data : in Vector_Data) return Vector_Type_Access is
   begin
      return Data.Vector;
   end Get_Vector;

   --  -----------------------
   --  Set the vector object.
   --  -----------------------
   procedure Set_Vector (Data   : in out Vector_Data;
                         Vector : in Vector_Type_Access) is
   begin
      Data.Vector := Vector;
   end Set_Vector;

   --  -----------------------
   --  Record mapper
   --  -----------------------

   --  -----------------------
   --  Set the Data vector in the context.
   --  -----------------------
   procedure Set_Context (Ctx  : in out Util.Serialize.Contexts.Context'Class;
                          Data : in Vector_Type_Access) is
      Data_Context : constant Vector_Data_Access := new Vector_Data;
   begin
      Data_Context.Vector   := Data;
      Data_Context.Position := Index_Type'First;
      Ctx.Set_Data (Key => Key, Content => Data_Context.all'Unchecked_Access);
   end Set_Context;

   --  -----------------------
   --  Execute the mapping operation on the object associated with the current context.
   --  The object is extracted from the context and the Execute operation is called.
   --  -----------------------
   procedure Execute (Handler : in Mapper;
                      Map     : in Mapping'Class;
                      Ctx     : in out Util.Serialize.Contexts.Context'Class;
                      Value   : in Util.Beans.Objects.Object) is
      pragma Unreferenced (Handler);

      procedure Process (Element : in out Element_Type);

      procedure Process (Element : in out Element_Type) is
      begin
         Element_Mapper.Set_Member (Map, Element, Value);
      end Process;

      D : constant Contexts.Data_Access := Ctx.Get_Data (Key);
   begin
      Log.Debug ("Updating vector element");

      if not (D.all in Vector_Data'Class) then
         raise Util.Serialize.Contexts.No_Data;
      end if;
      declare
         DE : constant Vector_Data_Access := Vector_Data'Class (D.all)'Access;
      begin
         if DE.Vector = null then
            raise Util.Serialize.Contexts.No_Data;
         end if;
         --  Update the element through the generic procedure
         Update_Element (DE.Vector.all, DE.Position - 1, Process'Access);
      end;
   end Execute;

   procedure Set_Mapping (Into  : in out Mapper;
                          Inner : in Element_Mapper.Mapper_Access) is
   begin
      Into.Mapper := Inner.all'Unchecked_Access;
      Into.Map.Bind (Inner);
   end Set_Mapping;

   --  -----------------------
   --  Find the mapper associated with the given name.
   --  Returns null if there is no mapper.
   --  -----------------------
   function Find_Mapper (Controller : in Mapper;
                         Name       : in String) return Util.Serialize.Mappers.Mapper_Access is
   begin
      return Controller.Mapper.Find_Mapper (Name);
   end Find_Mapper;

   overriding
   procedure Initialize (Controller : in out Mapper) is
   begin
      Controller.Mapper := Controller.Map'Unchecked_Access;
   end Initialize;

   procedure Start_Object (Handler : in Mapper;
                           Context : in out Util.Serialize.Contexts.Context'Class;
                           Name    : in String) is
      pragma Unreferenced (Handler);

      procedure Set_Context (Item : in out Element_Type);

      D : constant Contexts.Data_Access := Context.Get_Data (Key);

      procedure Set_Context (Item : in out Element_Type) is
      begin
         Element_Mapper.Set_Context (Ctx => Context, Element => Item'Unrestricted_Access);
      end Set_Context;

   begin
      Log.Debug ("Creating vector element {0}", Name);

      if not (D.all in Vector_Data'Class) then
         raise Util.Serialize.Contexts.No_Data;
      end if;
      declare
         DE : constant Vector_Data_Access := Vector_Data'Class (D.all)'Access;
      begin
         if DE.Vector = null then
            raise Util.Serialize.Contexts.No_Data;
         end if;
         Insert_Space (DE.Vector.all, DE.Position);
         DE.Vector.Update_Element (Index => DE.Position, Process => Set_Context'Access);
         DE.Position := DE.Position + 1;
      end;
   end Start_Object;

   procedure Finish_Object (Handler : in Mapper;
                            Context : in out Util.Serialize.Contexts.Context'Class;
                            Name    : in String) is
   begin
      null;
   end Finish_Object;

   --  -----------------------
   --  Write the element on the stream using the mapper description.
   --  -----------------------
   procedure Write (Handler : in Mapper;
                    Stream  : in out Util.Serialize.IO.Output_Stream'Class;
                    Element : in Vectors.Vector) is
      Pos : Vectors.Cursor := Element.First;
   begin
      Stream.Start_Array (Element.Length);
      while Vectors.Has_Element (Pos) loop
         Element_Mapper.Write (Handler.Mapper.all, Handler.Map.Get_Getter,
                               Stream, Vectors.Element (Pos));
         Vectors.Next (Pos);
      end loop;
      Stream.End_Array;
   end Write;

begin
   --  Allocate the unique data key.
   Util.Serialize.Contexts.Allocate (Key);
end Util.Serialize.Mappers.Vector_Mapper;

Fix compilation warning reported by gcc 4.7


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

with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with Util.Beans.Basic;
package Util.Beans.Objects.Maps is

   package Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Object,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   subtype Cursor is Maps.Cursor;
   subtype Map is Maps.Map;

   --  Make all the Maps operations available (a kind of 'use Maps' for anybody).
   function Length (Container : in Map) return Ada.Containers.Count_Type renames Maps.Length;
   function Is_Empty (Container : in Map) return Boolean renames Maps.Is_Empty;
   procedure Clear (Container : in out Map) renames Maps.Clear;
   function Key (Position : Cursor) return String renames Maps.Key;

   procedure Include (Container : in out Map;
                      Key : in String;
                      New_Item : in Object) renames Maps.Include;
   procedure Query_Element (Position : in Cursor;
                            Process  : not null access procedure (Key     : String;
                                                                  Element : Object))
                            renames Maps.Query_Element;

   function Has_Element (Position : Cursor) return Boolean renames Maps.Has_Element;
   function Element (Position : Cursor) return Object renames Maps.Element;
   procedure Next (Position : in out Cursor) renames Maps.Next;
   function Next (Position : Cursor) return Cursor renames Maps.Next;
   function Equivalent_Keys (Left, Right : Cursor) return Boolean renames Maps.Equivalent_Keys;
   function Equivalent_Keys (Left : Cursor; Right : String) return Boolean
                             renames Maps.Equivalent_Keys;
   function Equivalent_Keys (Left : String; Right : Cursor) return Boolean
                             renames Maps.Equivalent_Keys;
   function Copy (Source : Maps.Map; Capacity : in Ada.Containers.Count_Type) return Maps.Map
     renames Maps.Copy;

   --  ------------------------------
   --  Map Bean
   --  ------------------------------
   --  The Map_Bean is a map of objects that also exposes the Bean interface.
   --  This allows the map to be available and accessed from an Object instance.
   type Map_Bean is new Maps.Map and Util.Beans.Basic.Bean with private;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   function Get_Value (From : in Map_Bean;
                       Name : in String) return Object;

   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   procedure Set_Value (From  : in out Map_Bean;
                        Name  : in String;
                        Value : in Object);

   --  Create an object that contains a <tt>Map_Bean</tt> instance.
   function Create return Object;

private

   type Map_Bean is new Maps.Map and Util.Beans.Basic.Bean with null record;

end Util.Beans.Objects.Maps;

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

with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with Util.Beans.Basic;
package Util.Beans.Objects.Maps is

   package Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Object,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   subtype Cursor is Maps.Cursor;
   subtype Map is Maps.Map;

   --  Make all the Maps operations available (a kind of 'use Maps' for anybody).
   function Length (Container : in Map) return Ada.Containers.Count_Type renames Maps.Length;
   function Is_Empty (Container : in Map) return Boolean renames Maps.Is_Empty;
   procedure Clear (Container : in out Map) renames Maps.Clear;
   function Key (Position : Cursor) return String renames Maps.Key;

   procedure Include (Container : in out Map;
                      Key : in String;
                      New_Item : in Object) renames Maps.Include;
   procedure Query_Element (Position : in Cursor;
                            Process  : not null access procedure (Key     : String;
                                                                  Element : Object))
                            renames Maps.Query_Element;

   function Has_Element (Position : Cursor) return Boolean renames Maps.Has_Element;
   function Element (Position : Cursor) return Object renames Maps.Element;
   procedure Next (Position : in out Cursor) renames Maps.Next;
   function Next (Position : Cursor) return Cursor renames Maps.Next;
   function Equivalent_Keys (Left, Right : Cursor) return Boolean renames Maps.Equivalent_Keys;
   function Equivalent_Keys (Left : Cursor; Right : String) return Boolean
                             renames Maps.Equivalent_Keys;
   function Equivalent_Keys (Left : String; Right : Cursor) return Boolean
                             renames Maps.Equivalent_Keys;
   function Copy (Source : Maps.Map; Capacity : in Ada.Containers.Count_Type) return Maps.Map
     renames Maps.Copy;

   --  ------------------------------
   --  Map Bean
   --  ------------------------------
   --  The Map_Bean is a map of objects that also exposes the Bean interface.
   --  This allows the map to be available and accessed from an Object instance.
   type Map_Bean is new Maps.Map and Util.Beans.Basic.Bean with private;
   type Map_Bean_Access is access all Map_Bean'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   function Get_Value (From : in Map_Bean;
                       Name : in String) return Object;

   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   procedure Set_Value (From  : in out Map_Bean;
                        Name  : in String;
                        Value : in Object);

   --  Create an object that contains a <tt>Map_Bean</tt> instance.
   function Create return Object;

private

   type Map_Bean is new Maps.Map and Util.Beans.Basic.Bean with null record;

end Util.Beans.Objects.Maps;

Declare the Map_Bean_Access type

Declare the Map_Bean_Access type


with Test;
with OpenAL.Context;
with OpenAL.Context.Error;

procedure init_001 is
  package ALC       renames OpenAL.Context;
  package ALC_Error renames OpenAL.Context.Error;

  Device     : ALC.Device_t;
  Context    : ALC.Context_t;
  Current_OK : Boolean;
  TC         : Test.Context_t;

  use type ALC.Device_t;
  use type ALC.Context_t;
  use type ALC_Error.Error_t;
begin
  Test.Initialize
    (Test_Context => TC,
     Program      => "init_001",
     Test_DB      => "TEST_DB",
     Test_Results => "TEST_RESULTS");

  Device := ALC.Open_Default_Device;
  Test.Check (TC, 1, Device /= ALC.Invalid_Device, "Device /= ALC.Invalid_Device");
  Test.Check (TC, 2, ALC_Error.Get_Error (Device) = ALC_Error.No_Error,
    "ALC_Error.Get_Error (Device) = ALC_Error.No_Error");

  Context := ALC.Create_Context (Device);
  Test.Check (TC, 3, Context /= ALC.Invalid_Context, "Context /= ALC.Invalid_Context");
  Test.Check (TC, 4, ALC_Error.Get_Error (Device) = ALC_Error.No_Error,
    "ALC_Error.Get_Error (Device) = ALC_Error.No_Error");

  Current_OK := ALC.Make_Context_Current (Context);
  Test.Check (TC, 5, Current_OK, "Current_OK");
  Test.Check (TC, 6, ALC_Error.Get_Error (Device) = ALC_Error.No_Error,
    "ALC_Error.Get_Error (Device) = ALC_Error.No_Error");

  Current_OK := ALC.Make_Context_Current (ALC.Null_Context);
  Test.Check (TC, 7, Current_OK, "Current_OK");
  Test.Check (TC, 8, ALC_Error.Get_Error (Device) = ALC_Error.No_Error,
    "ALC_Error.Get_Error (Device) = ALC_Error.No_Error");

  ALC.Destroy_Context (Context);
  Test.Check (TC, 9, ALC_Error.Get_Error (Device) = ALC_Error.No_Error,
    "ALC_Error.Get_Error (Device) = ALC_Error.No_Error");

  ALC.Close_Device (Device);
  Test.Check (TC, 10, Device = ALC.Invalid_Device,
    "Device = ALC.Invalid_Device");
end init_001;

with Test;
with OpenAL.Context;
with OpenAL.Context.Error;

procedure init_001 is
  package ALC       renames OpenAL.Context;
  package ALC_Error renames OpenAL.Context.Error;

  Device     : ALC.Device_t;
  Context    : ALC.Context_t;
  Current_OK : Boolean;
  TC         : Test.Context_t;

  use type ALC.Device_t;
  use type ALC.Context_t;
  use type ALC_Error.Error_t;
begin
  Test.Initialize
    (Test_Context => TC,
     Program      => "init_001",
     Test_DB      => "TEST_DB",
     Test_Results => "TEST_RESULTS");

  Device := ALC.Open_Default_Device;
  Test.Check (TC, 1, Device /= ALC.Invalid_Device, "Device /= ALC.Invalid_Device");
  Test.Check (TC, 2, ALC_Error.Get_Error (Device) = ALC_Error.No_Error,
    "ALC_Error.Get_Error (Device) = ALC_Error.No_Error");

  pragma Assert (Device /= ALC.Invalid_Device);

  Context := ALC.Create_Context (Device);
  Test.Check (TC, 3, Context /= ALC.Invalid_Context, "Context /= ALC.Invalid_Context");
  Test.Check (TC, 4, ALC_Error.Get_Error (Device) = ALC_Error.No_Error,
    "ALC_Error.Get_Error (Device) = ALC_Error.No_Error");

  pragma Assert (Context /= ALC.Invalid_Context);

  Current_OK := ALC.Make_Context_Current (Context);
  Test.Check (TC, 5, Current_OK, "Current_OK");
  Test.Check (TC, 6, ALC_Error.Get_Error (Device) = ALC_Error.No_Error,
    "ALC_Error.Get_Error (Device) = ALC_Error.No_Error");

  Current_OK := ALC.Make_Context_Current (ALC.Null_Context);
  Test.Check (TC, 7, Current_OK, "Current_OK");
  Test.Check (TC, 8, ALC_Error.Get_Error (Device) = ALC_Error.No_Error,
    "ALC_Error.Get_Error (Device) = ALC_Error.No_Error");

  ALC.Destroy_Context (Context);
  Test.Check (TC, 9, ALC_Error.Get_Error (Device) = ALC_Error.No_Error,
    "ALC_Error.Get_Error (Device) = ALC_Error.No_Error");

  ALC.Close_Device (Device);
  Test.Check (TC, 10, Device = ALC.Invalid_Device,
    "Device = ALC.Invalid_Device");
end init_001;

Add assertions before running tests that may give incorrect results dependent on previous tests


--  SPDX-License-Identifier: Apache-2.0
--
--  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 Ada.Containers.Indefinite_Holders;

with GL.Low_Level.Enums;
with GL.Objects.Programs.Uniforms;
with GL.Objects.Textures;
with GL.Types;

with Orka.Transforms.Singles.Matrices;
with Orka.Transforms.Doubles.Matrices;

package Orka.Rendering.Programs.Uniforms is
   pragma Preelaborate;

   package LE renames GL.Low_Level.Enums;

   use type LE.Texture_Kind;
   use type LE.Resource_Type;

   package TS renames Transforms.Singles.Matrices;
   package TD renames Transforms.Doubles.Matrices;

   type Uniform (Kind : LE.Resource_Type) is tagged private;

   procedure Set_Matrix (Object : Uniform; Value : TS.Matrix4);
   procedure Set_Matrix (Object : Uniform; Value : TD.Matrix4);

   procedure Set_Vector (Object : Uniform; Value : TS.Vector4);
   procedure Set_Vector (Object : Uniform; Value : TD.Vector4);

   procedure Set_Single (Object : Uniform; Value : GL.Types.Single);

   procedure Set_Double (Object : Uniform; Value : GL.Types.Double);

   procedure Set_Int (Object : Uniform; Value : GL.Types.Int);

   procedure Set_UInt (Object : Uniform; Value : GL.Types.UInt);

   procedure Set_Boolean (Object : Uniform; Value : Boolean);

   function GL_Uniform (Object : Uniform) return GL.Objects.Programs.Uniforms.Uniform
     with Inline;

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

   type Uniform_Sampler (Kind : LE.Texture_Kind) is tagged private;

   procedure Set_Texture
     (Object  : Uniform_Sampler;
      Texture : GL.Objects.Textures.Texture_Base'Class;
      Binding : Natural)
   with Pre => Texture.Kind = Object.Kind;
   --  TODO Add pre condition to check Texture.Format matches Sampler_Kind
   --  (see https://www.khronos.org/opengl/wiki/Sampler_(GLSL)#Sampler_types)
   --  Set the binding point of the uniform sampler and bind the
   --  given texture to the corresponding texture unit

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

   type Uniform_Image (Kind : LE.Texture_Kind) is tagged private;

   procedure Set_Image
     (Object  : Uniform_Image;
      Texture : GL.Objects.Textures.Texture_Base'Class;
      Binding : Natural)
   with Pre => Texture.Kind = Object.Kind;

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

   type Uniform_Subroutine (<>) is tagged limited private;

   function Is_Compatible
     (Object : Uniform_Subroutine;
      Index  : Subroutine_Index) return Boolean;
   --  Return True if the index is a compatible subroutine function
   --  for the subroutine uniform, False otherwise

   procedure Set_Function
     (Object : Uniform_Subroutine;
      Name   : String)
   with Inline;
   --  Select the given subroutine function to be used by the
   --  subroutine uniform
   --
   --  This procedure is a shortcut for Set_Function (Index (Name)).

   procedure Set_Function
     (Object : Uniform_Subroutine;
      Index  : Subroutine_Index)
   with Pre => Object.Is_Compatible (Index);
   --  Select the given subroutine function to be used by the
   --  subroutine uniform

   function Index
     (Object : Uniform_Subroutine;
      Name   : String) return Subroutine_Index;
   --  Return the index of the subroutine function identified
   --  by the given name

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

   type Uniform_Block is tagged private;

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

   function Create_Uniform_Sampler
     (Object : Program;
      Name   : String) return Uniform_Sampler;

   function Create_Uniform_Image
     (Object : Program;
      Name   : String) return Uniform_Image;

   function Create_Uniform_Subroutine
     (Object : in out Program;
      Shader : GL.Objects.Shaders.Shader_Type;
      Name   : String) return Uniform_Subroutine;

   function Create_Uniform_Block
     (Object : Program;
      Name   : String) return Uniform_Block;

   function Create_Uniform_Variable
     (Object : Program;
      Name   : String) return Uniform;

   Uniform_Inactive_Error : exception renames GL.Objects.Programs.Uniform_Inactive_Error;

   Uniform_Type_Error : exception;

private

   type Uniform (Kind : LE.Resource_Type) is tagged record
      GL_Uniform : GL.Objects.Programs.Uniforms.Uniform;
   end record;

   type Uniform_Sampler (Kind : LE.Texture_Kind) is tagged record
      GL_Uniform : GL.Objects.Programs.Uniforms.Uniform;
   end record;

   type Uniform_Image (Kind : LE.Texture_Kind) is tagged record
      GL_Uniform : GL.Objects.Programs.Uniforms.Uniform;
   end record;

   package Indices_Holder is new Ada.Containers.Indefinite_Holders
     (Element_Type => GL.Objects.Programs.Subroutine_Index_Array,
      "=" => GL.Objects.Programs."=");

   type Uniform_Subroutine (Program : access Programs.Program) is tagged limited record
      Location : Uniform_Location;
      Indices  : Indices_Holder.Holder;
      Shader   : GL.Objects.Shaders.Shader_Type;
   end record;

   type Uniform_Block is tagged record
      GL_Uniform : GL.Objects.Programs.Uniforms.Uniform;
   end record;

end Orka.Rendering.Programs.Uniforms;

--  SPDX-License-Identifier: Apache-2.0
--
--  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 Ada.Containers.Indefinite_Holders;

with GL.Low_Level.Enums;
with GL.Objects.Programs.Uniforms;
with GL.Objects.Textures;
with GL.Types;

with Orka.Transforms.Singles.Matrices;
with Orka.Transforms.Doubles.Matrices;

package Orka.Rendering.Programs.Uniforms is
   pragma Preelaborate;

   package LE renames GL.Low_Level.Enums;

   use type LE.Texture_Kind;
   use type LE.Resource_Type;

   package TS renames Transforms.Singles.Matrices;
   package TD renames Transforms.Doubles.Matrices;

   type Uniform (Kind : LE.Resource_Type) is tagged private;

   procedure Set_Matrix (Object : Uniform; Value : TS.Matrix4);
   procedure Set_Matrix (Object : Uniform; Value : TD.Matrix4);

   procedure Set_Vector (Object : Uniform; Value : TS.Vector4);
   procedure Set_Vector (Object : Uniform; Value : TD.Vector4);

   procedure Set_Single (Object : Uniform; Value : GL.Types.Single);

   procedure Set_Double (Object : Uniform; Value : GL.Types.Double);

   procedure Set_Int (Object : Uniform; Value : GL.Types.Int);

   procedure Set_UInt (Object : Uniform; Value : GL.Types.UInt);

   procedure Set_Boolean (Object : Uniform; Value : Boolean);

   function GL_Uniform (Object : Uniform) return GL.Objects.Programs.Uniforms.Uniform
     with Inline;

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

   type Uniform_Sampler (Kind : LE.Texture_Kind) is tagged private;

   procedure Set_Texture
     (Object  : Uniform_Sampler;
      Texture : GL.Objects.Textures.Texture_Base'Class;
      Binding : Natural)
   with Pre => Texture.Kind = Object.Kind or else raise Constraint_Error with
                 "Cannot bind " & Texture.Kind'Image & " to " &
                 Object.Kind'Image & " sampler";
   --  TODO Add pre condition to check Texture.Format matches Sampler_Kind
   --  (see https://www.khronos.org/opengl/wiki/Sampler_(GLSL)#Sampler_types)
   --  Set the binding point of the uniform sampler and bind the
   --  given texture to the corresponding texture unit

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

   type Uniform_Image (Kind : LE.Texture_Kind) is tagged private;

   procedure Set_Image
     (Object  : Uniform_Image;
      Texture : GL.Objects.Textures.Texture_Base'Class;
      Binding : Natural)
   with Pre => Texture.Kind = Object.Kind or else raise Constraint_Error with
                 "Cannot bind " & Texture.Kind'Image & " to " &
                 Object.Kind'Image & " image sampler";

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

   type Uniform_Subroutine (<>) is tagged limited private;

   function Is_Compatible
     (Object : Uniform_Subroutine;
      Index  : Subroutine_Index) return Boolean;
   --  Return True if the index is a compatible subroutine function
   --  for the subroutine uniform, False otherwise

   procedure Set_Function
     (Object : Uniform_Subroutine;
      Name   : String)
   with Inline;
   --  Select the given subroutine function to be used by the
   --  subroutine uniform
   --
   --  This procedure is a shortcut for Set_Function (Index (Name)).

   procedure Set_Function
     (Object : Uniform_Subroutine;
      Index  : Subroutine_Index)
   with Pre => Object.Is_Compatible (Index);
   --  Select the given subroutine function to be used by the
   --  subroutine uniform

   function Index
     (Object : Uniform_Subroutine;
      Name   : String) return Subroutine_Index;
   --  Return the index of the subroutine function identified
   --  by the given name

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

   type Uniform_Block is tagged private;

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

   function Create_Uniform_Sampler
     (Object : Program;
      Name   : String) return Uniform_Sampler;

   function Create_Uniform_Image
     (Object : Program;
      Name   : String) return Uniform_Image;

   function Create_Uniform_Subroutine
     (Object : in out Program;
      Shader : GL.Objects.Shaders.Shader_Type;
      Name   : String) return Uniform_Subroutine;

   function Create_Uniform_Block
     (Object : Program;
      Name   : String) return Uniform_Block;

   function Create_Uniform_Variable
     (Object : Program;
      Name   : String) return Uniform;

   Uniform_Inactive_Error : exception renames GL.Objects.Programs.Uniform_Inactive_Error;

   Uniform_Type_Error : exception;

private

   type Uniform (Kind : LE.Resource_Type) is tagged record
      GL_Uniform : GL.Objects.Programs.Uniforms.Uniform;
   end record;

   type Uniform_Sampler (Kind : LE.Texture_Kind) is tagged record
      GL_Uniform : GL.Objects.Programs.Uniforms.Uniform;
   end record;

   type Uniform_Image (Kind : LE.Texture_Kind) is tagged record
      GL_Uniform : GL.Objects.Programs.Uniforms.Uniform;
   end record;

   package Indices_Holder is new Ada.Containers.Indefinite_Holders
     (Element_Type => GL.Objects.Programs.Subroutine_Index_Array,
      "=" => GL.Objects.Programs."=");

   type Uniform_Subroutine (Program : access Programs.Program) is tagged limited record
      Location : Uniform_Location;
      Indices  : Indices_Holder.Holder;
      Shader   : GL.Objects.Shaders.Shader_Type;
   end record;

   type Uniform_Block is tagged record
      GL_Uniform : GL.Objects.Programs.Uniforms.Uniform;
   end record;

end Orka.Rendering.Programs.Uniforms;

orka: Add exception message to some pre conditions in package Uniforms

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


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

with Ada.Exceptions;
with Ada.Calendar;

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

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

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

package body ADO.Tests is

   use Ada.Exceptions;
   use ADO.Statements;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

   end Test_Not_Open;

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

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

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

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

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

      Ref2.Load (DB, Ref.Get_Id);

   end Test_Create_Save;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --  ------------------------------
   procedure Test_Perf_Create_Save (T : in out Test) is
      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      S  : Util.Measures.Stamp;
   begin
      DB.Begin_Transaction;
      for I in 1 .. 1_000 loop
         declare
            Ref  : Regtests.Simple.Model.Allocate_Ref;
         begin
            Ref.Set_Name ("Testing the allocation");
            Ref.Save (DB);
            T.Assert (Ref.Get_Id > 0, "Object must have an id");
         end;
      end loop;
      DB.Commit;
      Util.Measures.Report (S, "Create 1000 rows");
   end Test_Perf_Create_Save;

   procedure Test_Delete_All (T : in out Test) is

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end ADO.Tests;

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

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

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

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

package body ADO.Tests is

   use Ada.Exceptions;
   use ADO.Statements;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

   end Test_Not_Open;

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

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

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

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

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

      Ref2.Load (DB, Ref.Get_Id);

   end Test_Create_Save;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --  ------------------------------
   procedure Test_Perf_Create_Save (T : in out Test) is
      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      S  : Util.Measures.Stamp;
   begin
      DB.Begin_Transaction;
      for I in 1 .. 1_000 loop
         declare
            Ref  : Regtests.Simple.Model.Allocate_Ref;
         begin
            Ref.Set_Name ("Testing the allocation");
            Ref.Save (DB);
            T.Assert (Ref.Get_Id > 0, "Object must have an id");
         end;
      end loop;
      DB.Commit;
      Util.Measures.Report (S, "Create 1000 rows");
   end Test_Perf_Create_Save;

   procedure Test_Delete_All (T : in out Test) is

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end ADO.Tests;

Change NOT_OPEN exception into Session_Error


-- t0048.adb - Thu Feb 20 16:54:37 2014
--
-- (c) Warren W. Gay VE3WWG  ve3wwg@gmail.com
--
-- $Id$
--
-- Protected under the GNU GENERAL PUBLIC LICENSE v2, June 1991

with Ada.Text_IO;

with Posix;
use Posix;

procedure T0048 is
   use Ada.Text_IO;

   Connect_Addr : constant String := "127.0.0.1";

   Inet_C_Addr :  s_sockaddr_in;
   Port_C_No :    constant ushort_t := 19199;

   S, L :      fd_t := -1;       -- Connecting socket
   Child :     pid_t := -1;
   Error :     errno_t;
begin

   Put_Line("Test 0048 - IPv4 socket/connect/etc.");

   Fork(Child,Error);
   pragma Assert(Error = 0);

   if Child /= 0 then
      -- Parent process

      -- Create socket:
      Socket(PF_INET,SOCK_STREAM,0,S,Error);
      pragma Assert(Error = 0);
      pragma Assert(S >= 0);

      -- Create address to connect with:
      Inet_C_Addr.sin_family := AF_INET;
      Inet_C_Addr.sin_port   := Htons(Port_C_No);
      Inet_Aton(Connect_Addr,Inet_C_Addr.sin_addr,Error);
      pragma Assert(Error = 0);

      -- Test Inet_Ntop -- should return same IPv4 String
      declare
         Str_Addr :  String(1..300);
         Last :      Natural := 0;
      begin
         Inet_Ntop(Inet_C_Addr.sin_addr,Str_Addr,Last,Error);
         pragma Assert(Error = 0);
         pragma Assert(Str_Addr(1..Last) = Connect_Addr);
      end;

      -- Test port
      declare
         Test_Port : constant ushort_t := Ntohs(Inet_C_Addr.sin_port);
      begin
         pragma Assert(Test_Port = Port_C_No);
         null;
      end;

      -- Wait for client to setup and listen
      Sleep(2);

      -- Connect to the client process
      Connect(S,To_Sock_Addr(Inet_C_Addr),Error);
      pragma Assert(Error = 0);

      -- Close the socket
      Close(S,Error);
      pragma Assert(Error = 0);

      -- Wait for child process to exit
      declare
         Status : int_t := -1;
      begin
         Wait_Pid(Child,0,Status,Error);
         pragma Assert(WIFEXITED(Status));
         pragma Assert(WEXITSTATUS(Status) = 0);
      end;

      Put_Line("Test 0048 Passed.");
   else
      -- Child process

      -- Create a listening socket:
      Socket(PF_INET,SOCK_STREAM,0,L,Error);
      pragma Assert(Error = 0);
      pragma Assert(L >= 0);

      -- Create the address to bind to:
      Inet_C_Addr.sin_family := AF_INET;
      Inet_C_Addr.sin_port   := Htons(Port_C_No);
      Inet_Aton(Connect_Addr,Inet_C_Addr.sin_addr,Error);
      pragma Assert(Error = 0);

      -- Bind to the address:
      Bind(L,To_Sock_Addr(Inet_C_Addr),Error);
      pragma Assert(Error = 0);

      loop
         Listen(L,10,Error);
         exit when Error = 0;
         pragma Assert(Error = EINTR);
      end loop;

      -- Accept one connect
      declare
         Peer :   s_sockaddr;
      begin
         loop
            Accept_Connect(L,Peer,S,Error);
            exit when Error = 0;
            pragma Assert(Error = EINTR);
         end loop;

         pragma Assert(S >= 0);

         -- Display peer's address
         declare
            Peer_Addr : constant s_sockaddr_in := To_Inet_Addr(Peer);
            Str_Addr :  String(1..300);
            Last :      Natural := 0;
            Port :      constant ushort_t := Ntohs(Peer_Addr.sin_port);
         begin
            Inet_Ntop(Peer_Addr.sin_addr,Str_Addr,Last,Error);
            pragma Assert(Error = 0);

            Put_Line("Received connect from " & Str_Addr(1..Last) & ":" & ushort_t'Image(Port));
         end;
      end;

      -- Close listening socket
      Close(L,Error);
      pragma Assert(Error = 0);

      -- Test getsockopt(2)
      declare
         Sock_Error : int_t := -33;
         Keep_Alive : int_t := -33;
      begin
         Get_Sockopt(S,SOL_SOCKET,SO_ERROR,Sock_Error,Error);
         pragma Assert(Error = 0);
         pragma Assert(Sock_Error = 0);

         Get_Sockopt(S,SOL_SOCKET,SO_KEEPALIVE,Keep_Alive,Error);
         pragma Assert(Error = 0);
         pragma Assert(Keep_Alive = 0 or Keep_Alive = 1);

         if Keep_Alive /= 0 then
            Keep_Alive := 0;        -- Turn it off
            Set_Sockopt(S,SOL_SOCKET,SO_KEEPALIVE,Keep_Alive,Error);
            pragma Assert(Error = 0);

            Keep_Alive := -95;
            Get_Sockopt(S,SOL_SOCKET,SO_KEEPALIVE,Keep_Alive,Error);
            pragma Assert(Error = 0);
            pragma Assert(Keep_Alive = 0);
         else
            Keep_Alive := 1;        -- Turn it on
            Set_Sockopt(S,SOL_SOCKET,SO_KEEPALIVE,Keep_Alive,Error);
            pragma Assert(Error = 0);

            Keep_Alive := -95;
            Get_Sockopt(S,SOL_SOCKET,SO_KEEPALIVE,Keep_Alive,Error);
            pragma Assert(Error = 0);
            pragma Assert(Keep_Alive = 1);
         end if;
      end;

      -- Close accepted socket
      Close(S,Error);
      pragma Assert(Error = 0);

   end if;

end T0048;

-- t0048.adb - Thu Feb 20 16:54:37 2014
--
-- (c) Warren W. Gay VE3WWG  ve3wwg@gmail.com
--
-- $Id$
--
-- Protected under the GNU GENERAL PUBLIC LICENSE v2, June 1991

with Ada.Text_IO;

with Posix;
use Posix;

procedure T0048 is
   use Ada.Text_IO;

   Connect_Addr : constant String := "127.0.0.1";

   Inet_C_Addr :  s_sockaddr_in;
   Port_C_No :    constant ushort_t := 19199;

   S, L :      fd_t := -1;       -- Connecting socket
   Child :     pid_t := -1;
   Error :     errno_t;
begin

   Put_Line("Test 0048 - IPv4 socket/connect/etc.");

   Fork(Child,Error);
   pragma Assert(Error = 0);

   if Child /= 0 then
      -- Parent process

      -- Create socket:
      Socket(PF_INET,SOCK_STREAM,0,S,Error);
      pragma Assert(Error = 0);
      pragma Assert(S >= 0);

      -- Create address to connect with:
      Inet_C_Addr.sin_family := AF_INET;
      Inet_C_Addr.sin_port   := Htons(Port_C_No);
      Inet_Aton(Connect_Addr,Inet_C_Addr.sin_addr,Error);
      pragma Assert(Error = 0);

      -- Test Inet_Ntop -- should return same IPv4 String
      declare
         Str_Addr :  String(1..300);
         Last :      Natural := 0;
      begin
         Inet_Ntop(Inet_C_Addr.sin_addr,Str_Addr,Last,Error);
         pragma Assert(Error = 0);
         pragma Assert(Str_Addr(1..Last) = Connect_Addr);
      end;

      -- Test port
      declare
         Test_Port : constant ushort_t := Ntohs(Inet_C_Addr.sin_port);
      begin
         pragma Assert(Test_Port = Port_C_No);
         null;
      end;

      -- Wait for client to setup and listen
      Sleep(2);

      -- Connect to the client process
      Connect(S,To_Sock_Addr(Inet_C_Addr),Error);
      pragma Assert(Error = 0);

      -- Close the socket
      Close(S,Error);
      pragma Assert(Error = 0);

      -- Wait for child process to exit
      declare
         Status : int_t := -1;
      begin
         Wait_Pid(Child,0,Status,Error);
         pragma Assert(WIFEXITED(Status));
         pragma Assert(WEXITSTATUS(Status) = 0);
      end;

      Put_Line("Test 0048 Passed.");
   else
      -- Child process

      -- Create a listening socket:
      Socket(PF_INET,SOCK_STREAM,0,L,Error);
      pragma Assert(Error = 0);
      pragma Assert(L >= 0);

      -- Create the address to bind to:
      Inet_C_Addr.sin_family := AF_INET;
      Inet_C_Addr.sin_port   := Htons(Port_C_No);
      Inet_Aton(Connect_Addr,Inet_C_Addr.sin_addr,Error);
      pragma Assert(Error = 0);

      -- Bind to the address:
      Bind(L,To_Sock_Addr(Inet_C_Addr),Error);
      pragma Assert(Error = 0);

      loop
         Listen(L,10,Error);
         exit when Error = 0;
         pragma Assert(Error = EINTR);
      end loop;

      -- Accept one connect
      declare
         Peer :   s_sockaddr;
      begin
         loop
            Accept_Connect(L,Peer,S,Error);
            exit when Error = 0;
            pragma Assert(Error = EINTR);
         end loop;

         pragma Assert(S >= 0);

         -- Display peer's address
         declare
            Peer_Addr : constant s_sockaddr_in := To_Inet_Addr(Peer);
            Str_Addr :  String(1..300);
            Last :      Natural := 0;
            Port :      constant ushort_t := Ntohs(Peer_Addr.sin_port);
         begin
            Inet_Ntop(Peer_Addr.sin_addr,Str_Addr,Last,Error);
            pragma Assert(Error = 0);

            Put_Line("Received connect from " & Str_Addr(1..Last) & ":" & ushort_t'Image(Port));
         end;
      end;

      -- Close listening socket
      Close(L,Error);
      pragma Assert(Error = 0);

      -- Test getsockopt(2)
      declare
         Sock_Error : int_t := -33;
         Keep_Alive : int_t := -33;
      begin
         Get_Sockopt(S,SOL_SOCKET,SO_ERROR,Sock_Error,Error);
         pragma Assert(Error = 0);
         pragma Assert(Sock_Error = 0);

         Get_Sockopt(S,SOL_SOCKET,SO_KEEPALIVE,Keep_Alive,Error);
         pragma Assert(Error = 0);
         pragma Assert(Keep_Alive >= 0);

         if Keep_Alive /= 0 then
            Keep_Alive := 0;        -- Turn it off
            Set_Sockopt(S,SOL_SOCKET,SO_KEEPALIVE,Keep_Alive,Error);
            pragma Assert(Error = 0);

            Keep_Alive := -95;
            Get_Sockopt(S,SOL_SOCKET,SO_KEEPALIVE,Keep_Alive,Error);
            pragma Assert(Error = 0);
            pragma Assert(Keep_Alive = 0);
         else
            Keep_Alive := 1;        -- Turn it on
            Set_Sockopt(S,SOL_SOCKET,SO_KEEPALIVE,Keep_Alive,Error);
            pragma Assert(Error = 0);

            Keep_Alive := -95;
            Get_Sockopt(S,SOL_SOCKET,SO_KEEPALIVE,Keep_Alive,Error);
            pragma Assert(Error = 0);
            pragma Assert(Keep_Alive /= 0);
         end if;
      end;

      -- Close accepted socket
      Close(S,Error);
      pragma Assert(Error = 0);

   end if;

end T0048;

Test is now more flexible-- Darwin uses values > 1


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

with Util.Strings.Vectors;
with ADO.Sessions;
with ADO.Configs;
package ADO.Schemas.Databases is

   --  Create the database and initialize it with the schema SQL file.
   procedure Create_Database (Session     : in out Sessions.Master_Session;
                              Config      : in Configs.Configuration'Class;
                              Schema_Path : in String;
                              Messages    : out Util.Strings.Vectors.Vector);

end ADO.Schemas.Databases;

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

with Util.Strings.Vectors;
with ADO.Sessions.Sources;
package ADO.Schemas.Databases is

   --  Create the database and initialize it with the schema SQL file.
   --  The `Admin` parameter describes the database connection with administrator access.
   --  The `Config` parameter describes the target database connection: this is the
   --  database that must be created and configured.  The `Schema_Path` is the path
   --  of the SQL file that can be used to populate the database with the schema.
   --  The `Messages` vector will contain the messages produced during the setup and
   --  configuration of the database.
   --
   --  For the `sqlite` driver, the `Admin` parameter is not used.
   procedure Create_Database (Admin       : in ADO.Sessions.Sources.Data_Source'Class;
                              Config      : in ADO.Sessions.Sources.Data_Source'Class;
                              Schema_Path : in String;
                              Messages    : out Util.Strings.Vectors.Vector);

end ADO.Schemas.Databases;

Update the Create_Database to use a Data_Source as configuration parameters


-----------------------------------------------------------------------
--  EL.Expressions -- Expression Language
--  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.Expressions.Nodes;
with EL.Expressions.Parser;
with Util.Concurrent.Counters;
package body EL.Expressions is

   --  ------------------------------
   --  Check whether the expression is a holds a constant value.
   --  ------------------------------
   function Is_Constant (Expr : Expression'Class) return Boolean is
   begin
      return Expr.Node = null;
   end Is_Constant;

   --  ------------------------------
   --  Get the value of the expression using the given expression context.
   --  ------------------------------
   function Get_Value (Expr    : Expression;
                       Context : ELContext'Class) return Object is
   begin
      if Expr.Node = null then
         return Expr.Value;
      end if;
      return EL.Expressions.Nodes.Get_Value (Expr.Node.all, Context);
   end Get_Value;

   --  ------------------------------
   --  Get the value of the expression using the given expression context.
   --  ------------------------------
   function Get_Value (Expr    : ValueExpression;
                       Context : ELContext'Class) return Object is
   begin
      if Expr.Bean = null then
         if Expr.Node = null then
            return Expr.Value;
         else
            return EL.Expressions.Nodes.Get_Value (Expr.Node.all, Context);
         end if;
      end if;
      return To_Object (Expr.Bean);
   end Get_Value;

   --  ------------------------------
   --  Set the value of the expression to the given object value.
   --  ------------------------------
   procedure Set_Value (Expr    : in out ValueExpression;
                        Context : in ELContext'Class;
                        Value   : in Object) is
   begin
      Expr.Value := Value;
   end Set_Value;

   --  ------------------------------
   --  Returns true if the expression is read-only.
   --  ------------------------------
   function Is_Readonly (Expr : in ValueExpression) return Boolean is
   begin
      if Expr.Bean = null then
         return True;
      end if;
      return not (Expr.Bean.all in EL.Beans.Bean'Class);
   end Is_Readonly;

   --  ------------------------------
   --  Parse an expression and return its representation ready for evaluation.
   --  ------------------------------
   function Create_Expression (Expr    : String;
                               Context : ELContext'Class)
                               return Expression is
      use EL.Expressions.Nodes;
      Result : Expression;
      Node   : EL.Expressions.Nodes.ELNode_Access;
   begin
      EL.Expressions.Parser.Parse (Expr => Expr, Context => Context, Result => Node);
      if Node /= null then
         Result.Node := Node.all'Access;
      end if;
      return Result;
   end Create_Expression;

   --  ------------------------------
   --  Reduce the expression by eliminating known variables and computing
   --  constant expressions.  The result expression is either another
   --  expression or a computed constant value.
   --  ------------------------------
   function Reduce_Expression (Expr    : Expression;
                               Context : ELContext'Class)
                               return Expression is
      use EL.Expressions.Nodes;
      use Ada.Finalization;
   begin
      if Expr.Node = null then
         return Expr;
      end if;
      declare
         Result : constant Reduction := Expr.Node.Reduce (Context);
      begin
         return Expression '(Controlled with
                             Node => Result.Node,
                             Value => Result.Value);
      end;
   end Reduce_Expression;

   function Create_ValueExpression (Bean : access EL.Beans.Readonly_Bean'Class)
                                    return ValueExpression is
      Result : ValueExpression;
   begin
      Result.Bean := Bean;
      return Result;
   end Create_ValueExpression;

   function Create_ValueExpression (Bean : EL.Objects.Object)
                                    return ValueExpression is
      Result : ValueExpression;
   begin
      Result.Value := Bean;
      return Result;
   end Create_ValueExpression;

   --  ------------------------------
   --  Parse an expression and return its representation ready for evaluation.
   --  ------------------------------
   function Create_Expression (Expr    : String;
                               Context : ELContext'Class)
                               return ValueExpression is
      Result : ValueExpression;
      Node   : EL.Expressions.Nodes.ELNode_Access;
   begin
      EL.Expressions.Parser.Parse (Expr => Expr, Context => Context, Result => Node);
      Result.Node := Node.all'Access;
      return Result;
   end Create_Expression;

   overriding
   function Reduce_Expression (Expr    : ValueExpression;
                               Context : ELContext'Class)
                               return ValueExpression is
      pragma Unreferenced (Context);
   begin
      return Expr;
   end Reduce_Expression;

   procedure Adjust (Object : in out Expression) is
   begin
      if Object.Node /= null then
         Util.Concurrent.Counters.Increment (Object.Node.Ref_Counter);
      end if;
   end Adjust;

   procedure Finalize (Object : in out Expression) is
      Node    : EL.Expressions.Nodes.ELNode_Access;
      Is_Zero : Boolean;
   begin
      if Object.Node /= null then
         Node := Object.Node.all'Access;
         Util.Concurrent.Counters.Decrement (Node.Ref_Counter, Is_Zero);
         if Is_Zero then
            EL.Expressions.Nodes.Delete (Node);
            Object.Node := null;
         end if;
      end if;
   end Finalize;

   --  ------------------------------
   --  Evaluate the method expression and return the object and method
   --  binding to execute the method.  The result contains a pointer
   --  to the bean object and a method binding.  The method binding
   --  contains the information to invoke the method
   --  (such as an access to the function or procedure).
   --  Raises the Invalid_Method exception if the method
   --  cannot be resolved.
   --  ------------------------------
   function Get_Method_Info (Expr    : Method_Expression;
                             Context : ELContext'Class)
                             return Method_Info is
      use EL.Expressions.Nodes;
   begin
      if Expr.Node = null then
         raise Invalid_Expression with "Method expression is empty";
      end if;
      declare
         Node : constant ELValue_Access := ELValue'Class (Expr.Node.all)'Access;
      begin
         return Node.Get_Method_Info (Context);
      end;
   end Get_Method_Info;

   --  ------------------------------
   --  Parse an expression and return its representation ready for evaluation.
   --  The context is used to resolve the functions.  Variables will be
   --  resolved during evaluation of the expression.
   --  Raises Invalid_Expression if the expression is invalid.
   --  ------------------------------
   overriding
   function Create_Expression (Expr    : String;
                               Context : EL.Contexts.ELContext'Class)
                               return Method_Expression is
     use type EL.Expressions.Nodes.ELNode_Access;

     Result : Method_Expression;
     Node   : EL.Expressions.Nodes.ELNode_Access;
   begin
      EL.Expressions.Parser.Parse (Expr => Expr, Context => Context, Result => Node);

      --  The root of the method expression must be an ELValue node.
      if Node = null or else not (Node.all in Nodes.ELValue'Class) then
         raise Invalid_Expression with "Expression is not a method expression";
      end if;
      Result.Node := Node.all'Access;
      return Result;
   end Create_Expression;

   --  ------------------------------
   --  Reduce the expression by eliminating known variables and computing
   --  constant expressions.  The result expression is either another
   --  expression or a computed constant value.
   --  ------------------------------
   overriding
   function Reduce_Expression (Expr    : Method_Expression;
                               Context : EL.Contexts.ELContext'Class)
                               return Method_Expression is
      pragma Unreferenced (Context);
   begin
      return Expr;
   end Reduce_Expression;

end EL.Expressions;

-----------------------------------------------------------------------
--  EL.Expressions -- Expression Language
--  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.Expressions.Nodes;
with EL.Expressions.Parser;
with Util.Concurrent.Counters;
package body EL.Expressions is

   --  ------------------------------
   --  Check whether the expression is a holds a constant value.
   --  ------------------------------
   function Is_Constant (Expr : Expression'Class) return Boolean is
   begin
      return Expr.Node = null;
   end Is_Constant;

   --  ------------------------------
   --  Get the value of the expression using the given expression context.
   --  ------------------------------
   function Get_Value (Expr    : Expression;
                       Context : ELContext'Class) return Object is
   begin
      if Expr.Node = null then
         return Expr.Value;
      end if;
      return EL.Expressions.Nodes.Get_Value (Expr.Node.all, Context);
   end Get_Value;

   --  ------------------------------
   --  Get the value of the expression using the given expression context.
   --  ------------------------------
   function Get_Value (Expr    : ValueExpression;
                       Context : ELContext'Class) return Object is
   begin
      if Expr.Bean = null then
         if Expr.Node = null then
            return Expr.Value;
         else
            return EL.Expressions.Nodes.Get_Value (Expr.Node.all, Context);
         end if;
      end if;
      return To_Object (Expr.Bean);
   end Get_Value;

   --  ------------------------------
   --  Set the value of the expression to the given object value.
   --  ------------------------------
   procedure Set_Value (Expr    : in out ValueExpression;
                        Context : in ELContext'Class;
                        Value   : in Object) is
   begin
      Expr.Value := Value;
   end Set_Value;

   --  ------------------------------
   --  Returns true if the expression is read-only.
   --  ------------------------------
   function Is_Readonly (Expr : in ValueExpression) return Boolean is
   begin
      if Expr.Bean = null then
         return True;
      end if;
      return not (Expr.Bean.all in EL.Beans.Bean'Class);
   end Is_Readonly;

   --  ------------------------------
   --  Parse an expression and return its representation ready for evaluation.
   --  ------------------------------
   function Create_Expression (Expr    : String;
                               Context : ELContext'Class)
                               return Expression is
      use EL.Expressions.Nodes;
      Result : Expression;
      Node   : EL.Expressions.Nodes.ELNode_Access;
   begin
      EL.Expressions.Parser.Parse (Expr => Expr, Context => Context, Result => Node);
      if Node /= null then
         Result.Node := Node.all'Access;
      end if;
      return Result;
   end Create_Expression;

   --  ------------------------------
   --  Reduce the expression by eliminating known variables and computing
   --  constant expressions.  The result expression is either another
   --  expression or a computed constant value.
   --  ------------------------------
   function Reduce_Expression (Expr    : Expression;
                               Context : ELContext'Class)
                               return Expression is
      use EL.Expressions.Nodes;
      use Ada.Finalization;
   begin
      if Expr.Node = null then
         return Expr;
      end if;
      declare
         Result : constant Reduction := Expr.Node.Reduce (Context);
      begin
         return Expression '(Controlled with
                             Node => Result.Node,
                             Value => Result.Value);
      end;
   end Reduce_Expression;

   function Create_ValueExpression (Bean : access EL.Beans.Readonly_Bean'Class)
                                    return ValueExpression is
      Result : ValueExpression;
   begin
      Result.Bean := Bean;
      return Result;
   end Create_ValueExpression;

   function Create_ValueExpression (Bean : EL.Objects.Object)
                                    return ValueExpression is
      Result : ValueExpression;
   begin
      Result.Value := Bean;
      return Result;
   end Create_ValueExpression;

   --  ------------------------------
   --  Parse an expression and return its representation ready for evaluation.
   --  ------------------------------
   function Create_Expression (Expr    : String;
                               Context : ELContext'Class)
                               return ValueExpression is
      Result : ValueExpression;
      Node   : EL.Expressions.Nodes.ELNode_Access;
   begin
      EL.Expressions.Parser.Parse (Expr => Expr, Context => Context, Result => Node);
      Result.Node := Node.all'Access;
      return Result;
   end Create_Expression;

   overriding
   function Reduce_Expression (Expr    : ValueExpression;
                               Context : ELContext'Class)
                               return ValueExpression is
      pragma Unreferenced (Context);
   begin
      return Expr;
   end Reduce_Expression;

   procedure Adjust (Object : in out Expression) is
   begin
      if Object.Node /= null then
         Util.Concurrent.Counters.Increment (Object.Node.Ref_Counter);
      end if;
   end Adjust;

   procedure Finalize (Object : in out Expression) is
      Node    : EL.Expressions.Nodes.ELNode_Access;
      Is_Zero : Boolean;
   begin
      if Object.Node /= null then
         Node := Object.Node.all'Access;
         Util.Concurrent.Counters.Decrement (Node.Ref_Counter, Is_Zero);
         if Is_Zero then
            EL.Expressions.Nodes.Delete (Node);
            Object.Node := null;
         end if;
      end if;
   end Finalize;

   --  ------------------------------
   --  Evaluate the method expression and return the object and method
   --  binding to execute the method.  The result contains a pointer
   --  to the bean object and a method binding.  The method binding
   --  contains the information to invoke the method
   --  (such as an access to the function or procedure).
   --  Raises the Invalid_Method exception if the method
   --  cannot be resolved.
   --  ------------------------------
   function Get_Method_Info (Expr    : Method_Expression;
                             Context : ELContext'Class)
                             return Method_Info is
      use EL.Expressions.Nodes;
   begin
      if Expr.Node = null then
         raise Invalid_Expression with "Method expression is empty";
      end if;
      declare
         Node : constant ELValue_Access := ELValue'Class (Expr.Node.all)'Access;
      begin
         return Node.Get_Method_Info (Context);
      end;
   end Get_Method_Info;

   --  ------------------------------
   --  Parse an expression and return its representation ready for evaluation.
   --  The context is used to resolve the functions.  Variables will be
   --  resolved during evaluation of the expression.
   --  Raises Invalid_Expression if the expression is invalid.
   --  ------------------------------
   overriding
   function Create_Expression (Expr    : String;
                               Context : EL.Contexts.ELContext'Class)
                               return Method_Expression is
     use type EL.Expressions.Nodes.ELNode_Access;

     Result : Method_Expression;
     Node   : EL.Expressions.Nodes.ELNode_Access;
   begin
      EL.Expressions.Parser.Parse (Expr => Expr, Context => Context, Result => Node);

      --  The root of the method expression must be an ELValue node.
      if Node = null or else not (Node.all in Nodes.ELValue'Class) then
         EL.Expressions.Nodes.Delete (Node);
         raise Invalid_Expression with "Expression is not a method expression";
      end if;
      Result.Node := Node.all'Access;
      return Result;
   end Create_Expression;

   --  ------------------------------
   --  Reduce the expression by eliminating known variables and computing
   --  constant expressions.  The result expression is either another
   --  expression or a computed constant value.
   --  ------------------------------
   overriding
   function Reduce_Expression (Expr    : Method_Expression;
                               Context : EL.Contexts.ELContext'Class)
                               return Method_Expression is
      pragma Unreferenced (Context);
   begin
      return Expr;
   end Reduce_Expression;

end EL.Expressions;

Fix memory leak if the method expression is a valid EL expression but not a method expression