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

with Ada.Exceptions;
with Ada.Calendar;

with ADO.Statements;
with ADO.Objects;
with ADO.Sessions;
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.Test_Caller;

package body ADO.Tests is

   use Util.Log;
   use Ada.Exceptions;
   use ADO.Statements;
   use type Regtests.Simple.Model.User_Ref;
   use type Regtests.Simple.Model.Allocate_Ref;

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

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

   procedure Fail (T : in Test; Message : in String);
   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence);

   procedure Fail (T : in Test; Message : in String) is
   begin
      T.Assert (False, Message);
   end Fail;

   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;
         Fail (T, "Master_Connection.Rollback should raise an exception");

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

      begin
         DB.Commit;
         Fail (T, "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'Access);
      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 ADO.Objects;

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

      Ref  : Regtests.Simple.Model.Allocate_Ref;
      Ref2 : 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");

      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
      use ADO.Objects;

      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'Access);
      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 ADO.Objects;
      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 : Unbounded_String;
   begin
      for I in 1 .. 127 loop
         Append (Name, Character'Val (I));
      end loop;
      Append (Name, ' ');
      Append (Name, ' ');
      Append (Name, ' ');
      Append (Name, ' ');
      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), String '(Usr2.Get_Name),
                                "Invalid name inserted for user");
   end Test_String;

   --  ------------------------------
   --  Test blob insert.
   --  ------------------------------
   procedure Test_Blob (T : in out Test) is
      use ADO.Objects;
      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 : constant 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;
   end Test_Blob;

   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);
   end Add_Tests;

end ADO.Tests;

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

with Ada.Exceptions;
with Ada.Calendar;

with ADO.Statements;
with ADO.Objects;
with ADO.Sessions;
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.Test_Caller;

package body ADO.Tests is

   use Util.Log;
   use Ada.Exceptions;
   use ADO.Statements;
   use type Regtests.Simple.Model.User_Ref;
   use type Regtests.Simple.Model.Allocate_Ref;

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

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

   procedure Fail (T : in Test; Message : in String);
   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence);

   procedure Fail (T : in Test; Message : in String) is
   begin
      T.Assert (False, Message);
   end Fail;

   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;
         Fail (T, "Master_Connection.Rollback should raise an exception");

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

      begin
         DB.Commit;
         Fail (T, "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'Access);
      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 ADO.Objects;

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

      Ref  : Regtests.Simple.Model.Allocate_Ref;
      Ref2 : 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");

      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
      use ADO.Objects;

      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'Access);
      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 ADO.Objects;
      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 : Unbounded_String;
   begin
      for I in 1 .. 127 loop
         Append (Name, Character'Val (I));
      end loop;
      Append (Name, ' ');
      Append (Name, ' ');
      Append (Name, ' ');
      Append (Name, ' ');
      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), String '(Usr2.Get_Name),
                                "Invalid name inserted for user");
   end Test_String;

   --  ------------------------------
   --  Test blob insert.
   --  ------------------------------
   procedure Test_Blob (T : in out Test) is
      use ADO.Objects;
      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");
   end Test_Blob;

   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);
   end Add_Tests;

end ADO.Tests;

Update unit tests to check the blob

Update unit tests to check the blob


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

