gnatcoll-db/sql/gnatcoll-sql-exec.adb

------------------------------------------------------------------------------
--                             G N A T C O L L                              --
--                                                                          --
--                     Copyright (C) 2005-2020, AdaCore                     --
--                                                                          --
-- This library is free software;  you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software  Foundation;  either version 3,  or (at your  option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.                            --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
------------------------------------------------------------------------------

pragma Ada_2012;
with Ada.Calendar;               use Ada.Calendar;
with Ada.Containers.Hashed_Maps; use Ada.Containers;
with Ada.Containers.Hashed_Sets;
with Ada.Strings.Fixed;          use Ada.Strings;
with Ada.Strings.Maps.Constants;
with Ada.Strings.Hash;
with Ada.Strings.Unbounded;      use Ada.Strings.Unbounded;
with Ada.Unchecked_Deallocation;
with GNAT.Strings;               use GNAT.Strings;
with GNATCOLL.OS.Constants;      use GNATCOLL.OS.Constants;
with GNATCOLL.Plugins;           use GNATCOLL.Plugins;
with GNATCOLL.Traces;            use GNATCOLL.Traces;
with GNATCOLL.Utils;             use GNATCOLL.Utils;
with GNATCOLL.SQL.Exec_Private;  use GNATCOLL.SQL.Exec_Private;
with GNATCOLL.SQL.Exec.Tasking;  use GNATCOLL.SQL.Exec.Tasking;
with Interfaces.C.Strings;
with System.Address_Image;       use System;
with Ada.Unchecked_Conversion;

package body GNATCOLL.SQL.Exec is

   Me_Error  : constant Trace_Handle := Create ("SQL.ERROR", On);
   Me_Select : constant Trace_Handle := Create ("SQL.SELECT", Off);
   Me_Cache  : constant Trace_Handle := Create ("SQL.CACHE");
   Me_Perf   : constant Trace_Handle := Create ("SQL.PERF", Off);
   Me_Query  : constant Trace_Handle := Create ("SQL", Off);
   --  Disable by default those streams that tend to output a lot of data in
   --  standard applications.

   Cache_Expiration_Delay : constant Duration := 3600.0;  --  1 hour
   --  Delay after which the SQL cache expires and must be reset

   procedure Unchecked_Free is new Ada.Unchecked_Deallocation
     (Abstract_DBMS_Forward_Cursor'Class, Abstract_Cursor_Access);
   procedure Unchecked_Free is new Ada.Unchecked_Deallocation
     (Prepared_In_Session, Prepared_In_Session_List);

   function Is_Select_Query (Query : String) return Boolean;
   --  Return true if Query is a select query

   function Display_Query
     (Query      : String;
      Prepared   : Prepared_Statement'Class := No_Prepared) return String;
   --  Return the display for Query (or Prepared, if specified).
   --  This is for debug purposes only.

   function Prepared_Statement_Name
     (Name : String; Cache : Cache_Id) return XString
   is
     (To_XString
        (if Name = "" then "stmt" & Image (Natural (Cache), 0)
         else Name));
   --  Create prepared statement name either from Name parameter or from
   --  Cache_Id if Name is empty.

   procedure Execute_And_Log
     (Result     : in out Forward_Cursor'Class;
      Connection : access Database_Connection_Record'Class;
      Query      : String;
      Prepared   : Prepared_Statement'Class := No_Prepared;
      Direct     : Boolean;
      Params     : SQL_Parameters := No_Parameters);
   --  Low-level call to perform a query on the database and log results.
   --  The Query parameter is ignored if Prepared is provided.

   procedure Fetch_Internal
     (Result     : out Forward_Cursor'Class;
      Connection : access Database_Connection_Record'Class;
      Stmt       : Prepared_Statement'Class;
      Params     : SQL_Parameters);

   function Hash (Key : Cache_Id) return Ada.Containers.Hash_Type;

   package Cached_Maps is new Ada.Containers.Hashed_Maps
     (Key_Type        => Cache_Id,
      Element_Type    => Direct_Cursor,
      Hash            => Hash,
      Equivalent_Keys => "=");
   --  Cache the results of queries

   procedure Compute_And_Prepare_Statement
     (Prepared   : Prepared_Statement'Class;
      Connection : access Database_Connection_Record'Class;
      Stmt       : out DBMS_Stmt);
   --  Format the statement into a string, if not done yet.

   function Hash (Key : Database_Connection) return Ada.Containers.Hash_Type;
   package Freed_DB_Maps is new Ada.Containers.Hashed_Sets
     (Element_Type        => Database_Connection,
      Hash                => Hash,
      Equivalent_Elements => "=");
   --  List of connections that were freed, so that we no longer try to use
   --  them

   type Get_Database_Engine_Function is
     access function return Database_Engine_Access;

   DB_Engines : Database_Engines.Map;

   -----------
   -- Setup --
   -----------

   function Setup
     (Kind    : String;
      Options : Name_Values.Map;
      Errors  : access Error_Reporter'Class) return Database_Description
   is
      DBP    : Plugin := No_Plugin;
      CE     : Database_Engines.Cursor;
      Engine : Database_Engine_Access;
      DBE    : System.Address;

      function To_Function is new Ada.Unchecked_Conversion
        (Address, Get_Database_Engine_Function);
   begin
      CE := DB_Engines.Find (Kind);

      if Database_Engines.Has_Element (CE) then
         Engine := DB_Engines (CE);

      else
         DBP := Load ("libgnatcoll_" & Kind & DLL_Ext);

         if DBP = No_Plugin then
            Trace (Me_Error, "DB plugin load error: " & Last_Error_Message);
            return null;
         end if;

         DBE := Routine_Address (DBP, "db_engine");

         if DBE = Null_Address then
            Trace
              (Me_Error, "Can't bind engine provider: " & Last_Error_Message);
            return null;
         end if;

         Engine := To_Function (DBE).all;

         if Engine = null then
            Trace (Me_Error, "Can't get engine");
            return null;
         end if;

         Engine.Plugin := DBP;
         DB_Engines.Insert (Kind, Engine);
      end if;

      return Engine.Setup (Options, Errors);
   end Setup;

   -----------------
   -- Query_Cache --
   -----------------

   protected Query_Cache is
      procedure Get_Result
        (Stmt    : Prepared_Statement'Class;
         Cached  : out Direct_Cursor;
         Found   : out Boolean);
      --  Return null or the cached value for the statement

      procedure Set_Id (Stmt : Prepared_Statement'Class);
      --  Set the Cached_Result field of Stmt

      procedure Set_Cache
        (Stmt : Prepared_Statement'Class; Cached : Forward_Cursor'Class);
      --  Add a new value in the cache

      procedure Unset_Cache (Stmt : Prepared_Statement_Data);
      --  Unset the cache entry for this particular element

      procedure Reset;
      --  Reset the cache

      procedure Mark_DB_As_Free (DB : Database_Connection; Closed : Boolean);
      function Was_Freed (DB : Database_Connection) return Boolean;

   private
      Current_Cache_Id : Cache_Id := 1;
      --  First unassigned id for prepared statements

      Freed_DB  : Freed_DB_Maps.Set;

      Cache     : Cached_Maps.Map;
      Timestamp : Ada.Calendar.Time := Ada.Calendar.Clock;
   end Query_Cache;

   ----------
   -- Hash --
   ----------

   function Hash (Key : Cache_Id) return Ada.Containers.Hash_Type is
   begin
      return Ada.Containers.Hash_Type (Key);
   end Hash;

   ----------
   -- Hash --
   ----------

   function Hash (Key : Database_Connection) return Ada.Containers.Hash_Type is
   begin
      return Ada.Strings.Hash (System.Address_Image (Key.all'Address));
   end Hash;

   -----------------
   -- Query_Cache --
   -----------------

   protected body Query_Cache is

      ----------------
      -- Get_Result --
      ----------------

      procedure Get_Result
        (Stmt    : Prepared_Statement'Class;
         Cached  : out Direct_Cursor;
         Found   : out Boolean) is
      begin
         if Clock - Timestamp > Cache_Expiration_Delay then
            Reset;
            Found := False;
         else
            declare
               C : Cached_Maps.Cursor;
            begin
               if Stmt.Get.Cached_Result = No_Cache_Id
                 or else not Stmt.Get.Use_Cache
               then
                  Found := False;
               else
                  C := Cached_Maps.Find (Cache, Stmt.Get.Cached_Result);
                  Found := Cached_Maps.Has_Element (C);

                  if Found then
                     Cached := Task_Safe_Clone (Cached_Maps.Element (C));
                  end if;
               end if;
            end;
         end if;

      exception
         when E : others =>
            Trace (Me_Cache, E, "Get_Result ");
      end Get_Result;

      ------------
      -- Set_Id --
      ------------

      procedure Set_Id (Stmt : Prepared_Statement'Class) is
      begin
         if not Stmt.Is_Null
           and then Stmt.Get.Cached_Result = No_Cache_Id
         then
            Stmt.Get.Cached_Result := Current_Cache_Id;
            Current_Cache_Id := Current_Cache_Id + 1;
         end if;

      exception
         when E : others =>
            Trace (Me_Cache, E, "Set_Id ");
      end Set_Id;

      ---------------
      -- Set_Cache --
      ---------------

      procedure Set_Cache
        (Stmt : Prepared_Statement'Class; Cached : Forward_Cursor'Class)
      is
      begin
         --  Reserve capacity up to the current assigned id, since we are
         --  likely to need it anyway, and it is bound to be at least as big
         --  as Stmt.Cached.Id

         if Stmt.Get.Use_Cache then
            Set_Id (Stmt);
            Cache.Include
              (Stmt.Get.Cached_Result,
               Task_Safe_Instance (Cached, Index_By => Stmt.Get.Index_By));
         end if;

      exception
         when E : others =>
            Trace (Me_Cache, E, "Set_Cache ");
      end Set_Cache;

      -----------------
      -- Unset_Cache --
      -----------------

      procedure Unset_Cache (Stmt : Prepared_Statement_Data) is
         C : Cached_Maps.Cursor;
      begin
         if Stmt.Cached_Result /= No_Cache_Id
           and then Stmt.Use_Cache
         then
            C := Cache.Find (Stmt.Cached_Result);
            if Cached_Maps.Has_Element (C) then
               Trace (Me_Query, "Unset cache for " & Stmt.Name.To_String);
               Cache.Delete (C);
            end if;
         end if;

      exception
         when E : others =>
            Trace (Me_Cache, E, "Unset_Cache ");
      end Unset_Cache;

      -----------
      -- Reset --
      -----------

      procedure Reset is
      begin
         Cache.Clear;
         Timestamp := Clock;
      exception
         when E : others =>
            Trace (Me_Cache, E, "Reset ");
      end Reset;

      ---------------------
      -- Mark_DB_As_Free --
      ---------------------

      procedure Mark_DB_As_Free (DB : Database_Connection; Closed : Boolean) is
      begin
         if Closed then
            Freed_DB.Include (DB);
         else
            Freed_DB.Exclude (DB);
         end if;

      exception
         when E : others =>
            Trace (Me_Cache, E, "Mark_DB_As_Free ");
      end Mark_DB_As_Free;

      ---------------
      -- Was_Freed --
      ---------------

      function Was_Freed (DB : Database_Connection) return Boolean is
      begin
         return Freed_DB.Contains (DB);

      exception
         when E : others =>
            Trace (Me_Cache, E, "Was_Freed ");

            return False;
      end Was_Freed;

   end Query_Cache;

   ---------------
   -- To_String --
   ---------------

   function To_String
      (Connection : access Database_Connection_Record;
       Stmt       : Prepared_Statement'Class)
      return String
   is
      S : constant access Prepared_Statement_Data := Stmt.Unchecked_Get;
   begin
      if S.Query_Str = null then
         S.Query_Str := new String'
            (To_String (To_String (S.Query, Connection.all)));

         if Active (Me_Query) then
            Trace
              (Me_Query, "compute (" & S.Name.To_String & "): "
               & S.Query_Str.all);
         end if;

         S.Query := No_Query;   --  release memory
         S.Is_Select := Is_Select_Query (S.Query_Str.all);
      end if;

      return S.Query_Str.all;
   end To_String;

   -----------------------------------
   -- Compute_And_Prepare_Statement --
   -----------------------------------

   procedure Compute_And_Prepare_Statement
     (Prepared   : Prepared_Statement'Class;
      Connection : access Database_Connection_Record'Class;
      Stmt       : out DBMS_Stmt)
   is
      L : Prepared_In_Session_List;

      --  The side effect is to set S.Query_Str
      Str : constant String := To_String (Connection, Prepared);
   begin
      if Prepared.Get.On_Server
         and Is_Prepared_On_Server_Supported (Connection)
      then
         --  Reuse a prepared statement if one exists for this connection.

         L := Prepared.Get.Prepared;
         while L /= null loop
            exit when L.DB = Database_Connection (Connection);
            L := L.Next;
         end loop;

         if L = null then
            L := new Prepared_In_Session'
              (Stmt         => No_DBMS_Stmt,
               DB           => Database_Connection (Connection),
               DB_Timestamp => Connection.Connected_On,
               Next         => Prepared.Get.Prepared);
            Prepared.Get.Prepared := L;
         end if;

         --  Else prepare the statement

         if L.Stmt = No_DBMS_Stmt
            or else L.DB_Timestamp /= Connection.Connected_On
         then
            L.Stmt := Connect_And_Prepare
              (Connection, Str, Prepared.Get.Name.To_String, Direct => True);

            --  Set the timestamp *after* we have created the connection, in
            --  case it did not exist before (if prepare is the first command
            --  done on this connection).

            L.DB_Timestamp := Connection.Connected_On;

            --  L.Stmt could still be No_DBMS_Stmt if the backend does not
            --  support preparation on the server.  ??? This means we'll try
            --  again next time. For now, all supported DBMS have prepared
            --  statement, so that's not an issue.

         else
            Reset (Connection, L.Stmt);
         end if;

         Stmt := L.Stmt;
      else
         Stmt := No_DBMS_Stmt;
      end if;
   end Compute_And_Prepare_Statement;

   -------------------
   -- Print_Warning --
   -------------------

   procedure Print_Warning
     (Connection : access Database_Connection_Record'Class; Str : String) is
   begin
      Trace (Me_Query, Str & " (" & Connection.Username.To_String & ")");

      if Connection.Descr.Errors /= null then
         Connection.Descr.Errors.On_Warning (Connection, Str);
      end if;
   end Print_Warning;

   -----------------
   -- Print_Error --
   -----------------

   procedure Print_Error
     (Connection : access Database_Connection_Record'Class; Str : String) is
   begin
      Trace (Me_Error, Str & " (" & Connection.Username.To_String & ")");

      if Connection.Descr.Errors /= null then
         Connection.Descr.Errors.On_Error (Connection, Str);
      end if;
   end Print_Error;

   -------------------------------
   -- Report_Database_Corrupted --
   -------------------------------

   procedure Report_Database_Corrupted
     (Connection : access Database_Connection_Record'Class)
   is
   begin
      if Connection.Descr.Errors /= null then
         Connection.Descr.Errors.On_Database_Corrupted (Connection);
      end if;

      Print_Error (Connection, "Error, database is corrupted");
   end Report_Database_Corrupted;

   ----------
   -- Free --
   ----------

   procedure Free (Description : in out Database_Description) is
      procedure Unchecked_Free is new Ada.Unchecked_Deallocation
        (Database_Description_Record'Class, Database_Description);
   begin
      if Description /= null then
         --  as documented (in gnatcoll.sql.sqlite.setup), do not free the
         --  memory for Errors

         Free (Description.all);
         Unchecked_Free (Description);
      end if;
   end Free;

   ----------------------
   -- Check_Connection --
   ----------------------

   function Check_Connection
     (Connection : access Database_Connection_Record) return Boolean
   is
      Success    : Boolean;
      R          : Abstract_Cursor_Access;
   begin
      if Connection = null then
         Trace (Me_Error, "DBMS backend not supported");
         return False;
      end if;

      R := Connect_And_Execute
        (Database_Connection (Connection),
         Query     => "",
         Is_Select => False,
         Direct    => False);
      Success := R /= null;
      Unchecked_Free (R);

      if Success then
         Trace (Me_Query, "Init_Database: database successfully initialized");
      else
         Trace
           (Me_Error,
            "Init_Database: check_connection FAILED: "
            & Error (Database_Connection (Connection)));
      end if;

      return Success;
   end Check_Connection;

   ---------------------
   -- Is_Select_Query --
   ---------------------

   function Is_Select_Query (Query : String) return Boolean is
      --  Allow both "SELECT" and "(SELECT" (the latter is used when we do a
      --  union between two selects
   begin
      return Fixed.Index
               (Query, "SELECT ", Mapping => Maps.Constants.Upper_Case_Map)
             in 1 .. 2;
   end Is_Select_Query;

   -----------
   -- Image --
   -----------

   function Image
     (Format : Formatter'Class; Params : SQL_Parameters)
      return String
   is
      Result : Unbounded_String;
   begin
      for P in Params'Range loop
         Append (Result, ", ");
         Append (Result, Params (P).Image (Format));
      end loop;

      return To_String (Result);
   end Image;

   -------------------
   -- Display_Query --
   -------------------

   function Display_Query
     (Query      : String;
      Prepared   : Prepared_Statement'Class := No_Prepared) return String is
   begin
      if not Prepared.Is_Null then
         return "(" & Prepared.Get.Name.To_String & ")";
      else
         return Query;
      end if;
   end Display_Query;

   --------------------------
   -- Post_Execute_And_Log --
   --------------------------

   procedure Post_Execute_And_Log
     (R          : access Abstract_DBMS_Forward_Cursor'Class;
      Connection : access Database_Connection_Record'Class;
      Query      : String;
      Prepared   : Prepared_Statement'Class := No_Prepared;
      Is_Select  : Boolean;
      Params     : SQL_Parameters := No_Parameters)
   is
      function Get_Rows return String;
      --  The number of rows downloaded. If we only have a forward cursor, we
      --  can't display them

      function Get_User return String;
      --  Return the user name

      function Get_User return String is
      begin
         if Connection.Username = Null_XString then
            return "";
         else
            return " (" & Connection.Username.To_String & ")";
         end if;
      end Get_User;

      function Get_Rows return String is
      begin
         if R.all in DBMS_Direct_Cursor'Class then
            return " (" & Image
              (Processed_Rows (DBMS_Forward_Cursor'Class (R.all)),
               Min_Width => 1) & " tuples)";

         elsif Is_Select
           and then not Has_Row (DBMS_Forward_Cursor'Class (R.all))
         then
            return " (no tuples)";

         else
            --  We cannot count the number of rows, which would require getting
            --  all of them.
            return "";
         end if;
      end Get_Rows;

   begin
      if R = null then
         if Active (Me_Error) then
            Trace (Me_Error, "Transaction failed (null result): "
                   & Display_Query (Query, Prepared)
                   & Image (Connection.all, Params));
         end if;

         Set_Failure (Connection);

      elsif Is_Select then
         --  ??? Should use the local mirror database when doing a select,
         --  to speed up queries. Are we guaranteed, with the mirror, that
         --  doing a INSERT on the master, and immediately a SELECT on the
         --  slave will return the newly inserted values ?
         Connection.Success := Is_Success (DBMS_Forward_Cursor'Class (R.all));

         if not Connection.Success then
            if Active (Me_Error) then
               Trace (Me_Error, "select failed: "
                      & Display_Query (Query, Prepared)
                      & Image (Connection.all, Params)
                      & " " & Status (DBMS_Forward_Cursor'Class (R.all))
                      & " " & Error_Msg (DBMS_Forward_Cursor'Class (R.all))
                      & Get_User);
            end if;

            Set_Failure (Connection);

         elsif Active (Me_Select) then
            Trace
              (Me_Select,
               Display_Query (Query, Prepared)
               & Image (Connection.all, Params)
               & Get_Rows & " "
               & Status (DBMS_Forward_Cursor'Class (R.all)) & Get_User);
         end if;

      else
         Connection.Success := Is_Success (DBMS_Forward_Cursor'Class (R.all));
         if not Connection.Success then
            if Active (Me_Error) then
               --  This trace might duplicate information already available
               --  if both the SQL and SQL.ERRORS streams are active (since
               --  the result of the SQL has already shown the error message).
               --  However, it is useful when only SQL.ERRORS is active.
               Trace (Me_Error, "Transaction failed: "
                      & Display_Query (Query, Prepared)
                      & Image (Connection.all, Params)
                      & " " & Status (DBMS_Forward_Cursor'Class (R.all))
                      & " " & Error_Msg (DBMS_Forward_Cursor'Class (R.all))
                      & Get_User);
            end if;

            Set_Failure
              (Connection, Error_Msg (DBMS_Forward_Cursor'Class (R.all)));

         elsif Active (Me_Query) then
            declare
               Q : constant String := Display_Query (Query, Prepared);
            begin
               if Q = "BEGIN" then
                  Increase_Indent
                    (Me_Query,
                     Q & Image (Connection.all, Params)
                     & Get_Rows & " "
                     & Status (DBMS_Forward_Cursor'Class (R.all)) & Get_User);
               else
                  Trace
                    (Me_Query,
                     Q & Image (Connection.all, Params)
                     & Get_Rows & " "
                     & Status (DBMS_Forward_Cursor'Class (R.all)) & Get_User);
               end if;
            end;
         end if;
      end if;
   end Post_Execute_And_Log;

   -----------------------
   -- Start_Transaction --
   -----------------------

   function Start_Transaction
     (Connection : access Database_Connection_Record'Class)
      return Boolean is
   begin
      if not Connection.In_Transaction
        or else not Connection.Automatic_Transactions
      then
         Execute (Connection, "BEGIN");
         Connection.In_Transaction := True;
         return True;
      end if;
      return False;
   end Start_Transaction;

   ----------------
   -- Initialize --
   ----------------

   overriding procedure Initialize (Self : in out Transaction_Controller) is
   begin
      Self.Started := Self.DB.Start_Transaction;
   end Initialize;

   --------------
   -- Finalize --
   --------------

   overriding procedure Finalize (Self : in out Transaction_Controller) is
   begin
      if Self.Started then
         Self.DB.Commit_Or_Rollback;
      end if;
   end Finalize;

   ---------------------
   -- Execute_And_Log --
   ---------------------

   procedure Execute_And_Log
     (Result     : in out Forward_Cursor'Class;
      Connection : access Database_Connection_Record'Class;
      Query      : String;
      Prepared   : Prepared_Statement'Class := No_Prepared;
      Direct     : Boolean;
      Params     : SQL_Parameters := No_Parameters)
   is
      Is_Select : Boolean;
      Is_Commit_Or_Rollback : Boolean := False;
      Stmt : DBMS_Stmt := No_DBMS_Stmt;
      R    : Abstract_Cursor_Access;
      Was_Started : Boolean;
      pragma Unreferenced (Was_Started);

      Is_Prepared : constant Boolean :=
        Prepared /= Prepared_Statement'Class (No_Prepared);
      Index_By : Field_Index'Base;

      Start : Time;

      Q : access String := Query'Unrestricted_Access;
      --  Should be safe here, we do not intend to free anything

   begin
      if Active (Me_Perf) then
         Start := Clock;
      end if;

      if Is_Prepared then
         --  Compute the query. We cannot reference the query before
         --  that, since it might not have been computed yet.

         Compute_And_Prepare_Statement (Prepared, Connection, Stmt);
         Is_Select := Prepared.Get.Is_Select;
         Q := Prepared.Get.Query_Str;

      else
         Is_Select := Is_Select_Query (Query);
      end if;

      if Active (Me_Query) then
         Is_Commit_Or_Rollback :=
           Equal (Q.all, "commit", Case_Sensitive => False)
           or else Equal (Q.all, "rollback", Case_Sensitive => False);
         if Is_Commit_Or_Rollback then
            Decrease_Indent (Me_Query);
         end if;
      end if;

      --  Transaction management: do we need to start a transaction ?

      if Connection.Automatic_Transactions then
         if not Is_Select then
            Is_Commit_Or_Rollback :=
              Equal (Q.all, "commit", Case_Sensitive => False)
              or else Equal (Q.all, "rollback", Case_Sensitive => False);
         end if;

         if Connection.In_Transaction
           and then not Connection.Success
         then
            Trace
              (Me_Error,
               "Ignored, since transaction in failure: "
               & Display_Query (Q.all, Prepared)
               & " (" & Connection.Username.To_String & ")");
            return;

         elsif Equal (Q.all, "begin", Case_Sensitive => False) then
            if not Connection.In_Transaction then
               Connection.In_Transaction := True;
            else
               --  Ignore silently: GNATCOLL might have started a transaction
               --  without the user knowing, for instance on the first SELECT
               --  statement if Always_Use_Transactions is true.
               return;
            end if;

         elsif not Connection.In_Transaction
           and then
             (Connection.Always_Use_Transactions
              or else
                (not Is_Commit_Or_Rollback
                 and then not Is_Select))  --  INSERT, UPDATE, LOCK, DELETE,...
           and then
             (Q'Length <= 7   --  for sqlite
              or else Q (Q'First .. Q'First + 6) /= "PRAGMA ")
           and then
             (Q'Length <= 7   --  for sqlite
              or else Q (Q'First .. Q'First + 6) /= "ANALYZE")
         then
            --  Start a transaction automatically
            Was_Started := Start_Transaction (Connection);
            if not Connection.Success then
               return;
            end if;
         end if;

      else
         if Equal (Q.all, "begin", Case_Sensitive => False) then
            Connection.In_Transaction := True;
         end if;
      end if;

      if Perform_Queries then
         R := Connect_And_Execute
           (Connection => Connection,
            Query      => Q.all,
            Stmt       => Stmt,
            Is_Select  => Is_Select,
            Direct     => Direct,
            Params     => Params);

         if R = null then
            if Active (Me_Error) then
               if Stmt /= No_DBMS_Stmt then
                  Trace (Me_Error, "Failed to execute prepared ("
                         & Prepared.Get.Name.To_String & ") " & Q.all
                         & " " & Image (Connection.all, Params)
                         & " error=" & Error (Connection));
               else
                  Trace (Me_Error, "Failed to execute " & Q.all
                         & " " & Image (Connection.all, Params)
                         & " error=" & Error (Connection));
               end if;
            end if;

            Set_Failure (Connection);

         else
            Index_By := (if Is_Prepared then Prepared.Get.Index_By
                         else No_Field_Index);

            if Direct
              and then (R.all not in DBMS_Direct_Cursor'Class
                        or Index_By /= No_Field_Index)
            then
               --  DBMS does not support Direct_Cursor or indexed cursor
               --  requested. We now need to read all the results and store
               --  them into GNATCOLL implemented Direct_Cursor.

               declare
                  R2 : constant Abstract_Cursor_Access :=
                    Task_Safe_Instance (R, Index_By);
               begin
                  Finalize (DBMS_Forward_Cursor'Class (R.all));
                  Unchecked_Free (R);

                  R := R2;
               end;
            end if;

            Post_Execute_And_Log
              (R, Connection, Q.all, Prepared, Is_Select, Params);
         end if;

         Result.Res := R;
      end if;

      if Connection.Automatic_Transactions
        and then Connection.In_Transaction
        and then Is_Commit_Or_Rollback
      then
         Connection.In_Transaction := False;
      end if;

      if Active (Me_Perf) then
         Trace (Me_Perf, "Finished executing query:"
                & Duration'Image ((Clock - Start) * 1000.0) & " ms");
      end if;
   end Execute_And_Log;

   -----------------------
   -- Insert_And_Get_PK --
   -----------------------

   function Insert_And_Get_PK
     (Connection : access Database_Connection_Record'Class;
      Query      : GNATCOLL.SQL.SQL_Query;
      Params     : SQL_Parameters := No_Parameters;
      PK         : SQL_Field_Integer) return Integer
   is
   begin
      return Insert_And_Get_PK
         (Connection, To_String (To_String (Query, Connection.all)),
          Params, PK);
   end Insert_And_Get_PK;

   -----------------------
   -- Insert_And_Get_PK --
   -----------------------

   function Insert_And_Get_PK
     (Connection : access Database_Connection_Record;
      Query      : String;
      Params     : SQL_Parameters := No_Parameters;
      PK         : SQL_Field_Integer) return Integer
   is
      R : Forward_Cursor;
      Id : Integer;
   begin
      Fetch (R, Connection, Query, Params);
      Id := Last_Id (R, Connection, PK);

      if Active (Me_Query) then
         Trace (Me_Query, "  => id=" & Id'Img);
      end if;

      return Id;
   end Insert_And_Get_PK;

   -----------
   -- Fetch --
   -----------

   procedure Fetch
     (Result     : out Forward_Cursor;
      Connection : access Database_Connection_Record'Class;
      Query      : String;
      Params     : SQL_Parameters := No_Parameters) is
   begin
      Result := No_Element;
      Execute_And_Log
        (Result, Connection, Query, No_Prepared, Direct => False,
         Params => Params);
   end Fetch;

   -----------
   -- Fetch --
   -----------

   procedure Fetch
     (Result     : out Forward_Cursor;
      Connection : access Database_Connection_Record'Class;
      Query      : SQL_Query;
      Params     : SQL_Parameters := No_Parameters) is
   begin
      Fetch
        (Result, Connection, To_String (To_String (Query, Connection.all)),
         Params);
   end Fetch;

   -----------
   -- Fetch --
   -----------

   procedure Fetch
     (Result     : out Direct_Cursor;
      Connection : access Database_Connection_Record'Class;
      Query      : String;
      Params     : SQL_Parameters := No_Parameters) is
   begin
      Result := No_Direct_Element;
      Execute_And_Log
        (Result, Connection, Query, No_Prepared, Direct => True,
         Params => Params);
   end Fetch;

   -----------
   -- Fetch --
   -----------

   overriding procedure Fetch
     (Result     : out Direct_Cursor;
      Connection : access Database_Connection_Record'Class;
      Query      : GNATCOLL.SQL.SQL_Query;
      Params     : SQL_Parameters := No_Parameters) is
   begin
      Fetch
        (Result, Connection, To_String (To_String (Query, Connection.all)),
         Params => Params);
   end Fetch;

   -------------
   -- Execute --
   -------------

   procedure Execute
     (Connection : access Database_Connection_Record'Class;
      Query      : SQL_Query;
      Params     : SQL_Parameters := No_Parameters)
   is
      R : Forward_Cursor;
      pragma Unreferenced (R);
   begin
      Fetch (R, Connection, Query, Params);
   end Execute;

   -------------
   -- Execute --
   -------------

   procedure Execute
     (Connection : access Database_Connection_Record'Class;
      Query      : String;
      Params     : SQL_Parameters := No_Parameters)
   is
      R : Forward_Cursor;
      pragma Unreferenced (R);
   begin
      Fetch (R, Connection, Query, Params);
   end Execute;

   -------------
   -- Success --
   -------------

   function Success
     (Connection : access Database_Connection_Record) return Boolean is
   begin
      return Connection.Success;
   end Success;

   -----------------
   -- Set_Failure --
   -----------------

   procedure Set_Failure
     (Connection : access Database_Connection_Record'Class;
      Error_Msg  : String := "") is
   begin
      Connection.Success := False;
      if Connection.Error_Msg = Null_XString then
         if Error_Msg /= "" then
            Connection.Error_Msg := To_XString (Error_Msg);
         else
            declare
               E : constant String := Error (Connection);
            begin
               if E /= "" then
                  Connection.Error_Msg := To_XString (E);
               end if;
            end;
         end if;
      end if;
   end Set_Failure;

   --------------------
   -- In_Transaction --
   --------------------

   function In_Transaction
     (Connection : access Database_Connection_Record'Class) return Boolean is
   begin
      return Connection.In_Transaction;
   end In_Transaction;

   --------------
   -- Rollback --
   --------------

   procedure Rollback
     (Connection : access Database_Connection_Record'Class;
      Error_Msg  : String := "") is
   begin
      if Connection.In_Transaction
        or else not Connection.Automatic_Transactions
      then
         Connection.Success := True; --  we are allowed to perform this
         Execute (Connection, "ROLLBACK");
         Connection.In_Transaction := False;
         if Connection.Error_Msg = Null_XString and then Error_Msg /= "" then
            Connection.Error_Msg := To_XString (Error_Msg);
         end if;

         --  A rollback can only fail if the connection to the database
         --  was broken. But in that case the transaction is lost anyway,
         --  so it behaves as if the rollback had succeeded.
         Connection.Success := True;
      end if;
   end Rollback;

   ------------------------
   -- Commit_Or_Rollback --
   ------------------------

   procedure Commit_Or_Rollback
     (Connection : access Database_Connection_Record'Class) is
   begin
      if Connection.In_Transaction
        or else not Connection.Automatic_Transactions
      then
         if Connection.Success then
            Execute (Connection, "COMMIT");
         else
            Rollback (Connection);

            --  Still marked as failed, since the transaction was never
            --  performed.
            Connection.Success := False;
         end if;
         Connection.In_Transaction := False;
      end if;
   end Commit_Or_Rollback;

   ----------------------
   -- Invalidate_Cache --
   ----------------------

   procedure Invalidate_Cache is
   begin
      Trace (Me_Query, "Invalidate SQL cache");
      Query_Cache.Reset;
   end Invalidate_Cache;

   ----------------------
   -- Reset_Connection --
   ----------------------

   procedure Reset_Connection
     (Connection  : access Database_Connection_Record'Class;
      Username    : String := "") is
   begin
      if Connection.In_Transaction then
         Rollback (Connection); --  In case a previous thread had started on
      end if;
      Connection.Success := True;
      Connection.Automatic_Transactions := True;

      if Username /= "" or else Connection.Username = Null_XString then
         Connection.Username := To_XString (Username);
      end if;

      Connection.Error_Msg := Null_XString;
   end Reset_Connection;

   ------------------------
   -- Last_Error_Message --
   ------------------------

   function Last_Error_Message
     (Connection : access Database_Connection_Record'Class) return String is
   begin
      return Connection.Error_Msg.To_String;
   end Last_Error_Message;

   ------------
   -- Adjust --
   ------------

   overriding procedure Adjust (Self : in out Forward_Cursor) is
   begin
      if Self.Res /= null then
         Self.Res.Refcount := Self.Res.Refcount + 1;
      end if;
   end Adjust;

   --------------
   -- Finalize --
   --------------

   overriding procedure Finalize (Self : in out Forward_Cursor) is
      Res : Abstract_Cursor_Access := Self.Res;
   begin
      Self.Res := null; -- Make Finalize idempotent
      if Res /= null then
         Res.Refcount := Res.Refcount - 1;
         if Res.Refcount = 0 then
            Finalize (DBMS_Forward_Cursor'Class (Res.all));
            Unchecked_Free (Res);
         end if;
      end if;
   end Finalize;

   --------------------
   -- Processed_Rows --
   --------------------

   function Processed_Rows (Self : Forward_Cursor) return Natural is
   begin
      if Self.Res = null then
         return 0;
      else
         return Processed_Rows (DBMS_Forward_Cursor'Class (Self.Res.all));
      end if;
   end Processed_Rows;

   -------------
   -- Has_Row --
   -------------

   function Has_Row (Self : Forward_Cursor) return Boolean is
   begin
      if Self.Res = null then
         return False;
      else
         return Has_Row (DBMS_Forward_Cursor'Class (Self.Res.all));
      end if;
   end Has_Row;

   ----------
   -- Next --
   ----------

   procedure Next (Self : in out Forward_Cursor) is
   begin
      if Self.Res /= null then
         Next (DBMS_Forward_Cursor'Class (Self.Res.all));
      end if;
   end Next;

   -----------
   -- Value --
   -----------

   function Value
     (Self  : Forward_Cursor;
      Field : Field_Index) return String is
   begin
      return Value (DBMS_Forward_Cursor'Class (Self.Res.all), Field);
   end Value;

   ---------------------
   -- Unbounded_Value --
   ---------------------

   function Unbounded_Value
     (Self : Forward_Cursor; Field : Field_Index) return Unbounded_String is
   begin
      return Unbounded_Value (DBMS_Forward_Cursor'Class (Self.Res.all), Field);
   end Unbounded_Value;

   -------------------
   -- XString_Value --
   -------------------

   function XString_Value
     (Self : Forward_Cursor; Field : Field_Index) return XString is
   begin
      return XString_Value (DBMS_Forward_Cursor'Class (Self.Res.all), Field);
   end XString_Value;

   -------------------
   -- Boolean_Value --
   -------------------

   function Boolean_Value
     (Self  : Forward_Cursor;
      Field : Field_Index) return Boolean is
   begin
      return Boolean_Value (DBMS_Forward_Cursor'Class (Self.Res.all), Field);
   end Boolean_Value;

   -------------------
   -- Integer_Value --
   -------------------

   function Integer_Value
     (Self   : Forward_Cursor;
      Field  : Field_Index) return Integer
   is
   begin
      return Integer_Value (DBMS_Forward_Cursor'Class (Self.Res.all), Field);
   end Integer_Value;

   -------------------
   -- Integer_Value --
   -------------------

   function Integer_Value
     (Self   : Forward_Cursor;
      Field  : Field_Index;
      Default : Integer) return Integer
   is
   begin
      return Integer_Value (DBMS_Forward_Cursor'Class (Self.Res.all), Field);
   exception
      when Constraint_Error | Interfaces.C.Strings.Dereference_Error  =>
         return Default;
   end Integer_Value;

   ------------------
   -- Bigint_Value --
   ------------------

   function Bigint_Value
     (Self   : Forward_Cursor;
      Field  : Field_Index) return Long_Long_Integer
   is
   begin
      return Bigint_Value (DBMS_Forward_Cursor'Class (Self.Res.all), Field);
   end Bigint_Value;

   ------------------
   -- Bigint_Value --
   ------------------

   function Bigint_Value
     (Self   : Forward_Cursor;
      Field  : Field_Index;
      Default : Long_Long_Integer) return Long_Long_Integer
   is
   begin
      return Bigint_Value (DBMS_Forward_Cursor'Class (Self.Res.all), Field);
   exception
      when Constraint_Error | Interfaces.C.Strings.Dereference_Error  =>
         return Default;
   end Bigint_Value;

   -----------------
   -- Float_Value --
   -----------------

   function Float_Value
     (Self  : Forward_Cursor;
      Field : Field_Index) return Float is
   begin
      return Float_Value (DBMS_Forward_Cursor'Class (Self.Res.all), Field);
   end Float_Value;

   function Float_Value
     (Self    : Forward_Cursor;
      Field   : Field_Index;
      Default : Float) return Float is
   begin
      return Float_Value (DBMS_Forward_Cursor'Class (Self.Res.all), Field);
   exception
      when Constraint_Error | Interfaces.C.Strings.Dereference_Error =>
         return Default;
   end Float_Value;

   ----------------------
   -- Long_Float_Value --
   ----------------------

   function Long_Float_Value
     (Self : Forward_Cursor; Field : Field_Index) return Long_Float is
   begin
      return Long_Float_Value
               (DBMS_Forward_Cursor'Class (Self.Res.all), Field);
   end Long_Float_Value;

   function Long_Float_Value
     (Self    : Forward_Cursor;
      Field   : Field_Index;
      Default : Long_Float) return Long_Float is
   begin
      return Long_Float_Value
               (DBMS_Forward_Cursor'Class (Self.Res.all), Field);
   exception
      when Constraint_Error | Interfaces.C.Strings.Dereference_Error =>
         return Default;
   end Long_Float_Value;

   -----------
   -- Value --
   -----------

   function Money_Value
     (Self : Forward_Cursor; Field : Field_Index)
     return T_Money is
   begin
      return Money_Value (DBMS_Forward_Cursor'Class (Self.Res.all), Field);
   end Money_Value;

   ----------------
   -- Time_Value --
   ----------------

   function Time_Value
     (Self  : Forward_Cursor;
      Field : Field_Index) return Ada.Calendar.Time is
   begin
      return Time_Value (DBMS_Forward_Cursor'Class (Self.Res.all), Field);
   end Time_Value;

   -------------
   -- Is_Null --
   -------------

   function Is_Null
     (Self  : Forward_Cursor;
      Field : Field_Index) return Boolean is
   begin
      return Is_Null (DBMS_Forward_Cursor'Class (Self.Res.all), Field);
   end Is_Null;

   -------------
   -- Last_Id --
   -------------

   function Last_Id
     (Self       : Forward_Cursor;
      Connection : access Database_Connection_Record'Class;
      Field      : SQL_Field_Integer) return Integer is
   begin
      if Perform_Queries then
         if Self.Res = null then
            return -1;
         else
            return Last_Id
              (DBMS_Forward_Cursor'Class (Self.Res.all), Connection, Field);
         end if;
      else
         return 1;  --  Dummy
      end if;
   end Last_Id;

   ---------------------
   -- Get_Description --
   ---------------------

   function Get_Description
     (Connection : access Database_Connection_Record'Class)
      return Database_Description
   is
   begin
      return Database_Description (Connection.Descr);
   end Get_Description;

   -----------------
   -- Field_Count --
   -----------------

   function Field_Count (Self : Forward_Cursor) return Field_Index is
   begin
      return Field_Count (DBMS_Forward_Cursor'Class (Self.Res.all));
   end Field_Count;

   ----------------
   -- Field_Name --
   ----------------

   function Field_Name
     (Self : Forward_Cursor; Field : Field_Index) return String is
   begin
      return Field_Name (DBMS_Forward_Cursor'Class (Self.Res.all), Field);
   end Field_Name;

   -----------
   -- First --
   -----------

   procedure First (Self : in out Direct_Cursor) is
   begin
      First (DBMS_Direct_Cursor'Class (Self.Res.all));
   end First;

   -------------
   -- Current --
   -------------

   function Current (Self : Forward_Cursor) return Positive is
   begin
      return Current (DBMS_Forward_Cursor'Class (Self.Res.all));
   end Current;

   ----------
   -- Last --
   ----------

   procedure Last  (Self : in out Direct_Cursor) is
   begin
      Last (DBMS_Direct_Cursor'Class (Self.Res.all));
   end Last;

   --------------
   -- Absolute --
   --------------

   procedure Absolute (Self : in out Direct_Cursor; Row : Positive) is
   begin
      Absolute (DBMS_Direct_Cursor'Class (Self.Res.all), Row);
   end Absolute;

   --------------
   -- Relative --
   --------------

   procedure Relative (Self : in out Direct_Cursor; Step : Integer) is
   begin
      Relative (DBMS_Direct_Cursor'Class (Self.Res.all), Step);
   end Relative;

   ----------
   -- Find --
   ----------

   procedure Find (Self : in out Direct_Cursor; Value : Integer) is
   begin
      Find (Self, Image (Value, Min_Width => 0));
   end Find;

   procedure Find (Self : in out Direct_Cursor; Value : String) is
   begin
      Tasking.Find (Self.Res, Value);
   end Find;

   --------------------
   -- Mark_As_Closed --
   --------------------

   procedure Mark_As_Closed
     (Connection : access Database_Connection_Record'Class;
      Closed     : Boolean) is
   begin
      Query_Cache.Mark_DB_As_Free (Database_Connection (Connection), Closed);
   end Mark_As_Closed;

   ----------------
   -- Was_Closed --
   ----------------

   function Was_Closed
     (Connection : access Database_Connection_Record'Class) return Boolean is
   begin
      return Query_Cache.Was_Freed (Database_Connection (Connection));
   end Was_Closed;

   ----------
   -- Free --
   ----------

   procedure Free (Connection : in out Database_Connection) is
      procedure Unchecked_Free is new Ada.Unchecked_Deallocation
        (Database_Connection_Record'Class, Database_Connection);
   begin
      if Connection /= null then
         Close (Connection);

         Mark_As_Closed (Connection, Closed => True);
         Unchecked_Free (Connection);
      end if;
   end Free;

   -------------
   -- Prepare --
   -------------

   function Prepare
     (Query         : SQL_Query;
      Auto_Complete : Boolean := False;
      Use_Cache     : Boolean := False;
      On_Server     : Boolean := False;
      Index_By      : Field_Index'Base := No_Field_Index;
      Name          : String := "") return Prepared_Statement
   is
      Stmt : Prepared_Statement;
      Ptr  : Prepared_Statements.Element_Access;
   begin
      Stmt.Set
        (Prepared_Statement_Data'
           (Query         => Query,
            Query_Str     => null,  -- Computed later
            Is_Select     => False, -- Computed later
            Use_Cache     => Use_Cache,
            Cached_Result => No_Cache_Id,
            Index_By      => Index_By,
            On_Server     => On_Server,
            Name          => Null_XString,
            Prepared      => null));

      Query_Cache.Set_Id (Stmt);

      Ptr := Stmt.Unchecked_Get;

      Ptr.Name := Prepared_Statement_Name (Name, Ptr.Cached_Result);

      if Auto_Complete then
         GNATCOLL.SQL.Auto_Complete (Ptr.Query);
      end if;

      return Stmt;
   end Prepare;

   -------------
   -- Prepare --
   -------------

   function Prepare
     (Query     : String;
      Use_Cache : Boolean := False;
      On_Server : Boolean := False;
      Index_By  : Field_Index'Base := No_Field_Index;
      Name      : String := "") return Prepared_Statement
   is
      Stmt : Prepared_Statement;
      Ptr  : Prepared_Statements.Element_Access;
   begin
      if Active (Me_Query) then
         Trace (Me_Query, "compute (" & Name & "): " & Query);
      end if;

      Stmt.Set
        (Prepared_Statement_Data'
           (Query         => No_Query,
            Query_Str     => new String'(Query),
            Is_Select     => Is_Select_Query (Query),
            Use_Cache     => Use_Cache,
            Cached_Result => No_Cache_Id,
            Index_By      => Index_By,
            On_Server     => On_Server,
            Name          => Null_XString,
            Prepared      => null));

      Query_Cache.Set_Id (Stmt);

      Ptr := Stmt.Unchecked_Get;

      Ptr.Name := Prepared_Statement_Name (Name, Ptr.Cached_Result);

      return Stmt;
   end Prepare;

   -----------------
   -- Clear_Cache --
   -----------------

   procedure Clear_Cache (Stmt : Prepared_Statement) is
   begin
      Query_Cache.Unset_Cache (Stmt.Get);
   end Clear_Cache;

   --------------------
   -- Fetch_Internal --
   --------------------

   procedure Fetch_Internal
     (Result     : out Forward_Cursor'Class;
      Connection : access Database_Connection_Record'Class;
      Stmt       : Prepared_Statement'Class;
      Params     : SQL_Parameters)
   is
      Direct : constant Boolean := Result in Direct_Cursor'Class;
      Found : Boolean;

      procedure Put_Result (Item : Forward_Cursor'Class);

      procedure Put_Result (Item : Forward_Cursor'Class) is
      begin
         if Direct then
            Direct_Cursor (Result) := Direct_Cursor (Item);
         else
            Forward_Cursor (Result) := Forward_Cursor (Item);
         end if;
      end Put_Result;

   begin
      Put_Result (No_Direct_Element);

      if Stmt.Is_Null then
         Trace (Me_Error, "Prepared statement was freed, can't execute");
         return;
      end if;

      if Stmt.Get.Use_Cache
        and then Connection.Descr.Caching
        and then Params = No_Parameters --  Parameters not supported for now
      then
         declare
            RC : Direct_Cursor;
         begin
            Query_Cache.Get_Result (Stmt, RC, Found);

            if Found then
               if Active (Me_Cache) then
                  Trace (Me_Cache, "(" & Stmt.Get.Name.To_String
                     & "): from cache");
               end if;

               Put_Result (RC);

               return;
            end if;
         end;

         declare
            RE : Forward_Cursor;
         begin
            --  for the caching do not need the Direct cursor, because it have
            --  to be translated into cache task safe anyway.

            Execute_And_Log
              (RE, Connection, "", Stmt, Direct => False, Params => Params);

            if Success (Connection) then
               Query_Cache.Set_Cache (Stmt, RE);

               --  Recursive reuse get from cache code of this routine

               Fetch_Internal (Result, Connection, Stmt, Params);

            elsif Direct then
               --  Just to return error in direct cursor type

               Put_Result (Task_Safe_Instance (RE, Stmt.Get.Index_By));

            else
               --  Just to return error

               Put_Result (RE);
            end if;

            return;
         end;
      end if; -- Cache processing

      Execute_And_Log
        (Result, Connection, "", Stmt, Direct => Direct, Params => Params);
   end Fetch_Internal;

   -----------
   -- Fetch --
   -----------

   procedure Fetch
     (Result     : out Direct_Cursor;
      Connection : access Database_Connection_Record'Class;
      Stmt       : Prepared_Statement'Class;
      Params     : SQL_Parameters := No_Parameters) is
   begin
      Fetch_Internal (Result, Connection, Stmt, Params);
   end Fetch;

   -----------
   -- Fetch --
   -----------

   procedure Fetch
     (Result     : out Forward_Cursor;
      Connection : access Database_Connection_Record'Class;
      Stmt       : Prepared_Statement'Class;
      Params     : SQL_Parameters := No_Parameters) is
   begin
      Fetch_Internal (Result, Connection, Stmt, Params);
   end Fetch;

   -----------------------
   -- Insert_And_Get_PK --
   -----------------------

   function Insert_And_Get_PK
     (Connection : access Database_Connection_Record;
      Stmt       : Prepared_Statement'Class;
      Params     : SQL_Parameters := No_Parameters;
      PK         : SQL_Field_Integer) return Integer
   is
      Result : Forward_Cursor;
      Id : Integer;
   begin
      Execute_And_Log
        (Result, Connection, "", Stmt, Direct => False, Params => Params);
      Id := Last_Id (Result, Connection, PK);

      if Active (Me_Query) then
         Trace (Me_Query, "  => id=" & Id'Img);
      end if;

      return Id;
   end Insert_And_Get_PK;

   -------------
   -- Execute --
   -------------

   procedure Execute
     (Connection : access Database_Connection_Record'Class;
      Stmt       : Prepared_Statement'Class;
      Params     : SQL_Parameters := No_Parameters)
   is
      R : Forward_Cursor;
      pragma Unreferenced (R);
   begin
      Fetch (R, Connection, Stmt, Params);
   end Execute;

   -------------------------
   -- Connect_And_Prepare --
   -------------------------

   function Connect_And_Prepare
     (Connection : access Database_Connection_Record;
      Query      : String;
      Name       : String;
      Direct     : Boolean)
      return DBMS_Stmt
   is
      pragma Unreferenced (Connection, Query, Direct, Name);
   begin
      return No_DBMS_Stmt;
   end Connect_And_Prepare;

   -------------
   -- Execute --
   -------------

   function Execute
     (Connection  : access Database_Connection_Record;
      Prepared    : DBMS_Stmt;
      Is_Select   : Boolean;
      Direct      : Boolean;
      Params      : SQL_Parameters := No_Parameters)
      return Abstract_Cursor_Access
   is
      pragma Unreferenced (Connection, Prepared, Is_Select, Direct, Params);
   begin
      return null;
   end Execute;

   ---------
   -- "+" --
   ---------

   function "+" (Value : access constant String) return SQL_Parameter is
      R : SQL_Parameter;
      P : SQL_Parameter_Text;
   begin
      P.Str_Ptr   := Value.all'Unrestricted_Access;
      P.Make_Copy := False;
      R.Set (P);
      return R;
   end "+";

   function "+" (Value : String) return SQL_Parameter is
      R : SQL_Parameter;
      P : SQL_Parameter_Text;
   begin
      P.Str_Val := To_Unbounded_String (Value);
      P.Make_Copy := False;
      R.Set (P);
      return R;
   end "+";

   function "+" (Value : Unbounded_String) return SQL_Parameter is
      R : SQL_Parameter;
      P : SQL_Parameter_Text;
   begin
      P.Str_Val := Value;
      P.Make_Copy := False;
      R.Set (P);
      return R;
   end "+";

   ----------
   -- Copy --
   ----------

   function Copy (Value : access constant String) return SQL_Parameter is
      R : SQL_Parameter;
      P : SQL_Parameter_Text;
   begin
      P.Str_Ptr   := Value.all'Unrestricted_Access;
      P.Make_Copy := True;
      R.Set (P);
      return R;
   end Copy;

   ---------
   -- "+" --
   ---------

   function "+" (Value : Integer) return SQL_Parameter is
      R : SQL_Parameter;
      P : SQL_Parameter_Integer;
   begin
      P.Val := Value;
      R.Set (P);
      return R;
   end "+";

   ---------------
   -- As_Bigint --
   ---------------

   function As_Bigint (Value : Long_Long_Integer) return SQL_Parameter is
      R : SQL_Parameter;
      P : SQL_Parameter_Bigint;
   begin
      P.Val := Value;
      R.Set (P);
      return R;
   end As_Bigint;

   ---------
   -- "+" --
   ---------

   function "+" (Value : Boolean) return SQL_Parameter is
      R : SQL_Parameter;
      P : SQL_Parameter_Boolean;
   begin
      P.Val := Value;
      R.Set (P);
      return R;
   end "+";

   ---------
   -- "+" --
   ---------

   function "+" (Value : Float) return SQL_Parameter is
      R : SQL_Parameter;
      P : SQL_Parameter_Float;
   begin
      P.Val := Value;
      R.Set (P);
      return R;
   end "+";

   -------------------
   -- As_Long_Float --
   -------------------

   function As_Long_Float (Value : Long_Float) return SQL_Parameter is
      R : SQL_Parameter;
      P : SQL_Parameter_Long_Float;
   begin
      P.Val := Value;
      R.Set (P);
      return R;
   end As_Long_Float;

   ---------
   -- "+" --
   ---------

   function "+" (Value : Character) return SQL_Parameter is
      R : SQL_Parameter;
      P : SQL_Parameter_Character;
   begin
      P.Char_Val := Value;
      R.Set (P);
      return R;
   end "+";

   ---------
   -- "+" --
   ---------

   function "+" (Time : Ada.Calendar.Time) return SQL_Parameter is
      R : SQL_Parameter;
      P : SQL_Parameter_Time;
   begin
      P.Val := Time;
      R.Set (P);
      return R;
   end "+";

   ---------
   -- "+" --
   ---------

   function "+" (Value : T_Money) return SQL_Parameter is
      R : SQL_Parameter;
      P : SQL_Parameter_Money;
   begin
      P.Val := Value;
      R.Set (P);
      return R;
   end "+";

   ----------
   -- Free --
   ----------

   procedure Free (Self : in out Prepared_Statement_Data) is
      L, L2 : Prepared_In_Session_List;
      Count : Natural := 0;
   begin
      --  If there is a single DB, we are in one of two cases:
      --     - either the stmt was local to a procedure, and we are finalizing
      --       on exit of the procedure. It is thus safe to use the DB.
      --     - or we have a global variable that was only used from a single
      --       connection. Since the application is finalizing, we can use the
      --       session if it is still valid
      --  If there are more than one DB, we have a global variable and the
      --  application is finalizing. Don't do anything on the DBMS, just free
      --  memory.

      if Self.Prepared /= null
        and then Self.Prepared.Next = null
      then
         if Active (Me_Query) then
            Trace
               (Me_Query, "Finalize stmt on server: " & Self.Name.To_String);
         end if;

         if not Query_Cache.Was_Freed (Self.Prepared.DB) then
            Finalize (Self.Prepared.DB, Self.Prepared.Stmt);
         end if;
         Unchecked_Free (Self.Prepared);

      elsif Self.Prepared /= null then
         L := Self.Prepared;
         while L /= null loop
            L2 := L.Next;
            Unchecked_Free (L);
            Count := Count + 1;
            L := L2;
         end loop;

         if Active (Me_Query) then
            Trace (Me_Query, "Finalize stmt on server: " & Self.Name.To_String
                   & " (for" & Count'Img & " connections)");
         end if;
      end if;

      Query_Cache.Unset_Cache (Self);
      Free (Self.Query_Str);
   end Free;

   ----------------------------
   -- Automatic_Transactions --
   ----------------------------

   procedure Automatic_Transactions
     (Connection : access Database_Connection_Record'Class;
      Active     : Boolean := True) is
   begin
      Connection.Automatic_Transactions := Active;
   end Automatic_Transactions;

   ----------------------------
   -- Automatic_Transactions --
   ----------------------------

   function Automatic_Transactions
     (Connection : access Database_Connection_Record'Class) return Boolean
   is
   begin
      return Connection.Automatic_Transactions;
   end Automatic_Transactions;

   -------------------------------------
   -- Is_Prepared_On_Server_Supported --
   -------------------------------------

   function Is_Prepared_On_Server_Supported
     (Connection : access Database_Connection_Record) return Boolean
   is
      pragma Unreferenced (Connection);
   begin
      return True;
   end Is_Prepared_On_Server_Supported;

   ---------------------------
   -- Is_Prepared_On_Server --
   ---------------------------

   function Is_Prepared_On_Server (Stmt : Prepared_Statement) return Boolean is
      use type Prepared_Statements.Element_Access;
      Ref : constant Prepared_Statements.Element_Access := Stmt.Unchecked_Get;
   begin
      return Ref /= null and then Ref.Prepared /= null
        and then Ref.Prepared.Stmt /= No_DBMS_Stmt;
   end Is_Prepared_On_Server;

end GNATCOLL.SQL.Exec;