------------------------------------------------------------------------------
--                             G N A T C O L L                              --
--                                                                          --
--                     Copyright (C) 2005-2018, 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.                            --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- 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/>.                                          --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Calendar;               use Ada.Calendar;
with Ada.Calendar.Formatting;    use Ada.Calendar.Formatting;
with Ada.Strings.Fixed;          use Ada.Strings.Fixed;
with Ada.Strings.Hash;
with Ada.Unchecked_Deallocation;
with GNAT.Strings;               use GNAT.Strings;
with GNATCOLL.Utils;             use GNATCOLL.Utils;

package body GNATCOLL.SQL_Impl is
   use Field_List, Table_Sets, Assignment_Lists, SQL_Criteria_Pointers,
       Field_Pointers;

   Comparison_Equal         : aliased constant String := "=";
   Comparison_Different     : aliased constant String := "<>";
   Comparison_Less          : aliased constant String := "<";
   Comparison_Less_Equal    : aliased constant String := "<=";
   Comparison_Greater       : aliased constant String := ">";
   Comparison_Greater_Equal : aliased constant String := ">=";

   --------------------------
   --  Named field data --
   --------------------------
   --  Instantiation of field_data for specific types of fields, created for
   --  instance via Expression, From_String, or operators on time. Such fields
   --  are still typed

   type Field_Kind is (Field_Std, Field_Operator, Field_Parameter);
   --  The type of the field:
   --     Field_Std: Str_Value is directly the text of the field
   --     Field_Operator:  Str_Value is the operator, that acts on several
   --          fields ("-" for instance")
   --     Field_Parameter: the field's exact value is unknown, and will be
   --          substituted at runtime (for instance "?1" in sqlite3). Str_Value
   --          is then the index of the field.

   type Named_Field_Internal (Typ : Field_Kind)
     is new SQL_Field_Internal with record
      Table     : Table_Names := No_Names;

      case Typ is
         when Field_Std =>
            Str_Value : GNAT.Strings.String_Access;
            --  The expression representing the field in SQL. See Field_Type
            --  for more information

         when Field_Operator =>
            Op_Value : GNAT.Strings.String_Access;
            List     : SQL_Field_List;

         when Field_Parameter =>
            Index      : Positive;
            Param_Type : SQL_Parameter_Base;
      end case;
   end record;
   overriding procedure Free (Self : in out Named_Field_Internal);
   overriding function To_String
     (Self   : Named_Field_Internal;
      Format : Formatter'Class;
      Long   : Boolean) return String;
   overriding procedure Append_Tables
     (Self : Named_Field_Internal; To : in out Table_Sets.Set);
   overriding procedure Append_If_Not_Aggregate
     (Self         : access Named_Field_Internal;
      To           : in out SQL_Field_List'Class;
      Is_Aggregate : in out Boolean);

   procedure Assign
     (R     : out SQL_Assignment;
      Field : SQL_Field'Class;
      Value : Named_Field_Internal'Class);
   procedure Unassign
     (R     : out SQL_Assignment;
      Field : SQL_Field'Class);
   --  Assign Value to Field (or set field to NULL if Value is null).
   --  On exit, Value belongs to R and should not be freed by the caller.

   ---------------------
   -- Function fields --
   ---------------------

   type Function_Field is new SQL_Field_Internal with record
      Prefix, Suffix : GNAT.Strings.String_Access;
      To_Field       : SQL_Field_Pointer;
   end record;
   overriding procedure Free (Self : in out Function_Field);
   overriding function To_String
     (Self   : Function_Field;
      Format : Formatter'Class;
      Long   : Boolean) return String;
   overriding procedure Append_Tables
     (Self : Function_Field; To : in out Table_Sets.Set);
   overriding procedure Append_If_Not_Aggregate
     (Self         : access Function_Field;
      To           : in out SQL_Field_List'Class;
      Is_Aggregate : in out Boolean);
   --  A field that applies a function (via Prefix .. Suffix) to another field

   ----------------------
   -- Function2 fields --
   ----------------------

   type Function2_Field is new SQL_Field_Internal with record
      Prefix, Suffix : GNAT.Strings.String_Access;
      Field1, Field2 : SQL_Field_Pointer;
   end record;
   overriding procedure Free (Self : in out Function2_Field);
   overriding function To_String
     (Self   : Function2_Field;
      Format : Formatter'Class;
      Long   : Boolean) return String;
   overriding procedure Append_Tables
     (Self : Function2_Field; To : in out Table_Sets.Set);
   overriding procedure Append_If_Not_Aggregate
     (Self         : access Function2_Field;
      To           : in out SQL_Field_List'Class;
      Is_Aggregate : in out Boolean);
   --  A field that applies a function (via Prefix .. Suffix) to another field

   --------------
   -- Criteria --
   --------------

   type Comparison_Criteria is new SQL_Criteria_Data with record
      Op, Suffix : Cst_String_Access;
      Arg1, Arg2 : SQL_Field_Pointer;
   end record;
   overriding function To_String
     (Self   : Comparison_Criteria;
      Format : Formatter'Class;
      Long   : Boolean := True) return String;
   overriding procedure Append_Tables
     (Self : Comparison_Criteria; To : in out Table_Sets.Set);
   overriding procedure Append_If_Not_Aggregate
     (Self         : Comparison_Criteria;
      To           : in out SQL_Field_List'Class;
      Is_Aggregate : in out Boolean);

   ----------------
   -- Data_Field --
   ----------------

   package body Data_Fields is
      overriding function To_String
        (Self   : Field;
         Format : Formatter'Class;
         Long   : Boolean := True) return String is
      begin
         if not Self.Data.Is_Null then
            return To_String (Self.Data.Get.Element.all, Format, Long);
         else
            return "";
         end if;
      end To_String;

      overriding procedure Append_Tables
        (Self : Field; To : in out Table_Sets.Set) is
      begin
         if not Self.Data.Is_Null then
            Append_Tables (Self.Data.Get.Element.all, To);
         end if;
      end Append_Tables;

      overriding procedure Append_If_Not_Aggregate
        (Self         : Field;
         To           : in out SQL_Field_List'Class;
         Is_Aggregate : in out Boolean)
      is
         FC : access SQL_Field_Internal'Class;
      begin
         if not Self.Data.Is_Null then
            --  !!! Could not use Element call result in the
            --  Append_If_Not_Aggregate parameter because of GNAT bug OB03-009

            FC := Self.Data.Get.Element;
            Append_If_Not_Aggregate (FC, To, Is_Aggregate);
         end if;
      end Append_If_Not_Aggregate;
   end Data_Fields;

   package Any_Fields is new Data_Fields (SQL_Field);

   -------------------
   -- Instance_Name --
   -------------------

   function Instance_Name (Names : Table_Names) return String is
   begin
      if Names.Instance = null then
         if Names.Instance_Index = -1 then
            if Names.Name = null then
               return "";
            else
               return Names.Name.all;
            end if;
         else
            return Names.Name (Names.Name'First)
              & Image (Names.Instance_Index, Min_Width => 1);
         end if;
      else
         return Names.Instance.all;
      end if;
   end Instance_Name;

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

   function Hash (Self : Table_Names) return Ada.Containers.Hash_Type is
   begin
      return Ada.Strings.Hash (Instance_Name (Self));
   end Hash;

   -------------------
   -- Free_Dispatch --
   -------------------

   procedure Free_Dispatch (Self : in out SQL_Criteria_Data'Class) is
   begin
      Free (Self);
   end Free_Dispatch;

   -------------------
   -- Free_Dispatch --
   -------------------

   procedure Free_Dispatch (Self : in out SQL_Field_Internal'Class) is
   begin
      Free (Self);
   end Free_Dispatch;

   --------------
   -- Is_Empty --
   --------------

   function Is_Empty (List : SQL_Field_List) return Boolean is
   begin
      return List.List.Is_Empty;
   end Is_Empty;

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

   overriding function To_String
     (Self   : SQL_Field_List;
      Format : Formatter'Class;
      Long   : Boolean := True) return String
   is
      C      : Field_List.Cursor := First (Self.List);
      Result : Unbounded_String;
   begin
      if Has_Element (C) then
         Append (Result, To_String (Element (C), Format, Long));
         Next (C);
      end if;

      while Has_Element (C) loop
         Append (Result, ", ");
         Append (Result, To_String (Element (C), Format, Long));
         Next (C);
      end loop;
      return To_String (Result);
   end To_String;

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

   overriding function To_String
     (Self   : SQL_Field;
      Format : Formatter'Class;
      Long   : Boolean := True) return String
   is
      pragma Unreferenced (Format);
   begin
      if not Long then
         return Self.Name.all;
      else
         declare
            N : constant String := Instance_Name
              ((Name           => Self.Table,
                Instance       => Self.Instance,
                Instance_Index => Self.Instance_Index));
         begin
            if N /= "" then
               return N & "." & Self.Name.all;
            else
               --  Self.Table could be null in the case of the Null_Field_*
               --  constants
               return Self.Name.all;
            end if;
         end;
      end if;
   end To_String;

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

   procedure Free (Self : in out Named_Field_Internal) is
   begin
      case Self.Typ is
         when Field_Std       => Free (Self.Str_Value);
         when Field_Operator  => Free (Self.Op_Value);
         when Field_Parameter => null;
      end case;
   end Free;

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

   function To_String
     (Self   : Named_Field_Internal;
      Format : Formatter'Class;
      Long   : Boolean) return String
   is
      Result : Unbounded_String;
      C      : Field_List.Cursor;
   begin
      case Self.Typ is
         when Field_Std =>
            if Self.Table = No_Names then
               return Self.Str_Value.all;

            elsif Long then
               if Self.Table.Instance = null then
                  return Self.Table.Name.all & '.' & Self.Str_Value.all;
               else
                  return Self.Table.Instance.all & '.' & Self.Str_Value.all;
               end if;
            else
               return Self.Str_Value.all;
            end if;

         when Field_Operator =>
            C := First (Self.List.List);
            Result := To_Unbounded_String (To_String (Element (C), Format));
            Next (C);

            while Has_Element (C) loop
               Result := Result & " " & Self.Op_Value.all & " "
                 & To_String (Element (C), Format);
               Next (C);
            end loop;

            return To_String (Result);

         when Field_Parameter =>
            return Self.Param_Type.Get.Type_String (Self.Index, Format);
      end case;
   end To_String;

   -------------------
   -- Append_Tables --
   -------------------

   procedure Append_Tables
     (Self : Named_Field_Internal; To : in out Table_Sets.Set) is
   begin
      if Self.Table /= No_Names then
         Include (To, Self.Table);
      end if;
   end Append_Tables;

   -------------------
   -- Append_Tables --
   -------------------

   overriding procedure Append_Tables
     (Self : Function_Field; To : in out Table_Sets.Set) is
   begin
      Append_Tables (Self.To_Field.Get.Element.all, To);
   end Append_Tables;

   -----------------------------
   -- Append_If_Not_Aggregate --
   -----------------------------

   overriding procedure Append_If_Not_Aggregate
     (Self         : access Function_Field;
      To           : in out SQL_Field_List'Class;
      Is_Aggregate : in out Boolean)
   is
   begin
      Append_If_Not_Aggregate
         (Self.To_Field.Get.Element.all, To, Is_Aggregate);
   end Append_If_Not_Aggregate;

   -------------------
   -- Append_Tables --
   -------------------

   overriding procedure Append_Tables
     (Self : Function2_Field; To : in out Table_Sets.Set) is
   begin
      Append_Tables (Self.Field1.Get.Element.all, To);
      Append_Tables (Self.Field2.Get.Element.all, To);
   end Append_Tables;

   -----------------------------
   -- Append_If_Not_Aggregate --
   -----------------------------

   overriding procedure Append_If_Not_Aggregate
     (Self         : access Function2_Field;
      To           : in out SQL_Field_List'Class;
      Is_Aggregate : in out Boolean)
   is
   begin
      Append_If_Not_Aggregate
         (Self.Field1.Get.Element.all, To, Is_Aggregate);
      Append_If_Not_Aggregate
         (Self.Field2.Get.Element.all, To, Is_Aggregate);
   end Append_If_Not_Aggregate;

   -----------------------------
   -- Append_If_Not_Aggregate --
   -----------------------------

   procedure Append_If_Not_Aggregate
     (Self         : access Named_Field_Internal;
      To           : in out SQL_Field_List'Class;
      Is_Aggregate : in out Boolean)
   is
      C : Field_List.Cursor;
      F : Field_Pointers.Ref;
   begin
      if Self.Typ = Field_Operator then
         C := First (Self.List.List);
         while Has_Element (C) loop
            Append_If_Not_Aggregate (Element (C), To, Is_Aggregate);
            Next (C);
         end loop;
      end if;

      --  We create a SQL_Field_Text, but it might be any other type.
      --  This isn't really relevant, however, since the exact type is not used
      --  later on.

      if Self.Table /= No_Names then
         F.From_Element (Field_Pointers.Element_Access (Self));

         Append
           (To.List, Any_Fields.Field'
              (Table    => Self.Table.Name,
               Instance => Self.Table.Instance,
               Instance_Index => Self.Table.Instance_Index,
               Name     => null,
               Data     => F));
      end if;
   end Append_If_Not_Aggregate;

   ------------
   -- Append --
   ------------

   procedure Append
     (List : in out SQL_Field_List; Field : SQL_Field'Class) is
   begin
      Append (List.List, Field);
   end Append;

   ---------
   -- "&" --
   ---------

   function "&" (Left, Right : SQL_Field'Class) return SQL_Field_List is
      Result : SQL_Field_List;
   begin
      Append (Result.List, Left);
      Append (Result.List, Right);
      return Result;
   end "&";

   ---------
   -- "&" --
   ---------

   function "&"
     (Left : SQL_Field_List; Right : SQL_Field'Class) return SQL_Field_List
   is
      Result : SQL_Field_List;
   begin
      Result.List := Left.List;  --  Does a copy, so we do not modify Left
      Append (Result.List, Right);
      return Result;
   end "&";

   ---------
   -- "&" --
   ---------

   function "&"
     (Left : SQL_Field'Class; Right : SQL_Field_List) return SQL_Field_List
   is
      Result : SQL_Field_List;
   begin
      Result.List := Right.List; --  Does a copy so that we do not modify Right
      Prepend (Result.List, Left);
      return Result;
   end "&";

   ---------
   -- "&" --
   ---------

   function "&"
     (Left, Right : SQL_Field_List) return SQL_Field_List
   is
      Result : SQL_Field_List;
      C      : Field_List.Cursor := First (Right.List);
   begin
      Result.List := Left.List; --  Does a copy, don't modify Left
      while Has_Element (C) loop
         Append (Result.List, Element (C));
         Next (C);
      end loop;
      return Result;
   end "&";

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

   function "+" (Left : SQL_Field'Class) return SQL_Field_List is
      Result : SQL_Field_List;
   begin
      Append (Result.List, Left);
      return Result;
   end "+";

   -------------------
   -- Append_Tables --
   -------------------

   procedure Append_Tables (Self : SQL_Field; To : in out Table_Sets.Set) is
   begin
      if Self.Table /= null then
         Include (To, (Name => Self.Table, Instance => Self.Instance,
                       Instance_Index => Self.Instance_Index));
      end if;
   end Append_Tables;

   -----------------------------
   -- Append_If_Not_Aggregate --
   -----------------------------

   procedure Append_If_Not_Aggregate
     (Self         : SQL_Field;
      To           : in out SQL_Field_List'Class;
      Is_Aggregate : in out Boolean)
   is
      pragma Unreferenced (Is_Aggregate);
   begin
      --  Ignore constant fields (NULL,...)
      if Self.Table /= null then
         --  Check that field already exists in list
         for F of To.List loop
            if SQL_Field (F) = Self then
               --  Do not need the same field twice
               return;
            end if;
         end loop;

         Append (To.List, Self);
      end if;
   end Append_If_Not_Aggregate;

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

   function To_String
     (Self   : SQL_Criteria;
      Format : Formatter'Class;
      Long   : Boolean := True) return String
   is
   begin
      if not Self.Criteria.Is_Null then
         return To_String (Self.Criteria.Get.Element.all, Format, Long);
      else
         return "";
      end if;
   end To_String;

   -------------------
   -- Append_Tables --
   -------------------

   procedure Append_Tables (Self : SQL_Criteria; To : in out Table_Sets.Set) is
   begin
      if not Self.Criteria.Is_Null then
         Append_Tables (Self.Criteria.Get.Element.all, To);
      end if;
   end Append_Tables;

   -----------------------------
   -- Append_If_Not_Aggregate --
   -----------------------------

   procedure Append_If_Not_Aggregate
     (Self         : SQL_Criteria;
      To           : in out SQL_Field_List'Class;
      Is_Aggregate : in out Boolean) is
   begin
      if not Self.Criteria.Is_Null then
         Append_If_Not_Aggregate
            (Self.Criteria.Get.Element.all, To, Is_Aggregate);
      end if;
   end Append_If_Not_Aggregate;

   --------------
   -- Set_Data --
   --------------

   procedure Set_Data
     (Self : in out SQL_Criteria; Data : SQL_Criteria_Data'Class) is
   begin
      Self.Criteria.Set (Data);
   end Set_Data;

   --------------
   -- Get_Data --
   --------------

   function Get_Data (Self : SQL_Criteria) return SQL_Criteria_Data_Access is
   begin
      return Self.Criteria.Unchecked_Get;
   end Get_Data;

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

   function "+" (Field : SQL_Field'Class) return SQL_Field_Pointer is
   begin
      return R : SQL_Field_Pointer do
         R.Set (Field);
      end return;
   end "+";

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

   overriding function To_String
     (Self   : Comparison_Criteria;
      Format : Formatter'Class;
      Long   : Boolean := True) return String
   is
      Arg2 : constant String := To_String (Self.Arg2, Format, Long => Long);
   begin
      --  ??? Could we do this test when we create the comparison, that would
      --  be more efficient.
      if Self.Op.all = "="
        and then Arg2 = "TRUE"
      then
         return To_String (Self.Arg1, Format, Long => Long);

      elsif Self.Op.all = "="
        and then Arg2 = "FALSE"
      then
         return "not " & To_String (Self.Arg1, Format, Long => Long);

      elsif Self.Suffix /= null then
         if Self.Arg1 = No_Field_Pointer then
            return Self.Op.all & Arg2 & Self.Suffix.all;
         else
            return To_String (Self.Arg1, Format, Long => Long)
               & Self.Op.all & Arg2 & Self.Suffix.all;
         end if;

      else
         if Self.Arg1 = No_Field_Pointer then
            return Self.Op.all & Arg2;
         else
            return To_String (Self.Arg1, Format, Long => Long)
               & Self.Op.all & Arg2;
         end if;
      end if;
   end To_String;

   -------------------
   -- Append_Tables --
   -------------------

   overriding procedure Append_Tables
     (Self : Comparison_Criteria; To : in out Table_Sets.Set) is
   begin
      Append_Tables (Self.Arg1, To);
      Append_Tables (Self.Arg2, To);
   end Append_Tables;

   -----------------------------
   -- Append_If_Not_Aggregate --
   -----------------------------

   overriding procedure Append_If_Not_Aggregate
     (Self         : Comparison_Criteria;
      To           : in out SQL_Field_List'Class;
      Is_Aggregate : in out Boolean) is
   begin
      Append_If_Not_Aggregate (Self.Arg1, To, Is_Aggregate);
      Append_If_Not_Aggregate (Self.Arg2, To, Is_Aggregate);
   end Append_If_Not_Aggregate;

   -------------
   -- Compare --
   -------------

   function Compare
     (Left, Right : SQL_Field'Class;
      Op          : Cst_String_Access;
      Suffix      : Cst_String_Access := null) return SQL_Criteria
   is
      Data : constant Comparison_Criteria :=
         (SQL_Criteria_Data with
          Op => Op, Suffix => Suffix, Arg1 => +Left, Arg2 => +Right);
      Result : SQL_Criteria;
   begin
      Set_Data (Result, Data);
      return Result;
   end Compare;

   --------------
   -- Compare1 --
   --------------

   function Compare1
     (Field       : SQL_Field'Class;
      Op          : Cst_String_Access;
      Suffix      : Cst_String_Access := null) return SQL_Criteria
   is
      Data : constant Comparison_Criteria :=
         (SQL_Criteria_Data with
          Op => Op, Suffix => Suffix,
          Arg1 => No_Field_Pointer,
          Arg2 => +Field);
      Result : SQL_Criteria;
   begin
      Set_Data (Result, Data);
      return Result;
   end Compare1;

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

   function To_String
     (Self   : SQL_Field_Pointer;
      Format : Formatter'Class;
      Long   : Boolean) return String is
   begin
      return To_String (Self.Get.Element.all, Format, Long);
   end To_String;

   -------------------
   -- Append_Tables --
   -------------------

   procedure Append_Tables
     (Self : SQL_Field_Pointer; To : in out Table_Sets.Set) is
   begin
      if not Self.Is_Null then
         Append_Tables (Self.Get.Element.all, To);
      end if;
   end Append_Tables;

   -----------------------------
   -- Append_If_Not_Aggregate --
   -----------------------------

   procedure Append_If_Not_Aggregate
     (Self         : SQL_Field_Pointer;
      To           : in out SQL_Field_List'Class;
      Is_Aggregate : in out Boolean) is
   begin
      if not Self.Is_Null then
         Append_If_Not_Aggregate (Self.Get.Element.all, To, Is_Aggregate);
      end if;
   end Append_If_Not_Aggregate;

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

   function First (List : SQL_Field_List) return Field_List.Cursor is
   begin
      return First (List.List);
   end First;

   ------------
   -- Append --
   ------------

   procedure Append
     (List : in out SQL_Field_List'Class; Field : SQL_Field_Pointer) is
   begin
      if not Field.Is_Null then
         Append (List.List, Field.Get.Element.all);
      end if;
   end Append;

   -------------------
   -- Append_Tables --
   -------------------

   procedure Append_Tables
     (Self : SQL_Assignment; To : in out Table_Sets.Set)
   is
      C : Assignment_Lists.Cursor := First (Self.List);
   begin
      while Has_Element (C) loop
         Append_Tables (Element (C).Field, To);
         Append_Tables (Element (C).To_Field, To);
         Next (C);
      end loop;
   end Append_Tables;

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

   function To_String
     (Self       : SQL_Assignment;
      Format     : Formatter'Class;
      With_Field : Boolean) return String
   is
      Result : Unbounded_String;
      C      : Assignment_Lists.Cursor := First (Self.List);
      Data   : Assignment_Item;
   begin
      while Has_Element (C) loop
         Data := Element (C);
         if Result /= Null_Unbounded_String then
            Append (Result, ", ");
         end if;

         if Data.To_Field /= No_Field_Pointer then
            if With_Field then
               Append
                 (Result, To_String (Data.Field, Format, Long => False)
                  & "=" & To_String (Data.To_Field, Format, Long => True));
            else
               Append
                 (Result, To_String (Data.To_Field, Format, Long => True));
            end if;

         elsif With_Field then
            Append
              (Result, To_String (Data.Field, Format, Long => False)
               & "=" & Null_String);
         else
            Append (Result, Null_String);
         end if;

         Next (C);
      end loop;
      return To_String (Result);
   end To_String;

   -------------
   -- To_List --
   -------------

   procedure To_List (Self : SQL_Assignment; List : out SQL_Field_List) is
      N    : Field_Pointers.Ref;
      C    : Assignment_Lists.Cursor := First (Self.List);
      Data : Assignment_Item;
   begin
      while Has_Element (C) loop
         Data := Element (C);

         if Data.To_Field /= No_Field_Pointer then
            Append (List, Data.To_Field);

         else
            --  Setting a field to null
            N.Set
              (Named_Field_Internal'
                 (SQL_Field_Internal with Typ => Field_Std, others => <>));
            Named_Field_Internal (N.Get.Element.all).Str_Value :=
              new String'(Null_String);

            List := List
              & Any_Fields.Field'
                  (Table          => null,
                   Instance       => null,
                   Instance_Index => -1,
                   Name           => null,
                   Data           => N);
         end if;

         Next (C);
      end loop;
   end To_List;

   ----------------
   -- Get_Fields --
   ----------------

   procedure Get_Fields (Self : SQL_Assignment; List : out SQL_Field_List) is
      C    : Assignment_Lists.Cursor := First (Self.List);
   begin
      while Has_Element (C) loop
         Append (List, Element (C).Field);
         Next (C);
      end loop;
   end Get_Fields;

   ---------
   -- "&" --
   ---------

   function "&" (Left, Right : SQL_Assignment) return SQL_Assignment is
      Result : SQL_Assignment;
      C      : Assignment_Lists.Cursor := First (Right.List);
   begin
      Result.List := Left.List;
      while Has_Element (C) loop
         Append (Result.List, Element (C));
         Next (C);
      end loop;
      return Result;
   end "&";

   --------------
   -- Unassign --
   --------------

   procedure Unassign
     (R     : out SQL_Assignment;
      Field : SQL_Field'Class)
   is
   begin
      Append (R.List, Assignment_Item'(+Field, No_Field_Pointer));
   end Unassign;

   ------------
   -- Assign --
   ------------

   procedure Assign
     (R     : out SQL_Assignment;
      Field : SQL_Field'Class;
      Value : Named_Field_Internal'Class)
   is

      function To_Ref return Field_Pointers.Ref;

      ------------
      -- To_Ref --
      ------------

      function To_Ref return Field_Pointers.Ref is
         Result : Field_Pointers.Ref;
      begin
         Result.Set (Value);
         return Result;
      end To_Ref;

   begin
      declare
         A : constant Assignment_Item :=
           (Field    => +Field,
            To_Field => +Any_Fields.Field'
              (Table    => null,
               Instance => null,
               Instance_Index => -1,
               Name     => null,
               Data     => To_Ref));
      begin
         Append (R.List, A);
      end;
   end Assign;

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

   overriding procedure Free (Self : in out Function_Field) is
   begin
      Free (Self.Prefix);
      Free (Self.Suffix);
      Free (SQL_Field_Internal (Self));
   end Free;

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

   overriding procedure Free (Self : in out Function2_Field) is
   begin
      Free (Self.Prefix);
      Free (Self.Suffix);
      Free (SQL_Field_Internal (Self));
   end Free;

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

   overriding function To_String
     (Self   : Function_Field;
      Format : Formatter'Class;
      Long   : Boolean) return String
   is
      pragma Unreferenced (Long);
   begin
      return Self.Prefix.all
        & To_String (Self.To_Field.Get.Element.all, Format, Long => True)
        & Self.Suffix.all;
   end To_String;

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

   overriding function To_String
     (Self   : Function2_Field;
      Format : Formatter'Class;
      Long   : Boolean) return String
   is
      pragma Unreferenced (Long);
   begin
      return Self.Prefix.all
        & To_String (Self.Field1.Get.Element.all, Format, Long => True)
        & ", "
        & To_String (Self.Field2.Get.Element.all, Format, Long => True)
        & Self.Suffix.all;
   end To_String;

   -----------------
   -- Field_Types --
   -----------------

   package body Field_Types is

      type Ada_Type_Access is access Ada_Type;

      package Typed_Data_Fields is new Data_Fields (Field);
      type Typed_Named_Field_Internal is new Named_Field_Internal with record
         Data_Value : Ada_Type_Access;
      end record;

      overriding procedure Free (Self : in out Typed_Named_Field_Internal);
      overriding function To_String
        (Self   : Typed_Named_Field_Internal;
         Format : Formatter'Class;
         Long   : Boolean) return String;

      procedure Unchecked_Free is new Ada.Unchecked_Deallocation
        (Ada_Type, Ada_Type_Access);

      function Internal_From_Data
        (Data : SQL_Field_Internal'Class) return Field'Class;
      pragma Inline (Internal_From_Data);

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

      overriding procedure Free (Self : in out Typed_Named_Field_Internal) is
      begin
         Unchecked_Free (Self.Data_Value);
         Free (Named_Field_Internal (Self));
      end Free;

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

      overriding function To_String
        (Self   : Typed_Named_Field_Internal;
         Format : Formatter'Class;
         Long   : Boolean) return String is
      begin
         if Self.Data_Value /= null then
            declare
               --  Do not check that Data_Value is valid, it could also
               --  be Nan or Inf when using float
               pragma Validity_Checks (Off);
            begin
               return To_SQL (Format, Self.Data_Value.all, Quote => True);
            end;
         end if;

         return To_String (Named_Field_Internal (Self), Format, Long);
      end To_String;

      ----------------
      -- From_Table --
      ----------------

      function From_Table
        (Self  : Field;
         Table : SQL_Single_Table'Class) return Field'Class
      is
         F : Typed_Data_Fields.Field
           (Table => null, Instance => Table.Instance,
            Instance_Index => Table.Instance_Index, Name => Self.Name);
         D : Named_Field_Internal (Typ => Field_Std);
      begin
         D.Table := (Name => null, Instance => Table.Instance,
                     Instance_Index => Table.Instance_Index);
         D.Str_Value := new String'(Self.Name.all);
         F.Data.Set (D);
         return Field (F);
      end From_Table;

      ------------------------
      -- Internal_From_Data --
      ------------------------

      function Internal_From_Data
        (Data : SQL_Field_Internal'Class) return Field'Class
      is
         F : Field_Pointers.Ref;
      begin
         F.Set (Data);

         return Typed_Data_Fields.Field'
           (Table => null, Instance => null, Name => null,
            Instance_Index => -1,
            Data => F);
      end Internal_From_Data;

      ----------------
      -- Expression --
      ----------------

      function Expression (Value : Ada_Type) return Field'Class is
         Data : Typed_Named_Field_Internal (Field_Std);
      begin
         Data.Data_Value := new Ada_Type'(Value);
         return Internal_From_Data (Data);
      end Expression;

      -----------------
      -- From_String --
      -----------------

      function From_String (SQL : String) return Field'Class is
         Data : Named_Field_Internal (Field_Std);
      begin
         Data.Str_Value := new String'(SQL);
         return Internal_From_Data (Data);
      end From_String;

      -----------
      -- Param --
      -----------

      function Param (Index : Positive) return Field'Class is
         Data : Named_Field_Internal (Field_Parameter);
         P    : Param_Type;
      begin
         Data.Index := Index;
         Data.Param_Type.Set (P);
         return Internal_From_Data (Data);
      end Param;

      ---------
      -- "&" --
      ---------

      function "&"
        (Field : SQL_Field'Class; Value : Ada_Type) return SQL_Field_List is
      begin
         return Field & Expression (Value);
      end "&";

      function "&"
        (Value : Ada_Type; Field : SQL_Field'Class) return SQL_Field_List is
      begin
         return Expression (Value) & Field;
      end "&";

      function "&"
        (List : SQL_Field_List; Value : Ada_Type) return SQL_Field_List is
      begin
         return List & Expression (Value);
      end "&";

      function "&"
        (Value : Ada_Type; List : SQL_Field_List) return SQL_Field_List is
      begin
         return Expression (Value) & List;
      end "&";

      --------------
      -- Operator --
      --------------

      function Operator
        (Field1, Field2 : SQL_Field'Class) return Field'Class
      is
         F : Typed_Data_Fields.Field
           (Table => null, Instance => null,
            Instance_Index => -1, Name => null);
         D : Named_Field_Internal (Typ => Field_Operator);
      begin
         D.Op_Value := new String'(Name);
         D.List := Field1 & Field2;
         F.Data.Set (D);
         return F;
      end Operator;

      ---------------------
      -- String_Operator --
      ---------------------

      function String_Operator
        (Self : SQL_Field'Class; Operand : String) return Field'Class
      is
         F : Typed_Data_Fields.Field
           (Table => null, Instance => null, Name => null,
            Instance_Index => -1);
         D : Named_Field_Internal (Typ => Field_Operator);

         F2 : Typed_Data_Fields.Field
           (Table => null, Instance => null, Name => null,
            Instance_Index => -1);
         D2 : Named_Field_Internal (Typ => Field_Std);

      begin
         D2.Str_Value := new String'(Prefix & Operand & Suffix);
         F2.Data.Set (D2);

         D.Op_Value := new String'(Name);
         D.List := Self & F2;
         F.Data.Set (D);
         return F;
      end String_Operator;

      ---------------------
      -- Scalar_Operator --
      ---------------------

      function Scalar_Operator
        (Self : SQL_Field'Class; Operand : Scalar) return Field'Class
      is
         function Operator is new String_Operator (Name, Prefix, Suffix);
      begin
         return Operator (Self, Scalar'Image (Operand));
      end Scalar_Operator;

      ------------------
      -- SQL_Function --
      ------------------

      function SQL_Function return Field'Class is
         F : Typed_Data_Fields.Field
           (Table => null, Instance => null, Name => null,
            Instance_Index => -1);
         D : Named_Field_Internal (Typ => Field_Std);
      begin
         D.Str_Value := new String'(Name);
         F.Data.Set (D);
         return F;
      end SQL_Function;

      --------------------
      -- Apply_Function --
      --------------------

      function Apply_Function
        (Self : Argument_Type'Class) return Field'Class
      is
         F : Typed_Data_Fields.Field
           (Table => null, Instance => null, Name => null,
            Instance_Index => -1);
         D : Function_Field;
      begin
         if Suffix /= ")" and then Suffix /= "" then
            D.Suffix := new String'(" " & Suffix);
         else
            D.Suffix := new String'(Suffix);
         end if;

         D.Prefix := new String'(Name);
         D.To_Field := +Self;
         F.Data.Set (D);
         return F;
      end Apply_Function;

      -------------------
      -- Cast_Implicit --
      -------------------

      function Cast_Implicit (Self : SQL_Field'Class) return Field'Class is
         F : Typed_Data_Fields.Field
           (Table => null, Instance => null, Name => null,
            Instance_Index => -1);
         D : Function_Field;
      begin
         D.Suffix := new String'("");
         D.Prefix := new String'("");
         D.To_Field := +Self;
         F.Data.Set (D);
         return F;
      end Cast_Implicit;

      ---------------------
      -- Apply_Function2 --
      ---------------------

      function Apply_Function2
        (Arg1 : Argument1_Type'Class;
         Arg2 : Argument2_Type'Class) return Field'Class
      is
         F : Typed_Data_Fields.Field
           (Table => null, Instance => null, Name => null,
            Instance_Index => -1);
         D : Function2_Field;
      begin
         if Suffix /= ")" and then Suffix /= "" then
            D.Suffix := new String'(" " & Suffix);
         else
            D.Suffix := new String'(Suffix);
         end if;

         D.Prefix := new String'(Name);
         D.Field1 := +Arg1;
         D.Field2 := +Arg2;
         F.Data.Set (D);
         return F;
      end Apply_Function2;

      ------------
      -- Nullif --
      ------------

      function Nullif (Left, Right : SQL_Field'Class) return Field'Class is
         function Internal is new Apply_Function2
           (SQL_Field, SQL_Field, "NULLIF (");
      begin
         return Internal (Left, Right);
      end Nullif;

      ---------------
      -- Operators --
      ---------------

      function "=" (Left : Field; Right : Field'Class) return SQL_Criteria is
      begin
         return Compare (Left, Right, Comparison_Equal'Access);
      end "=";

      function "/=" (Left : Field; Right : Field'Class) return SQL_Criteria is
      begin
         return Compare (Left, Right, Comparison_Different'Access);
      end "/=";

      function "<" (Left : Field; Right : Field'Class) return SQL_Criteria is
      begin
         return Compare (Left, Right, Comparison_Less'Access);
      end "<";

      function "<=" (Left : Field; Right : Field'Class) return SQL_Criteria is
      begin
         return Compare (Left, Right, Comparison_Less_Equal'Access);
      end "<=";

      function ">" (Left : Field; Right : Field'Class) return SQL_Criteria is
      begin
         return Compare (Left, Right, Comparison_Greater'Access);
      end ">";

      function ">=" (Left : Field; Right : Field'Class) return SQL_Criteria is
      begin
         return Compare (Left, Right, Comparison_Greater_Equal'Access);
      end ">=";

      function "=" (Left : Field; Right : Ada_Type) return SQL_Criteria
      is
      begin
         return Compare (Left, Expression (Right), Comparison_Equal'Access);
      end "=";

      function "/=" (Left : Field; Right : Ada_Type) return SQL_Criteria
      is
      begin
         return Compare
           (Left, Expression (Right), Comparison_Different'Access);
      end "/=";

      function "<" (Left : Field; Right : Ada_Type) return SQL_Criteria is
      begin
         return Compare (Left, Expression (Right), Comparison_Less'Access);
      end "<";

      function "<=" (Left : Field; Right : Ada_Type) return SQL_Criteria
      is
      begin
         return Compare
           (Left, Expression (Right), Comparison_Less_Equal'Access);
      end "<=";

      function ">" (Left : Field; Right : Ada_Type) return SQL_Criteria is
      begin
         return Compare
           (Left, Expression (Right), Comparison_Greater'Access);
      end ">";

      function ">=" (Left : Field; Right : Ada_Type) return SQL_Criteria is
      begin
         return Compare
           (Left, Expression (Right), Comparison_Greater_Equal'Access);
      end ">=";

      function Greater_Than
        (Left : SQL_Field'Class; Right : Field) return SQL_Criteria
      is
      begin
         return Compare (Left, Right, Comparison_Greater'Access);
      end Greater_Than;

      function Greater_Or_Equal
        (Left : SQL_Field'Class; Right : Field) return SQL_Criteria
      is
      begin
         return Compare (Left, Right, Comparison_Greater_Equal'Access);
      end Greater_Or_Equal;

      function Equal
        (Left : SQL_Field'Class; Right : Field) return SQL_Criteria
      is
      begin
         return Compare (Left, Right, Comparison_Equal'Access);
      end Equal;

      function Less_Than
        (Left : SQL_Field'Class; Right : Field) return SQL_Criteria
      is
      begin
         return Compare (Left, Right, Comparison_Less'Access);
      end Less_Than;

      function Less_Or_Equal
        (Left : SQL_Field'Class; Right : Field) return SQL_Criteria
      is
      begin
         return Compare (Left, Right, Comparison_Less_Equal'Access);
      end Less_Or_Equal;

      function Greater_Than
        (Left : SQL_Field'Class; Right : Ada_Type) return SQL_Criteria is
      begin
         return Compare
           (Left, Expression (Right), Comparison_Greater'Access);
      end Greater_Than;

      function Greater_Or_Equal
        (Left : SQL_Field'Class; Right : Ada_Type) return SQL_Criteria is
      begin
         return Compare
           (Left, Expression (Right), Comparison_Greater_Equal'Access);
      end Greater_Or_Equal;

      function Equal
        (Left : SQL_Field'Class; Right : Ada_Type) return SQL_Criteria is
      begin
         return Compare (Left, Expression (Right), Comparison_Equal'Access);
      end Equal;

      function Less_Than
        (Left : SQL_Field'Class; Right : Ada_Type) return SQL_Criteria is
      begin
         return Compare
           (Left, Expression (Right), Comparison_Less'Access);
      end Less_Than;

      function Less_Or_Equal
        (Left : SQL_Field'Class; Right : Ada_Type) return SQL_Criteria is
      begin
         return Compare
           (Left, Expression (Right), Comparison_Less_Equal'Access);
      end Less_Or_Equal;

      function "=" (Self : Field; Value : Ada_Type) return SQL_Assignment is
         --  Do not check that Value is valid. It could also be Nan or Inf
         --  when using float
         pragma Validity_Checks (Off);
         Result : SQL_Assignment;
         F   : Typed_Named_Field_Internal (Field_Std);
      begin
         F.Data_Value := new Ada_Type'(Value);
         Assign (Result, Self, F);
         return Result;
      end "=";

      ---------
      -- "=" --
      ---------

      function "=" (Self : Field; To : Field'Class) return SQL_Assignment is
         Result : SQL_Assignment;
      begin
         --  Special case when assigning to one of the Null_Field constants

         if To.Table = null
           and then To.Instance = null
           and then To.Name = Null_String'Access
         then
            Unassign (Result, Self);

         else
            Append (Result.List, Assignment_Item'(+Self, +To));
         end if;

         return Result;
      end "=";

   end Field_Types;

   -------------------
   -- Boolean_Image --
   -------------------

   function Boolean_Image (Self : Formatter; Value : Boolean) return String is
      pragma Unreferenced (Self);
   begin
      return Boolean'Image (Value);
   end Boolean_Image;

   --------------------
   -- Boolean_To_SQL --
   --------------------

   function Boolean_To_SQL
     (Self  : Formatter'Class;
      Value : Boolean;
      Quote : Boolean) return String
   is
      pragma Unreferenced (Quote);
   begin
      return Boolean_Image (Self, Value);
   end Boolean_To_SQL;

   ----------------------
   -- Any_Float_To_SQL --
   ----------------------

   function Any_Float_To_SQL
     (Self  : Formatter'Class;
      Value : Base_Type;
      Quote : Boolean) return String
   is
      pragma Unreferenced (Self, Quote);
   begin
      --  Nan ?
      if Value /= Value then
         return "'Nan'";

      --  -Inf ?
      elsif Value < Base_Type'First then
         return "'-Infinity'";
      elsif Value > Base_Type'Last then
         return "'Infinity'";
      end if;

      declare
         Img : constant String := Base_Type'Image (Value);
      begin
         if Img (Img'First) = ' ' then
            return Img (Img'First + 1 .. Img'Last);
         else
            return Img;
         end if;
      end;
   end Any_Float_To_SQL;

   --------------------
   -- Integer_To_SQL --
   --------------------

   function Integer_To_SQL
     (Self  : Formatter'Class;
      Value : Integer;
      Quote : Boolean) return String
   is
      pragma Unreferenced (Self, Quote);
      Img : constant String := Integer'Image (Value);
   begin
      if Img (Img'First) = ' ' then
         return Img (Img'First + 1 .. Img'Last);
      else
         return Img;
      end if;
   end Integer_To_SQL;

   -------------------
   -- Bigint_To_SQL --
   -------------------

   function Bigint_To_SQL
     (Self  : Formatter'Class;
      Value : Long_Long_Integer;
      Quote : Boolean) return String
   is
      pragma Unreferenced (Self, Quote);
      Img : constant String := Long_Long_Integer'Image (Value);
   begin
      if Img (Img'First) = ' ' then
         return Img (Img'First + 1 .. Img'Last);
      else
         return Img;
      end if;
   end Bigint_To_SQL;

   -----------------------
   -- Supports_Timezone --
   -----------------------

   function Supports_Timezone (Self : Formatter) return Boolean is
      pragma Unreferenced (Self);
   begin
      return True;
   end Supports_Timezone;

   -----------------
   -- Time_To_SQL --
   -----------------

   function Time_To_SQL
     (Self  : Formatter'Class;
      Value : Ada.Calendar.Time;
      Quote : Boolean) return String
   is
   begin
      --  Value is always rendered as GMT, using Ada.Calendar.Formatting

      if Value /= No_Time then
         declare
            Value_Str : constant String := Image (Value, Time_Zone => 0)
              & (if Supports_Timezone (Self) then " +00:00" else "");
         begin
            return (if Quote then ''' & Value_Str & ''' else Value_Str);
         end;
      else
         return "NULL";
      end if;
   end Time_To_SQL;

   -----------------
   -- Date_To_SQL --
   -----------------

   function Date_To_SQL
     (Self  : Formatter'Class;
      Value : Ada.Calendar.Time;
      Quote : Boolean) return String
   is
      pragma Unreferenced (Self);
   begin
      if Value /= No_Time then
         declare
            Value_Str : constant String := Image (Value, Time_Zone => 0);
            Date_Str  : String
              renames Value_Str (Value_Str'First .. Value_Str'First + 9);
         begin
            return (if Quote then ''' & Date_Str & ''' else Date_Str);
         end;
      else
         return "NULL";
      end if;
   end Date_To_SQL;

   -------------------
   -- Decimal_To_SQL --
   -------------------

   function Money_To_SQL
     (Self  : Formatter'Class;
      Value : T_Money;
      Quote : Boolean) return String
   is
      pragma Unreferenced (Quote);
   begin
      return Self.Money_Image (Value);
   end Money_To_SQL;

   -----------------
   -- Money_Image --
   -----------------

   function Money_Image (Self  : Formatter; Value : T_Money) return String is
      pragma Unreferenced (Self);
      Img : constant String := T_Money'Image (Value);
   begin
      if Img (Img'First) = ' ' then
         return Img (Img'First + 1 .. Img'Last);
      else
         return Img;
      end if;
   end Money_Image;

   -------------------
   -- String_To_SQL --
   -------------------

   function String_To_SQL
     (Self : Formatter'Class; Value : String; Quote : Boolean) return String
   is
   begin
      return String_Image (Self, Value, Quote);
   end String_To_SQL;

   ------------------
   -- String_Image --
   ------------------

   function String_Image
     (Self  : Formatter;
      Value : String;
      Quote : Boolean) return String
   is
      --  This function used to quote the backslashes as well. However, this
      --  is incorrect, since the SQL backends will already take each
      --  character on its own. For instance, to insert a newline with psql
      --  we need to
      --          SELECT 'a\n' || chr(13) || 'e';
      --  This outputs a string with 5 characters.
      --  Same with sqlite.

      pragma Unreferenced (Self);
      Num_Of_Apostrophes : constant Natural :=
        Ada.Strings.Fixed.Count (Value, "'");
   begin
      if not Quote then
         return Value;
      end if;

      if Num_Of_Apostrophes = 0 then
         return "'" & Value & "'";
      end if;

      declare
         New_Str            : String
           (Value'First ..  Value'Last + Num_Of_Apostrophes + 2);
         Index : Natural := New_Str'First + 1;
      begin
         New_Str (New_Str'First) := ''';
         New_Str (New_Str'Last) := ''';

         for I in Value'Range loop
            if Value (I) = ''' then
               New_Str (Index .. Index + 1) := "''";
               Index := Index + 1;
            else
               New_Str (Index) := Value (I);
            end if;
            Index := Index + 1;
         end loop;

         return New_Str;
      end;
   end String_Image;

   ------------
   -- Create --
   ------------

   function Create (F1, F2 : SQL_Field'Class) return SQL_Assignment is
      R : SQL_Assignment;
      It : Assignment_Item;
   begin
      It.Field.Set (F1);
      It.To_Field.Set (F2);
      R.List.Append (It);
      return R;
   end Create;

   -------------------
   -- Free_Dispatch --
   -------------------

   procedure Free_Dispatch (Self : in out SQL_Parameter_Type'Class) is
   begin
      Self.Free;
   end Free_Dispatch;

   ----------------------
   -- Parameter_String --
   ----------------------

   function Parameter_String
     (Self       : Formatter;
      Index      : Positive;
      Type_Descr : String) return String
   is
      pragma Unreferenced (Self, Index, Type_Descr);
   begin
      return "?";
   end Parameter_String;

   --------------------
   -- Internal_Image --
   --------------------

   function Internal_Image
     (Self   : SQL_Parameter_Type;
      Format : Formatter'Class) return String
   is
      pragma Unreferenced (Self, Format);
   begin
      return "<none>";
   end Internal_Image;

   --------------------
   -- Internal_Image --
   --------------------

   overriding function Internal_Image
     (Self   : SQL_Parameter_Text;
      Format : Formatter'Class) return String
   is
      pragma Unreferenced (Format);
   begin
      return To_String (Self);
   end Internal_Image;

   --------------------
   -- Internal_Image --
   --------------------

   overriding function Internal_Image
      (Self   : SQL_Parameter_Character;
       Format : Formatter'Class) return String
   is
      pragma Unreferenced (Format);
   begin
      return String'(1 .. 1 => Self.Char_Val);
   end Internal_Image;

end GNATCOLL.SQL_Impl;