package body ASF.Components.Utils.Scripts is

   --  ------------------------------
   --  Write the content that was collected by rendering the inner children.
   --  Write the content in the Javascript queue.
   --  ------------------------------
   overriding
   procedure Write_Content (UI      : in UIScript;
                            Writer  : in out Contexts.Writer.Response_Writer'Class;
                            Content : in String;
                            Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (UI, Context);
   begin
      Writer.Queue_Script (Content);
   end Write_Content;

end ASF.Components.Utils.Scripts;

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

package body ASF.Components.Utils.Scripts is

   --  ------------------------------
   --  Write the content that was collected by rendering the inner children.
   --  Write the content in the Javascript queue.
   --  ------------------------------
   overriding
   procedure Write_Content (UI      : in UIScript;
                            Writer  : in out Contexts.Writer.Response_Writer'Class;
                            Content : in String;
                            Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (UI, Context);
   begin
      Writer.Queue_Script (Content);
   end Write_Content;

   --  ------------------------------
   --  If the component provides a src attribute, render the <script src='xxx'></script>
   --  tag with an optional async attribute.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIScript;
                           Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;
      declare
         Src    : constant String := UI.Get_Attribute (Context => Context, Name => "src");
         Writer : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
      begin
         if Src'Length > 0 then
            Writer.Queue_Include_Script (URL   => Src,
                                         Async => UI.Get_Attribute (Context => Context,
                                                                    Name    => "async"));
         end if;
      end;
   end Encode_Begin;

end ASF.Components.Utils.Scripts;

Implement the Encode_Begin procedure to test if the <util:script> component defines a 'src' attribute and generate a <script> command to load the specified javascript source


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

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

--  The Util.Systems.Os package defines various types and operations which are specific
--  to the OS (Unix).
package Util.Systems.Os is

   --  The directory separator.
   Directory_Separator : constant Character := '/';

   --  The path separator.
   Path_Separator      : constant Character := ':';

   --  The line ending separator.
   Line_Separator      : constant String := "" & ASCII.LF;

   use Util.Systems.Constants;

   subtype Ptr is Interfaces.C.Strings.chars_ptr;
   subtype Ptr_Array is Interfaces.C.Strings.chars_ptr_array;
   type Ptr_Ptr_Array is access all Ptr_Array;

   type Process_Identifier is new Integer;

   subtype File_Type is Util.Systems.Types.File_Type;

   --  Standard file streams Posix, X/Open standard values.
   STDIN_FILENO  : constant File_Type := 0;
   STDOUT_FILENO : constant File_Type := 1;
   STDERR_FILENO : constant File_Type := 2;

   --  File is not opened
   use type Util.Systems.Types.File_Type;  --  This use clause is required by GNAT 2018 for the -1!
   NO_FILE       : constant File_Type := -1;

   --  The following values should be externalized.  They are valid for GNU/Linux.
   F_SETFL    : constant Interfaces.C.int := Util.Systems.Constants.F_SETFL;
   FD_CLOEXEC : constant Interfaces.C.int := Util.Systems.Constants.FD_CLOEXEC;

   --  These values are specific to Linux.
   O_RDONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_RDONLY;
   O_WRONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_WRONLY;
   O_RDWR     : constant Interfaces.C.int := Util.Systems.Constants.O_RDWR;
   O_CREAT    : constant Interfaces.C.int := Util.Systems.Constants.O_CREAT;
   O_EXCL     : constant Interfaces.C.int := Util.Systems.Constants.O_EXCL;
   O_TRUNC    : constant Interfaces.C.int := Util.Systems.Constants.O_TRUNC;
   O_APPEND   : constant Interfaces.C.int := Util.Systems.Constants.O_APPEND;

   type Size_T is mod 2 ** Standard'Address_Size;

   type Ssize_T is range -(2 ** (Standard'Address_Size - 1))
     .. +(2 ** (Standard'Address_Size - 1)) - 1;

   function Close (Fd : in File_Type) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "close";

   function Read (Fd   : in File_Type;
                  Buf  : in System.Address;
                  Size : in Size_T) return Ssize_T
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "read";

   function Write (Fd   : in File_Type;
                   Buf  : in System.Address;
                   Size : in Size_T) return Ssize_T
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "write";

   --  System exit without any process cleaning.
   --  (destructors, finalizers, atexit are not called)
   procedure Sys_Exit (Code : in Integer)
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "exit";

   --  Fork a new process
   function Sys_Fork return Process_Identifier
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "fork";

   --  Fork a new process (vfork implementation)
   function Sys_VFork return Process_Identifier
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "fork";

   --  Execute a process with the given arguments.
   function Sys_Execvp (File : in Ptr;
                        Args : in Ptr_Array) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "execvp";

   --  Execute a process with the given arguments.
   function Sys_Execve (File : in Ptr;
                        Args : in Ptr_Array;
                        Envp : in Ptr_Array) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "execve";

   --  Wait for the process Pid to finish and return
   function Sys_Waitpid (Pid     : in Integer;
                         Status  : in System.Address;
                         Options : in Integer) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "waitpid";

   --  Get the current process identification.
   function Sys_Getpid return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "getpid";

   --  Create a bi-directional pipe
   function Sys_Pipe (Fds : in System.Address) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "pipe";

   --  Make fd2 the copy of fd1
   function Sys_Dup2 (Fd1, Fd2 : in File_Type) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "dup2";

   --  Close a file
   function Sys_Close (Fd : in File_Type) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "close";

   --  Open a file
   function Sys_Open (Path  : in Ptr;
                      Flags : in Interfaces.C.int;
                      Mode  : in Util.Systems.Types.mode_t) return File_Type
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "open";

   --  Change the file settings
   function Sys_Fcntl (Fd    : in File_Type;
                       Cmd   : in Interfaces.C.int;
                       Flags : in Interfaces.C.int) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "fcntl";

   function Sys_Kill (Pid : in Integer;
                      Signal : in Integer) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "kill";

   function Sys_Stat (Path : in Ptr;
                      Stat : access Util.Systems.Types.Stat_Type) return Integer
     with Import => True, Convention => C, Link_Name => Util.Systems.Types.STAT_NAME;

   function Sys_Lstat (Path : in String;
                       Stat : access Util.Systems.Types.Stat_Type) return Integer
     with Import => True, Convention => C, Link_Name => Util.Systems.Types.LSTAT_NAME;

   function Sys_Fstat (Fs : in File_Type;
                       Stat : access Util.Systems.Types.Stat_Type) return Integer
     with Import => True, Convention => C, Link_Name => Util.Systems.Types.FSTAT_NAME;

   function Sys_Lseek (Fs : in File_Type;
                       Offset : in Util.Systems.Types.off_t;
                       Mode   : in Util.Systems.Types.Seek_Mode)
                       return Util.Systems.Types.off_t
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "lseek";

   function Sys_Ftruncate (Fs : in File_Type;
                           Length : in Util.Systems.Types.off_t) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "ftruncate";

   function Sys_Truncate (Path  : in Ptr;
                          Length : in Util.Systems.Types.off_t) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "truncate";

   function Sys_Fchmod (Fd   : in File_Type;
                        Mode : in Util.Systems.Types.mode_t) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "fchmod";

   --  Change permission of a file.
   function Sys_Chmod (Path  : in Ptr;
                       Mode  : in Util.Systems.Types.mode_t) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "chmod";

   --  Change working directory.
   function Sys_Chdir (Path : in Ptr) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "chdir";

   --  Rename a file (the Ada.Directories.Rename does not allow to use
   --  the Unix atomic file rename!)
   function Sys_Rename (Oldpath  : in String;
                        Newpath  : in String) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "rename";

   function Sys_Unlink (Path  : in String) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "unlink";

   --  Libc errno.  The __get_errno function is provided by the GNAT runtime.
   function Errno return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "__get_errno";

   function Strerror (Errno : in Integer) return Interfaces.C.Strings.chars_ptr
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "strerror";

   type DIR is new System.Address;

   Null_Dir : constant DIR := DIR (System.Null_Address);

   --  Equivalent to Posix opendir (3) but handles some portability issues.
   --  We could use opendir, readdir_r and closedir but the __gnat_* alternative
   --  solves
   function Opendir (Directory : in String) return DIR
      with Import, External_Name => "__gnat_opendir", Convention => C;

   function Readdir (Directory : in DIR;
                     Buffer    : in System.Address;
                     Last      : not null access Integer) return System.Address
      with Import, External_Name => "__gnat_readdir", Convention => C;

   function Closedir (Directory : in DIR) return Integer
      with Import, External_Name => "__gnat_closedir", Convention => C;

end Util.Systems.Os;

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

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

--  The Util.Systems.Os package defines various types and operations which are specific
--  to the OS (Unix).
package Util.Systems.Os is

   --  The directory separator.
   Directory_Separator : constant Character := '/';

   --  The path separator.
   Path_Separator      : constant Character := ':';

   --  The line ending separator.
   Line_Separator      : constant String := "" & ASCII.LF;

   use Util.Systems.Constants;

   subtype Ptr is Interfaces.C.Strings.chars_ptr;
   subtype Ptr_Array is Interfaces.C.Strings.chars_ptr_array;
   type Ptr_Ptr_Array is access all Ptr_Array;

   type Process_Identifier is new Integer;

   subtype File_Type is Util.Systems.Types.File_Type;

   --  Standard file streams Posix, X/Open standard values.
   STDIN_FILENO  : constant File_Type := 0;
   STDOUT_FILENO : constant File_Type := 1;
   STDERR_FILENO : constant File_Type := 2;

   --  File is not opened
   use type Util.Systems.Types.File_Type;  --  This use clause is required by GNAT 2018 for the -1!
   NO_FILE       : constant File_Type := -1;

   --  The following values should be externalized.  They are valid for GNU/Linux.
   F_SETFL    : constant Interfaces.C.int := Util.Systems.Constants.F_SETFL;
   FD_CLOEXEC : constant Interfaces.C.int := Util.Systems.Constants.FD_CLOEXEC;

   --  These values are specific to Linux.
   O_RDONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_RDONLY;
   O_WRONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_WRONLY;
   O_RDWR     : constant Interfaces.C.int := Util.Systems.Constants.O_RDWR;
   O_CREAT    : constant Interfaces.C.int := Util.Systems.Constants.O_CREAT;
   O_EXCL     : constant Interfaces.C.int := Util.Systems.Constants.O_EXCL;
   O_TRUNC    : constant Interfaces.C.int := Util.Systems.Constants.O_TRUNC;
   O_APPEND   : constant Interfaces.C.int := Util.Systems.Constants.O_APPEND;

   type Size_T is mod 2 ** Standard'Address_Size;

   type Ssize_T is range -(2 ** (Standard'Address_Size - 1))
     .. +(2 ** (Standard'Address_Size - 1)) - 1;

   function Close (Fd : in File_Type) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "close";

   function Read (Fd   : in File_Type;
                  Buf  : in System.Address;
                  Size : in Size_T) return Ssize_T
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "read";

   function Write (Fd   : in File_Type;
                   Buf  : in System.Address;
                   Size : in Size_T) return Ssize_T
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "write";

   --  System exit without any process cleaning.
   --  (destructors, finalizers, atexit are not called)
   procedure Sys_Exit (Code : in Integer)
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "exit";

   --  Fork a new process
   function Sys_Fork return Process_Identifier
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "fork";

   --  Fork a new process (vfork implementation)
   function Sys_VFork return Process_Identifier
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "fork";

   --  Execute a process with the given arguments.
   function Sys_Execvp (File : in Ptr;
                        Args : in Ptr_Array) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "execvp";

   --  Execute a process with the given arguments.
   function Sys_Execve (File : in Ptr;
                        Args : in Ptr_Array;
                        Envp : in Ptr_Array) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "execve";

   --  Wait for the process Pid to finish and return
   function Sys_Waitpid (Pid     : in Integer;
                         Status  : in System.Address;
                         Options : in Integer) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "waitpid";

   --  Get the current process identification.
   function Sys_Getpid return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "getpid";

   --  Create a bi-directional pipe
   function Sys_Pipe (Fds : in System.Address) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "pipe";

   --  Make fd2 the copy of fd1
   function Sys_Dup2 (Fd1, Fd2 : in File_Type) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "dup2";

   --  Close a file
   function Sys_Close (Fd : in File_Type) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "close";

   --  Open a file
   function Sys_Open (Path  : in Ptr;
                      Flags : in Interfaces.C.int;
                      Mode  : in Util.Systems.Types.mode_t) return File_Type
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "open";

   --  Change the file settings
   function Sys_Fcntl (Fd    : in File_Type;
                       Cmd   : in Interfaces.C.int;
                       Flags : in Interfaces.C.int) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "fcntl";

   function Sys_Kill (Pid : in Integer;
                      Signal : in Integer) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "kill";

   function Sys_Stat (Path : in Ptr;
                      Stat : access Util.Systems.Types.Stat_Type) return Integer
     with Import => True, Convention => C, Link_Name => Util.Systems.Types.STAT_NAME;

   function Sys_Lstat (Path : in String;
                       Stat : access Util.Systems.Types.Stat_Type) return Integer
     with Import => True, Convention => C, Link_Name => Util.Systems.Types.LSTAT_NAME;

   function Sys_Fstat (Fs : in File_Type;
                       Stat : access Util.Systems.Types.Stat_Type) return Integer
     with Import => True, Convention => C, Link_Name => Util.Systems.Types.FSTAT_NAME;

   function Sys_Lseek (Fs : in File_Type;
                       Offset : in Util.Systems.Types.off_t;
                       Mode   : in Util.Systems.Types.Seek_Mode)
                       return Util.Systems.Types.off_t
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "lseek";

   function Sys_Ftruncate (Fs : in File_Type;
                           Length : in Util.Systems.Types.off_t) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "ftruncate";

   function Sys_Truncate (Path  : in Ptr;
                          Length : in Util.Systems.Types.off_t) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "truncate";

   function Sys_Fchmod (Fd   : in File_Type;
                        Mode : in Util.Systems.Types.mode_t) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "fchmod";

   --  Change permission of a file.
   function Sys_Chmod (Path  : in Ptr;
                       Mode  : in Util.Systems.Types.mode_t) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "chmod";

   --  Change working directory.
   function Sys_Chdir (Path : in Ptr) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "chdir";

   --  Rename a file (the Ada.Directories.Rename does not allow to use
   --  the Unix atomic file rename!)
   function Sys_Rename (Oldpath  : in String;
                        Newpath  : in String) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "rename";

   function Sys_Unlink (Path  : in String) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "unlink";

   function Sys_Realpath (S : in Ptr;
                          R : in Ptr) return Ptr
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "realpath";

   --  Libc errno.  The __get_errno function is provided by the GNAT runtime.
   function Errno return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "__get_errno";

   function Strerror (Errno : in Integer) return Interfaces.C.Strings.chars_ptr
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "strerror";

   type DIR is new System.Address;

   Null_Dir : constant DIR := DIR (System.Null_Address);

   --  Equivalent to Posix opendir (3) but handles some portability issues.
   --  We could use opendir, readdir_r and closedir but the __gnat_* alternative
   --  solves
   function Opendir (Directory : in String) return DIR
      with Import, External_Name => "__gnat_opendir", Convention => C;

   function Readdir (Directory : in DIR;
                     Buffer    : in System.Address;
                     Last      : not null access Integer) return System.Address
      with Import, External_Name => "__gnat_readdir", Convention => C;

   function Closedir (Directory : in DIR) return Integer
      with Import, External_Name => "__gnat_closedir", Convention => C;

end Util.Systems.Os;

Declare the Sys_Realpath function (taken from Porion)


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

with Ada.Exceptions;
with Ada.Calendar;

with ADO.Statements;
with ADO.Objects;
with ADO.Databases;
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 Util.Log;
   use Ada.Exceptions;
   use ADO.Statements;
   use type Regtests.Simple.Model.User_Ref;
   use type Regtests.Simple.Model.Allocate_Ref;

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

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

   procedure Fail (T : in Test; Message : in String);
   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence);

   procedure Fail (T : in Test; Message : in String) is
   begin
      T.Assert (False, Message);
   end Fail;

   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;
         Fail (T, "Master_Connection.Rollback should raise an exception");

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

      begin
         DB.Commit;
         Fail (T, "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 ADO.Objects;
      use type ADO.Databases.Connection_Status;

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Conn : constant ADO.Databases.Connection'Class := DB.Get_Connection;
      Ref  : Regtests.Simple.Model.Allocate_Ref;
      Ref2 : Regtests.Simple.Model.Allocate_Ref;
   begin
      T.Assert (Conn.Get_Status = ADO.Databases.OPEN,
                "The database connection is open");
      T.Assert (DB.Get_Status = ADO.Databases.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
      use ADO.Objects;

      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 ADO.Objects;
      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 : Unbounded_String;
   begin
      for I in 1 .. 127 loop
         Append (Name, Character'Val (I));
      end loop;
      Append (Name, ' ');
      Append (Name, ' ');
      Append (Name, ' ');
      Append (Name, ' ');
      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), String '(Usr2.Get_Name),
                                "Invalid name inserted for user");
   end Test_String;

   --  ------------------------------
   --  Test blob insert.
   --  ------------------------------
   procedure Test_Blob (T : in out Test) is
      use ADO.Objects;
      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");
   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 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.Databases;
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;
   use type Regtests.Simple.Model.User_Ref;
   use type Regtests.Simple.Model.Allocate_Ref;

   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 ADO.Objects;
      use type ADO.Databases.Connection_Status;

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Conn : constant ADO.Databases.Connection'Class := DB.Get_Connection;
      Ref  : Regtests.Simple.Model.Allocate_Ref;
      Ref2 : Regtests.Simple.Model.Allocate_Ref;
   begin
      T.Assert (Conn.Get_Status = ADO.Databases.OPEN,
                "The database connection is open");
      T.Assert (DB.Get_Status = ADO.Databases.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
      use ADO.Objects;

      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 ADO.Objects;
      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 : Unbounded_String;
   begin
      for I in 1 .. 127 loop
         Append (Name, Character'Val (I));
      end loop;
      Append (Name, ' ');
      Append (Name, ' ');
      Append (Name, ' ');
      Append (Name, ' ');
      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), String '(Usr2.Get_Name),
                                "Invalid name inserted for user");
   end Test_String;

   --  ------------------------------
   --  Test blob insert.
   --  ------------------------------
   procedure Test_Blob (T : in out Test) is
      use ADO.Objects;
      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;

Update the blog image test to verify more Create_Blob operations


-----------------------------------------------------------------------
--  util-processes -- Process creation and control
--  Copyright (C) 2011, 2016, 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.Unchecked_Deallocation;

with Util.Log.Loggers;
with Util.Strings;
with Util.Processes.Os;
package body Util.Processes is

   use Util.Log;
   use Ada.Strings.Unbounded;

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

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Util.Processes.System_Process'Class,
                                     Name   => Util.Processes.System_Process_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => File_Type_Array,
                                     Name   => File_Type_Array_Access);

   --  ------------------------------
   --  Before launching the process, redirect the input stream of the process
   --  to the specified file.
   --  ------------------------------
   procedure Set_Input_Stream (Proc : in out Process;
                               File : in String) is
   begin
      if Proc.Is_Running then
         Log.Error ("Cannot set input stream to {0} while process is running", File);
         raise Invalid_State with "Process is running";
      end if;
      Proc.In_File := To_Unbounded_String (File);
   end Set_Input_Stream;

   --  ------------------------------
   --  Set the output stream of the process.
   --  ------------------------------
   procedure Set_Output_Stream (Proc   : in out Process;
                                File   : in String;
                                Append : in Boolean := False) is
   begin
      if Proc.Is_Running then
         Log.Error ("Cannot set output stream to {0} while process is running", File);
         raise Invalid_State with "Process is running";
      end if;
      Proc.Out_File   := To_Unbounded_String (File);
      Proc.Out_Append := Append;
   end Set_Output_Stream;

   --  ------------------------------
   --  Set the error stream of the process.
   --  ------------------------------
   procedure Set_Error_Stream (Proc   : in out Process;
                               File   : in String;
                               Append : in Boolean := False) is
   begin
      if Proc.Is_Running then
         Log.Error ("Cannot set error stream to {0} while process is running", File);
         raise Invalid_State with "Process is running";
      end if;
      Proc.Err_File   := To_Unbounded_String (File);
      Proc.Err_Append := Append;
   end Set_Error_Stream;

   --  ------------------------------
   --  Set the working directory that the process will use once it is created.
   --  The directory must exist or the Invalid_Directory exception will be raised.
   --  ------------------------------
   procedure Set_Working_Directory (Proc : in out Process;
                                    Path : in String) is
   begin
      if Proc.Is_Running then
         Log.Error ("Cannot set working directory to {0} while process is running", Path);
         raise Invalid_State with "Process is running";
      end if;
      Proc.Dir := To_Unbounded_String (Path);
   end Set_Working_Directory;

   --  ------------------------------
   --  Set the shell executable path to use to launch a command.  The default on Unix is
   --  the /bin/sh command.  Argument splitting is done by the /bin/sh -c command.
   --  When setting an empty shell command, the argument splitting is done by the
   --  <tt>Spawn</tt> procedure.
   --  ------------------------------
   procedure Set_Shell (Proc  : in out Process;
                        Shell : in String) is
   begin
      if Proc.Is_Running then
         Log.Error ("Cannot set shell to {0} while process is running", Shell);
         raise Invalid_State with "Process is running";
      end if;
      Proc.Shell := To_Unbounded_String (Shell);
   end Set_Shell;

   --  ------------------------------
   --  Closes the given file descriptor in the child process before executing the command.
   --  ------------------------------
   procedure Add_Close (Proc  : in out Process;
                        Fd    : in File_Type) is
      List : File_Type_Array_Access;
   begin
      if Proc.To_Close /= null then
         List := new File_Type_Array (1 .. Proc.To_Close'Last + 1);
         List (1 .. Proc.To_Close'Last) := Proc.To_Close.all;
         List (List'Last) := Fd;
         Free (Proc.To_Close);
      else
         List := new File_Type_Array (1 .. 1);
         List (1) := Fd;
      end if;
      Proc.To_Close := List;
   end Add_Close;

   --  ------------------------------
   --  Append the argument to the current process argument list.
   --  Raises Invalid_State if the process is running.
   --  ------------------------------
   procedure Append_Argument (Proc : in out Process;
                              Arg  : in String) is
   begin
      if Proc.Is_Running then
         Log.Error ("Cannot add argument '{0}' while process is running", Arg);
         raise Invalid_State with "Process is running";
      end if;
      Proc.Sys.Append_Argument (Arg);
   end Append_Argument;

   --  ------------------------------
   --  Spawn a new process with the given command and its arguments.  The standard input, output
   --  and error streams are either redirected to a file or to a stream object.
   --  ------------------------------
   procedure Spawn (Proc      : in out Process;
                    Command   : in String;
                    Arguments : in Argument_List) is
   begin
      if Is_Running (Proc) then
         raise Invalid_State with "A process is running";
      end if;

      Log.Info ("Starting process {0}", Command);

      if Proc.Sys /= null then
         Proc.Sys.Finalize;
         Free (Proc.Sys);
      end if;
      Proc.Sys := new Util.Processes.Os.System_Process;

      --  Build the argc/argv table, terminate by NULL
      for I in Arguments'Range loop
         Proc.Sys.Append_Argument (Arguments (I).all);
      end loop;

      --  Prepare to redirect the input/output/error streams.
      Proc.Sys.Set_Streams (Input         => To_String (Proc.In_File),
                            Output        => To_String (Proc.Out_File),
                            Error         => To_String (Proc.Err_File),
                            Append_Output => Proc.Out_Append,
                            Append_Error  => Proc.Err_Append,
                            To_Close      => Proc.To_Close);

      --  System specific spawn
      Proc.Exit_Value := -1;
      Proc.Sys.Spawn (Proc);
   end Spawn;

   --  ------------------------------
   --  Spawn a new process with the given command and its arguments.  The standard input, output
   --  and error streams are either redirected to a file or to a stream object.
   --  ------------------------------
   procedure Spawn (Proc      : in out Process;
                    Command   : in String;
                    Mode      : in Pipe_Mode := NONE) is
      Pos  : Natural := Command'First;
      N    : Natural;
   begin
      if Is_Running (Proc) then
         raise Invalid_State with "A process is running";
      end if;

      Log.Info ("Starting process {0}", Command);

      if Proc.Sys /= null then
         Proc.Sys.Finalize;
         Free (Proc.Sys);
      end if;
      Proc.Sys := new Util.Processes.Os.System_Process;

      if Length (Proc.Shell) > 0 then
         Proc.Sys.Append_Argument (To_String (Proc.Shell));
         Proc.Sys.Append_Argument ("-c");
         Proc.Sys.Append_Argument (Command);
      else
         --  Build the argc/argv table
         while Pos <= Command'Last loop
            N := Util.Strings.Index (Command, ' ', Pos);
            if N = 0 then
               N := Command'Last + 1;
            end if;
            Proc.Sys.Append_Argument (Command (Pos .. N - 1));
            Pos := N + 1;
         end loop;
      end if;

      --  Prepare to redirect the input/output/error streams.
      --  The pipe mode takes precedence and will override these redirections.
      Proc.Sys.Set_Streams (Input         => To_String (Proc.In_File),
                            Output        => To_String (Proc.Out_File),
                            Error         => To_String (Proc.Err_File),
                            Append_Output => Proc.Out_Append,
                            Append_Error  => Proc.Err_Append,
                            To_Close      => Proc.To_Close);

      --  System specific spawn
      Proc.Exit_Value := -1;
      Proc.Sys.Spawn (Proc, Mode);
   end Spawn;

   --  ------------------------------
   --  Wait for the process to terminate.
   --  ------------------------------
   procedure Wait (Proc : in out Process) is
   begin
      if not Is_Running (Proc) then
         return;
      end if;

      Log.Info ("Waiting for process {0}", Process_Identifier'Image (Proc.Pid));
      Proc.Sys.Wait (Proc, -1.0);
   end Wait;

   --  ------------------------------
   --  Terminate the process by sending a signal on Unix and exiting the process on Windows.
   --  This operation is not portable and has a different behavior between Unix and Windows.
   --  Its intent is to stop the process.
   --  ------------------------------
   procedure Stop (Proc   : in out Process;
                   Signal : in Positive := 15) is
   begin
      if Is_Running (Proc) then
         Proc.Sys.Stop (Proc, Signal);
      end if;
   end Stop;

   --  ------------------------------
   --  Get the process exit status.
   --  ------------------------------
   function Get_Exit_Status (Proc : in Process) return Integer is
   begin
      return Proc.Exit_Value;
   end Get_Exit_Status;

   --  ------------------------------
   --  Get the process identifier.
   --  ------------------------------
   function Get_Pid (Proc : in Process) return Process_Identifier is
   begin
      return Proc.Pid;
   end Get_Pid;

   --  ------------------------------
   --  Returns True if the process is running.
   --  ------------------------------
   function Is_Running (Proc : in Process) return Boolean is
   begin
      return Proc.Pid > 0 and Proc.Exit_Value < 0;
   end Is_Running;

   --  ------------------------------
   --  Get the process input stream allowing to write on the process standard input.
   --  ------------------------------
   function Get_Input_Stream (Proc : in Process) return Util.Streams.Output_Stream_Access is
   begin
      return Proc.Input;
   end Get_Input_Stream;

   --  ------------------------------
   --  Get the process output stream allowing to read the process standard output.
   --  ------------------------------
   function Get_Output_Stream (Proc : in Process) return Util.Streams.Input_Stream_Access is
   begin
      return Proc.Output;
   end Get_Output_Stream;

   --  ------------------------------
   --  Get the process error stream allowing to read the process standard output.
   --  ------------------------------
   function Get_Error_Stream (Proc : in Process) return Util.Streams.Input_Stream_Access is
   begin
      return Proc.Error;
   end Get_Error_Stream;

   --  ------------------------------
   --  Initialize the process instance.
   --  ------------------------------
   overriding
   procedure Initialize (Proc : in out Process) is
   begin
      Proc.Sys := new Util.Processes.Os.System_Process;
      Proc.Shell := To_Unbounded_String (Util.Processes.Os.SHELL);
   end Initialize;

   --  ------------------------------
   --  Deletes the process instance.
   --  ------------------------------
   overriding
   procedure Finalize (Proc : in out Process) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Util.Streams.Input_Stream'Class,
                                         Name   => Util.Streams.Input_Stream_Access);
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Util.Streams.Output_Stream'Class,
                                         Name   => Util.Streams.Output_Stream_Access);
   begin
      if Proc.Sys /= null then
         Proc.Sys.Finalize;
         Free (Proc.Sys);
      end if;
      Free (Proc.Input);
      Free (Proc.Output);
      Free (Proc.Error);
      Free (Proc.To_Close);
   end Finalize;

end Util.Processes;

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

with Util.Log.Loggers;
with Util.Strings;
with Util.Processes.Os;
package body Util.Processes is

   use Util.Log;
   use Ada.Strings.Unbounded;

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

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Util.Processes.System_Process'Class,
                                     Name   => Util.Processes.System_Process_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => File_Type_Array,
                                     Name   => File_Type_Array_Access);

   --  ------------------------------
   --  Before launching the process, redirect the input stream of the process
   --  to the specified file.
   --  ------------------------------
   procedure Set_Input_Stream (Proc : in out Process;
                               File : in String) is
   begin
      if Proc.Is_Running then
         Log.Error ("Cannot set input stream to {0} while process is running", File);
         raise Invalid_State with "Process is running";
      end if;
      Proc.In_File := To_Unbounded_String (File);
   end Set_Input_Stream;

   --  ------------------------------
   --  Set the output stream of the process.
   --  ------------------------------
   procedure Set_Output_Stream (Proc   : in out Process;
                                File   : in String;
                                Append : in Boolean := False) is
   begin
      if Proc.Is_Running then
         Log.Error ("Cannot set output stream to {0} while process is running", File);
         raise Invalid_State with "Process is running";
      end if;
      Proc.Out_File   := To_Unbounded_String (File);
      Proc.Out_Append := Append;
   end Set_Output_Stream;

   --  ------------------------------
   --  Set the error stream of the process.
   --  ------------------------------
   procedure Set_Error_Stream (Proc   : in out Process;
                               File   : in String;
                               Append : in Boolean := False) is
   begin
      if Proc.Is_Running then
         Log.Error ("Cannot set error stream to {0} while process is running", File);
         raise Invalid_State with "Process is running";
      end if;
      Proc.Err_File   := To_Unbounded_String (File);
      Proc.Err_Append := Append;
   end Set_Error_Stream;

   --  ------------------------------
   --  Set the working directory that the process will use once it is created.
   --  The directory must exist or the Invalid_Directory exception will be raised.
   --  ------------------------------
   procedure Set_Working_Directory (Proc : in out Process;
                                    Path : in String) is
   begin
      if Proc.Is_Running then
         Log.Error ("Cannot set working directory to {0} while process is running", Path);
         raise Invalid_State with "Process is running";
      end if;
      Proc.Dir := To_Unbounded_String (Path);
   end Set_Working_Directory;

   --  ------------------------------
   --  Set the shell executable path to use to launch a command.  The default on Unix is
   --  the /bin/sh command.  Argument splitting is done by the /bin/sh -c command.
   --  When setting an empty shell command, the argument splitting is done by the
   --  <tt>Spawn</tt> procedure.
   --  ------------------------------
   procedure Set_Shell (Proc  : in out Process;
                        Shell : in String) is
   begin
      if Proc.Is_Running then
         Log.Error ("Cannot set shell to {0} while process is running", Shell);
         raise Invalid_State with "Process is running";
      end if;
      Proc.Shell := To_Unbounded_String (Shell);
   end Set_Shell;

   --  ------------------------------
   --  Closes the given file descriptor in the child process before executing the command.
   --  ------------------------------
   procedure Add_Close (Proc  : in out Process;
                        Fd    : in File_Type) is
      List : File_Type_Array_Access;
   begin
      if Proc.To_Close /= null then
         List := new File_Type_Array (1 .. Proc.To_Close'Last + 1);
         List (1 .. Proc.To_Close'Last) := Proc.To_Close.all;
         List (List'Last) := Fd;
         Free (Proc.To_Close);
      else
         List := new File_Type_Array (1 .. 1);
         List (1) := Fd;
      end if;
      Proc.To_Close := List;
   end Add_Close;

   --  ------------------------------
   --  Append the argument to the current process argument list.
   --  Raises Invalid_State if the process is running.
   --  ------------------------------
   procedure Append_Argument (Proc : in out Process;
                              Arg  : in String) is
   begin
      if Proc.Is_Running then
         Log.Error ("Cannot add argument '{0}' while process is running", Arg);
         raise Invalid_State with "Process is running";
      end if;
      Proc.Sys.Append_Argument (Arg);
   end Append_Argument;

   --  ------------------------------
   --  Set the environment variable to be used by the process before its creation.
   --  ------------------------------
   procedure Set_Environment (Proc  : in out Process;
                              Name  : in String;
                              Value : in String) is
   begin
      if Proc.Is_Running then
         Log.Error ("Cannot set environment '{0}' while process is running", Name);
         raise Invalid_State with "Process is running";
      end if;
      Proc.Sys.Set_Environment (Name, Value);
   end Set_Environment;

   procedure Set_Environment (Proc    : in out Process;
                              Iterate : not null access
                                procedure
                                  (Process : not null access procedure
                                     (Name  : in String;
                                      Value : in String))) is

      procedure Process (Name, Value : in String) is
      begin
         Proc.Sys.Set_Environment (Name, Value);
      end Process;

   begin
      if Proc.Is_Running then
         Log.Error ("Cannot set environment while process is running");
         raise Invalid_State with "Process is running";
      end if;
      Iterate (Process'Access);
   end Set_Environment;

   --  ------------------------------
   --  Spawn a new process with the given command and its arguments.  The standard input, output
   --  and error streams are either redirected to a file or to a stream object.
   --  ------------------------------
   procedure Spawn (Proc      : in out Process;
                    Command   : in String;
                    Arguments : in Argument_List) is
   begin
      if Is_Running (Proc) then
         raise Invalid_State with "A process is running";
      end if;

      Log.Info ("Starting process {0}", Command);

      --  if Proc.Sys /= null then
      --   Proc.Sys.Finalize;
      --   Free (Proc.Sys);
      --  end if;
      --  Proc.Sys := new Util.Processes.Os.System_Process;
      Proc.Sys.Clear_Arguments;

      --  Build the argc/argv table, terminate by NULL
      for I in Arguments'Range loop
         Proc.Sys.Append_Argument (Arguments (I).all);
      end loop;

      --  Prepare to redirect the input/output/error streams.
      Proc.Sys.Set_Streams (Input         => To_String (Proc.In_File),
                            Output        => To_String (Proc.Out_File),
                            Error         => To_String (Proc.Err_File),
                            Append_Output => Proc.Out_Append,
                            Append_Error  => Proc.Err_Append,
                            To_Close      => Proc.To_Close);

      --  System specific spawn
      Proc.Exit_Value := -1;
      Proc.Sys.Spawn (Proc);
   end Spawn;

   --  ------------------------------
   --  Spawn a new process with the given command and its arguments.  The standard input, output
   --  and error streams are either redirected to a file or to a stream object.
   --  ------------------------------
   procedure Spawn (Proc      : in out Process;
                    Command   : in String;
                    Mode      : in Pipe_Mode := NONE) is
      Pos  : Natural := Command'First;
      N    : Natural;
   begin
      if Is_Running (Proc) then
         raise Invalid_State with "A process is running";
      end if;

      Log.Info ("Starting process {0}", Command);

      --  if Proc.Sys /= null then
      --   Proc.Sys.Finalize;
      --   Free (Proc.Sys);
      --  end if;
      --  Proc.Sys := new Util.Processes.Os.System_Process;
      Proc.Sys.Clear_Arguments;

      if Length (Proc.Shell) > 0 then
         Proc.Sys.Append_Argument (To_String (Proc.Shell));
         Proc.Sys.Append_Argument ("-c");
         Proc.Sys.Append_Argument (Command);
      else
         --  Build the argc/argv table
         while Pos <= Command'Last loop
            N := Util.Strings.Index (Command, ' ', Pos);
            if N = 0 then
               N := Command'Last + 1;
            end if;
            Proc.Sys.Append_Argument (Command (Pos .. N - 1));
            Pos := N + 1;
         end loop;
      end if;

      --  Prepare to redirect the input/output/error streams.
      --  The pipe mode takes precedence and will override these redirections.
      Proc.Sys.Set_Streams (Input         => To_String (Proc.In_File),
                            Output        => To_String (Proc.Out_File),
                            Error         => To_String (Proc.Err_File),
                            Append_Output => Proc.Out_Append,
                            Append_Error  => Proc.Err_Append,
                            To_Close      => Proc.To_Close);

      --  System specific spawn
      Proc.Exit_Value := -1;
      Proc.Sys.Spawn (Proc, Mode);
   end Spawn;

   --  ------------------------------
   --  Wait for the process to terminate.
   --  ------------------------------
   procedure Wait (Proc : in out Process) is
   begin
      if not Is_Running (Proc) then
         return;
      end if;

      Log.Info ("Waiting for process {0}", Process_Identifier'Image (Proc.Pid));
      Proc.Sys.Wait (Proc, -1.0);
   end Wait;

   --  ------------------------------
   --  Terminate the process by sending a signal on Unix and exiting the process on Windows.
   --  This operation is not portable and has a different behavior between Unix and Windows.
   --  Its intent is to stop the process.
   --  ------------------------------
   procedure Stop (Proc   : in out Process;
                   Signal : in Positive := 15) is
   begin
      if Is_Running (Proc) then
         Proc.Sys.Stop (Proc, Signal);
      end if;
   end Stop;

   --  ------------------------------
   --  Get the process exit status.
   --  ------------------------------
   function Get_Exit_Status (Proc : in Process) return Integer is
   begin
      return Proc.Exit_Value;
   end Get_Exit_Status;

   --  ------------------------------
   --  Get the process identifier.
   --  ------------------------------
   function Get_Pid (Proc : in Process) return Process_Identifier is
   begin
      return Proc.Pid;
   end Get_Pid;

   --  ------------------------------
   --  Returns True if the process is running.
   --  ------------------------------
   function Is_Running (Proc : in Process) return Boolean is
   begin
      return Proc.Pid > 0 and Proc.Exit_Value < 0;
   end Is_Running;

   --  ------------------------------
   --  Get the process input stream allowing to write on the process standard input.
   --  ------------------------------
   function Get_Input_Stream (Proc : in Process) return Util.Streams.Output_Stream_Access is
   begin
      return Proc.Input;
   end Get_Input_Stream;

   --  ------------------------------
   --  Get the process output stream allowing to read the process standard output.
   --  ------------------------------
   function Get_Output_Stream (Proc : in Process) return Util.Streams.Input_Stream_Access is
   begin
      return Proc.Output;
   end Get_Output_Stream;

   --  ------------------------------
   --  Get the process error stream allowing to read the process standard output.
   --  ------------------------------
   function Get_Error_Stream (Proc : in Process) return Util.Streams.Input_Stream_Access is
   begin
      return Proc.Error;
   end Get_Error_Stream;

   --  ------------------------------
   --  Initialize the process instance.
   --  ------------------------------
   overriding
   procedure Initialize (Proc : in out Process) is
   begin
      Proc.Sys := new Util.Processes.Os.System_Process;
      Proc.Shell := To_Unbounded_String (Util.Processes.Os.SHELL);
   end Initialize;

   --  ------------------------------
   --  Deletes the process instance.
   --  ------------------------------
   overriding
   procedure Finalize (Proc : in out Process) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Util.Streams.Input_Stream'Class,
                                         Name   => Util.Streams.Input_Stream_Access);
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Util.Streams.Output_Stream'Class,
                                         Name   => Util.Streams.Output_Stream_Access);
   begin
      if Proc.Sys /= null then
         Proc.Sys.Finalize;
         Free (Proc.Sys);
      end if;
      Free (Proc.Input);
      Free (Proc.Output);
      Free (Proc.Error);
      Free (Proc.To_Close);
   end Finalize;

end Util.Processes;

Implement Set_Environment procedures

Implement Set_Environment procedures