ada/gnatcoll-db
0
0
Fork 0
mirror of https://github.com/AdaCore/gnatcoll-db.git synced 2026-02-12 12:59:31 -08:00
Code Issues Packages Projects Releases Wiki Activity
Files
21-sustained
gnatcoll-db/sql/gnatcoll-sql.adb
Fedor Rybin 5451547525 Make GNATCOLL.SQL Ada 2020 compatible 
Qualify the aggregate to fix compilation error in 2020 mode.

for U121-029

Change-Id: I57c0696eb01ca2ab32106c6760099a402e41910d
(cherry picked from commit 33b963c5e4)
2021-05-20 10:25:55 +02:00

2884 lines
78 KiB
Ada
Raw Permalink Blame History

------------------------------------------------------------------------------
-- G N A T C O L L --
-- --
-- Copyright (C) 2005-2021, 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/>. --
-- --
------------------------------------------------------------------------------
with Ada.Calendar; use Ada.Calendar;
with Ada.Containers; use Ada.Containers;
with Ada.Unchecked_Deallocation;
with GNAT.Strings; use GNAT.Strings;
package body GNATCOLL.SQL is
use Table_List, Field_List, Criteria_Lists, Table_Sets;
use When_Lists, Query_Pointers;
use type Boolean_Fields.Field;
Comparison_Like : aliased constant String := " LIKE ";
Comparison_ILike : aliased constant String := " ILIKE ";
Comparison_Not_Like : aliased constant String := " NOT LIKE ";
Comparison_Not_ILike : aliased constant String := " NOT ILIKE ";
Comparison_Overlaps : aliased constant String := " OVERLAPS ";
Comparison_Any : aliased constant String := " = ANY (";
Comparison_Parenthesis : aliased constant String := ")";
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(SQL_Table'Class, SQL_Table_Access);
function Combine
(Left, Right : SQL_Criteria; Op : Criteria_Combine) return SQL_Criteria;
-- Combine the two criterias with a specific operator.
procedure Append_Tables
(From : SQL_Field_List; To : in out Table_Sets.Set);
-- Append all tables referenced in From to To.
function To_String (Names : Table_Names) return String;
function To_String (Self : Table_Sets.Set) return Unbounded_String;
-- Various implementations for To_String, for different types
package Any_Fields is new Data_Fields (SQL_Field);
type SQL_Field_Any is new Any_Fields.Field with null record;
-------------------
-- As field data --
-------------------
-- Used when a field is renamed via "anything AS name"
type As_Field_Internal is new SQL_Field_Internal with record
As : GNAT.Strings.String_Access;
Renamed : SQL_Field_Pointer;
end record;
overriding procedure Free (Self : in out As_Field_Internal);
overriding function To_String
(Self : As_Field_Internal;
Format : Formatter'Class;
Long : Boolean) return String;
overriding procedure Append_Tables
(Self : As_Field_Internal; To : in out Table_Sets.Set);
overriding procedure Append_If_Not_Aggregate
(Self : access As_Field_Internal;
To : in out SQL_Field_List'Class;
Is_Aggregate : in out Boolean);
--------------------------
-- Multiple args fields --
--------------------------
-- Several fields grouped into one via functions, operators or other. Such
-- fields are not typed ("field1 operator field2 operator field3 ...")
type Multiple_Args_Field_Internal is new SQL_Field_Internal with record
Func_Name : GNAT.Strings.String_Access; -- can be null
Separator : GNAT.Strings.String_Access;
Suffix : GNAT.Strings.String_Access; -- can be null
List : Field_List.Vector;
end record;
overriding function To_String
(Self : Multiple_Args_Field_Internal;
Format : Formatter'Class;
Long : Boolean) return String;
overriding procedure Append_Tables
(Self : Multiple_Args_Field_Internal; To : in out Table_Sets.Set);
overriding procedure Append_If_Not_Aggregate
(Self : access Multiple_Args_Field_Internal;
To : in out SQL_Field_List'Class;
Is_Aggregate : in out Boolean);
overriding procedure Free (Self : in out Multiple_Args_Field_Internal);
----------------------
-- Aggregate fields --
----------------------
-- Representing an sql aggregate function.
type Aggregate_Field_Internal is new SQL_Field_Internal with record
Func : GNAT.Strings.String_Access;
-- Func might be null if we only want to represent as criteria as
-- a field
Params : SQL_Field_List;
Criteria : SQL_Criteria;
Order_By : SQL_Field_List;
end record;
overriding procedure Free (Self : in out Aggregate_Field_Internal);
overriding function To_String
(Self : Aggregate_Field_Internal;
Format : Formatter'Class;
Long : Boolean) return String;
overriding procedure Append_Tables
(Self : Aggregate_Field_Internal; To : in out Table_Sets.Set);
overriding procedure Append_If_Not_Aggregate
(Self : access Aggregate_Field_Internal;
To : in out SQL_Field_List'Class;
Is_Aggregate : in out Boolean);
-----------------
-- Query fields --
-----------------
-- a SQL query represented as a field
type Query_Field_Internal is new SQL_Field_Internal with record
Query : SQL_Query;
end record;
overriding function To_String
(Self : Query_Field_Internal;
Format : Formatter'Class;
Long : Boolean) return String;
overriding procedure Append_Tables
(Self : Query_Field_Internal; To : in out Table_Sets.Set) is null;
overriding procedure Append_If_Not_Aggregate
(Self : access Query_Field_Internal;
To : in out SQL_Field_List'Class;
Is_Aggregate : in out Boolean) is null;
-----------------
-- Sort fields --
-----------------
-- Fields used in the "ORDER BY" clauses
type Sorted_Field_Internal is new SQL_Field_Internal with record
Ascending : Boolean;
Sorted : SQL_Field_Pointer;
end record;
overriding function To_String
(Self : Sorted_Field_Internal;
Format : Formatter'Class;
Long : Boolean) return String;
overriding procedure Append_Tables
(Self : Sorted_Field_Internal; To : in out Table_Sets.Set);
overriding procedure Append_If_Not_Aggregate
(Self : access Sorted_Field_Internal;
To : in out SQL_Field_List'Class;
Is_Aggregate : in out Boolean);
-------------------------
-- Field_List_Function --
-------------------------
function Field_List_Function
(Fields : SQL_Field_List) return SQL_Field'Class
is
Data : Multiple_Args_Field_Internal;
F : SQL_Field_Any
(Table => null, Instance => null, Instance_Index => -1, Name => null);
C : Field_List.Cursor := First (Fields);
begin
if Func_Name /= "" then
Data.Func_Name := new String'(Func_Name);
end if;
Data.Separator := new String'(Separator);
if Suffix /= "" then
Data.Suffix := new String'(Suffix);
end if;
while Has_Element (C) loop
declare
Field : constant SQL_Field'Class := Element (C);
C2 : Field_List.Cursor;
R : Field_Pointers.Ref;
begin
if Field in SQL_Field_Any'Class then
R := SQL_Field_Any (Field).Data;
if R.Get.Element.all in Multiple_Args_Field_Internal'Class then
declare
D : Multiple_Args_Field_Internal'Class renames
Multiple_Args_Field_Internal'Class (R.Get.Element.all);
begin
if D.Separator.all = Separator then
-- Avoid nested concatenations, put them all at the
-- same level. This simplifies the query. Due to this,
-- we are also sure the concatenation itself doesn't
-- have sub-expressions
C2 := First (D.List);
while Has_Element (C2) loop
Append (Data.List, Element (C2));
Next (C2);
end loop;
else
Append (Data.List, Field);
end if;
end;
else
Append (Data.List, Field);
end if;
else
Append (Data.List, Field);
end if;
end;
Next (C);
end loop;
F.Data.Set (Data);
return F;
end Field_List_Function;
---------------
-- To_String --
---------------
function To_String
(Self : SQL_Left_Join_Table; Format : Formatter'Class) return String
is
Result : Unbounded_String;
C : Table_List.Cursor := Table_List.No_Element;
begin
if not Self.Data.Is_Null then
C := First (Self.Data.Get.Tables.Data.Get);
end if;
Append (Result, "(");
Append (Result, To_String (Element (C), Format));
if Self.Data.Get.Is_Left_Join then
Append (Result, " LEFT JOIN ");
else
Append (Result, " JOIN ");
end if;
Next (C);
Append (Result, To_String (Element (C), Format));
if Self.Data.Get.On /= No_Criteria then
Append (Result, " ON ");
Append
(Result,
GNATCOLL.SQL_Impl.To_String
(Self.Data.Get.On, Format, Long => True));
end if;
Append (Result, ")");
if Self.Instance /= null then
Append (Result, " " & Self.Instance.all);
end if;
return To_String (Result);
end To_String;
---------------
-- To_String --
---------------
function To_String
(Self : Subquery_Table; Format : Formatter'Class) return String is
begin
if Self.Instance /= null then
return "(" & To_String (To_String (Self.Query, Format)) & ") "
& Self.Instance.all;
else
return "(" & To_String (To_String (Self.Query, Format)) & ")";
end if;
end To_String;
---------------
-- To_String --
---------------
function To_String (Self : SQL_Table'Class) return String is
begin
return To_String (Table_Names'
(Name => Self.Table_Name,
Instance => Self.Instance,
Instance_Index => Self.Instance_Index));
end To_String;
---------------
-- To_String --
---------------
function To_String
(Self : SQL_Table; Format : Formatter'Class) return String
is
pragma Unreferenced (Format);
begin
return To_String (Self);
end To_String;
---------------
-- To_String --
---------------
function To_String
(Self : SQL_Table_List; Format : Formatter'Class) return String
is
C : Table_List.Cursor := Table_List.No_Element;
Result : Unbounded_String;
begin
if not Self.Data.Is_Null then
C := First (Self.Data.Get);
end if;
if Has_Element (C) then
Append (Result, To_String (Element (C), Format));
Next (C);
end if;
while Has_Element (C) loop
Append (Result, ", ");
Append (Result, To_String (Element (C), Format));
Next (C);
end loop;
return To_String (Result);
end To_String;
---------------
-- To_String --
---------------
function To_String (Names : Table_Names) return String is
Instance : constant String := Instance_Name (Names);
begin
if Instance /= Names.Name.all then
return Names.Name.all & " " & Instance;
else
return Names.Name.all;
end if;
end To_String;
---------------
-- To_String --
---------------
function To_String (Self : Table_Sets.Set) return Unbounded_String is
Result : Unbounded_String;
C : Table_Sets.Cursor := First (Self);
begin
if Has_Element (C) then
Append (Result, To_String (Element (C)));
Next (C);
end if;
while Has_Element (C) loop
Append (Result, ", ");
Append (Result, To_String (Element (C)));
Next (C);
end loop;
return Result;
end To_String;
---------------
-- To_String --
---------------
function To_String
(Self : As_Field_Internal;
Format : Formatter'Class;
Long : Boolean) return String
is
Has_Blank : Boolean := False;
begin
for J in Self.As'Range loop
if Self.As (J) = ' ' then
Has_Blank := True;
exit;
end if;
end loop;
if Has_Blank
and then (Self.As (Self.As'First) /= '"'
or else Self.As (Self.As'Last) /= '"')
then
return To_String (Self.Renamed, Format, Long)
& " AS """ & Self.As.all & """";
else
return To_String (Self.Renamed, Format, Long)
& " AS " & Self.As.all;
end if;
end To_String;
---------------
-- To_String --
---------------
function To_String
(Self : Sorted_Field_Internal;
Format : Formatter'Class;
Long : Boolean) return String is
begin
if Self.Ascending then
return To_String (Self.Sorted, Format, Long => Long) & " ASC";
else
return To_String (Self.Sorted, Format, Long => Long) & " DESC";
end if;
end To_String;
---------------
-- To_String --
---------------
function To_String
(Self : Multiple_Args_Field_Internal;
Format : Formatter'Class;
Long : Boolean) return String
is
C : Field_List.Cursor := First (Self.List);
Result : Unbounded_String;
begin
if Self.Func_Name /= null then
Append (Result, Self.Func_Name.all);
end if;
if Has_Element (C) then
Append (Result, To_String (Element (C), Format, Long));
Next (C);
end if;
while Has_Element (C) loop
Append (Result, Self.Separator.all);
Append (Result, To_String (Element (C), Format, Long));
Next (C);
end loop;
if Self.Suffix /= null then
Append (Result, Self.Suffix.all);
end if;
return To_String (Result);
end To_String;
---------------
-- To_String --
---------------
function To_String
(Self : Case_Stmt_Internal;
Format : Formatter'Class;
Long : Boolean) return String
is
C : When_Lists.Cursor := First (Self.Criteria.List);
Result : Unbounded_String;
begin
Append (Result, "CASE");
while Has_Element (C) loop
Append (Result, " WHEN "
& GNATCOLL.SQL_Impl.To_String (Element (C).Criteria, Format)
& " THEN "
& To_String (Element (C).Field, Format, Long));
Next (C);
end loop;
if Self.Else_Clause /= No_Field_Pointer then
Append
(Result,
" ELSE " & To_String (Self.Else_Clause, Format, Long));
end if;
Append (Result, " END");
return To_String (Result);
end To_String;
---------
-- "&" --
---------
function "&" (Left, Right : SQL_Table_List) return SQL_Table_List is
begin
if Left.Data.Is_Null then
return Right;
end if;
if Right.Data.Is_Null then
return Left;
end if;
Copy_Operands : declare
Result : SQL_Table_List;
begin
Result.Data.Set (Table_List."&" (Left.Data.Get, Right.Data.Get));
return Result;
end Copy_Operands;
end "&";
---------
-- "&" --
---------
function "&"
(Left : SQL_Table_List;
Right : SQL_Single_Table'Class) return SQL_Table_List
is
begin
return Left & (+Right);
end "&";
---------
-- "&" --
---------
function "&" (Left, Right : SQL_Single_Table'Class) return SQL_Table_List is
Result : constant SQL_Table_List := +Left;
begin
Result.Data.Get.Append (Right);
return Result;
end "&";
---------
-- "+" --
---------
function "+" (Left : SQL_Single_Table'Class) return SQL_Table_List is
Result : SQL_Table_List;
begin
Result.Data.Set (Table_List.To_Vector (Left, 1));
return Result;
end "+";
--------
-- As --
--------
function As
(Field : SQL_Field'Class; Name : String) return SQL_Field'Class
is
Data : As_Field_Internal;
F : Field_Pointers.Ref;
begin
Data.As := new String'(Name);
Data.Renamed := +Field;
F.Set (Data);
return SQL_Field_Any'
(Table => null,
Instance => null,
Name => null,
Instance_Index => -1,
Data => F);
end As;
----------
-- Desc --
----------
function Desc (Field : SQL_Field'Class) return SQL_Field'Class is
Data : Sorted_Field_Internal;
F : Field_Pointers.Ref;
begin
Data.Ascending := False;
Data.Sorted := +Field;
F.Set (Data);
return SQL_Field_Any'
(Table => null,
Instance => null,
Name => null,
Instance_Index => -1,
Data => F);
end Desc;
---------
-- Asc --
---------
function Asc (Field : SQL_Field'Class) return SQL_Field'Class is
Data : Sorted_Field_Internal;
F : Field_Pointers.Ref;
begin
Data.Ascending := True;
Data.Sorted := +Field;
F.Set (Data);
return SQL_Field_Any'
(Table => null, Instance => null, Name => null,
Instance_Index => -1,
Data => F);
end Asc;
------------------------
-- Expression_Or_Null --
------------------------
function Expression_Or_Null
(Value : String) return Text_Fields.Field'Class
is
begin
if Value = Null_String then
return Text_Fields.From_String (Null_String);
else
return Text_Fields.Expression (Value);
end if;
end Expression_Or_Null;
----------------
-- As_Boolean --
----------------
function As_Boolean
(Criteria : SQL_Criteria) return SQL_Field'Class
is
Data : Aggregate_Field_Internal;
F : Field_Pointers.Ref;
begin
Data.Criteria := Criteria;
F.Set (Data);
return SQL_Field_Any'
(Table => null, Instance => null, Name => null,
Instance_Index => -1,
Data => F);
end As_Boolean;
-------------
-- As_Days --
-------------
function As_Days (Count : Natural) return Time_Fields.Field'Class is
begin
return Time_Fields.From_String
("interval '" & Integer'Image (Count) & "days'");
end As_Days;
function As_Days (Count : Natural) return Date_Fields.Field'Class is
begin
return Date_Fields.From_String (Integer'Image (Count));
end As_Days;
------------------
-- At_Time_Zone --
------------------
function At_Time_Zone
(Field : Time_Fields.Field'Class; TZ : String)
return Time_Fields.Field'Class
is
function Internal is new Time_Fields.Apply_Function
(Time_Fields.Field, "", " at time zone '" & TZ & "'");
begin
return Internal (Field);
end At_Time_Zone;
----------
-- Free --
----------
overriding procedure Free (Self : in out Multiple_Args_Field_Internal) is
begin
Free (Self.Suffix);
Free (Self.Func_Name);
Free (Self.Separator);
end Free;
------------
-- Concat --
------------
function Concat (Fields : SQL_Field_List) return SQL_Field'Class is
function Internal is new Field_List_Function ("", " || ", "");
begin
return Internal (Fields);
end Concat;
-----------
-- Tuple --
-----------
function Tuple (Fields : SQL_Field_List) return SQL_Field'Class is
function Internal is new Field_List_Function ("(", ", ", ")");
begin
return Internal (Fields);
end Tuple;
--------------
-- Coalesce --
--------------
function Coalesce (Fields : SQL_Field_List) return SQL_Field'Class is
function Internal is new Field_List_Function ("COALESCE (", ", ", ")");
begin
return Internal (Fields);
end Coalesce;
---------
-- "&" --
---------
function "&" (List1, List2 : When_List) return When_List is
Result : When_List;
procedure Copy_Elements (L : When_List);
-- Copy elements from L into Result
-------------------
-- Copy_Elements --
-------------------
procedure Copy_Elements (L : When_List) is
C : When_Lists.Cursor := L.List.First;
begin
while Has_Element (C) loop
Append (Result.List, Element (C));
Next (C);
end loop;
end Copy_Elements;
-- Start of processing for "&"
begin
Copy_Elements (List1);
Copy_Elements (List2);
return Result;
end "&";
--------------
-- SQL_When --
--------------
function SQL_When
(Criteria : SQL_Criteria; Field : SQL_Field'Class) return When_List
is
Result : When_List;
begin
Append (Result.List, When_List_Item'(Criteria, +Field));
return Result;
end SQL_When;
--------------
-- SQL_Case --
--------------
function SQL_Case
(List : When_List; Else_Clause : SQL_Field'Class := Null_Field_Text)
return SQL_Field'Class
is
Data : Case_Stmt_Internal;
F : Field_Pointers.Ref;
begin
Data.Criteria := List;
if Else_Clause /= SQL_Field'Class (Null_Field_Text) then
Data.Else_Clause := +Else_Clause;
end if;
F.Set (Data);
return SQL_Field_Any'
(Table => null,
Instance => null,
Name => null,
Instance_Index => -1,
Data => F);
end SQL_Case;
-------------
-- To_Char --
-------------
function To_Char
(Field : Time_Fields.Field'Class; Format : String)
return Text_Fields.Field'Class
is
function Internal is new Text_Fields.Apply_Function
(Time_Fields.Field, "TO_CHAR (", ", '" & Format & "')");
begin
return Internal (Field);
end To_Char;
-------------
-- Extract --
-------------
function Extract
(Field : Time_Fields.Field'Class; Attribute : String)
return Time_Fields.Field'Class
is
function Internal is new Time_Fields.Apply_Function
(Time_Fields.Field, "EXTRACT (" & Attribute & " from ");
begin
return Internal (Field);
end Extract;
-------------
-- Extract --
-------------
function Extract
(Field : Date_Fields.Field'Class; Attribute : String)
return Date_Fields.Field'Class
is
function Internal is new Date_Fields.Apply_Function
(Date_Fields.Field, "EXTRACT (" & Attribute & " from ");
begin
return Internal (Field);
end Extract;
--------------
-- Absolute --
--------------
function Absolute
(Field : SQL_Field'Class) return Integer_Fields.Field'Class
is
function Internal is new Integer_Fields.Apply_Function
(SQL_Field, "ABS (");
begin
return Internal (Field);
end Absolute;
-----------
-- Lower --
-----------
function Lower
(Field : SQL_Field'Class) return Text_Fields.Field'Class
is
function Internal is new Text_Fields.Apply_Function
(SQL_Field, "LOWER (");
begin
return Internal (Field);
end Lower;
-----------
-- Upper --
-----------
function Upper
(Field : SQL_Field'Class) return Text_Fields.Field'Class
is
function Internal is new Text_Fields.Apply_Function
(SQL_Field, "UPPER (");
begin
return Internal (Field);
end Upper;
----------
-- Trim --
----------
function Trim (Field : SQL_Field'Class) return Text_Fields.Field'Class is
function Internal is new Text_Fields.Apply_Function
(SQL_Field, "TRIM (");
begin
return Internal (Field);
end Trim;
-------------
-- Initcap --
-------------
function Initcap
(Field : SQL_Field'Class) return Text_Fields.Field'Class
is
function Internal is new Text_Fields.Apply_Function
(SQL_Field, "INITCAP (");
begin
return Internal (Field);
end Initcap;
--------------------
-- Cast_To_String --
--------------------
function Cast_To_String
(Field : SQL_Field'Class) return Text_Fields.Field'Class
is
function Internal is new Text_Fields.Apply_Function
(SQL_Field, "CAST (", "AS TEXT)");
begin
return Internal (Field);
end Cast_To_String;
------------------
-- Cast_To_Date --
------------------
function Cast_To_Date
(Field : SQL_Field'Class) return Date_Fields.Field'Class
is
function Internal is new Date_Fields.Apply_Function
(SQL_Field, "CAST (", "AS DATE)");
begin
return Internal (Field);
end Cast_To_Date;
---------------------
-- Cast_To_Integer --
---------------------
function Cast_To_Integer
(Field : SQL_Field'Class) return Integer_Fields.Field'Class
is
function Internal is new Integer_Fields.Apply_Function
(SQL_Field, "CAST (", "AS INTEGER)");
begin
return Internal (Field);
end Cast_To_Integer;
---------------
-- To_String --
---------------
function To_String
(Self : Aggregate_Field_Internal;
Format : Formatter'Class;
Long : Boolean) return String
is
Result : Unbounded_String;
procedure Append_Field_List (L : SQL_Field_List);
-- Append L as a comma separated list to Result
-----------------------
-- Append_Field_List --
-----------------------
procedure Append_Field_List (L : SQL_Field_List) is
C : Field_List.Cursor := First (L);
First : Boolean := True;
begin
while Has_Element (C) loop
if First then
First := False;
else
Append (Result, ", ");
end if;
Append (Result, To_String (Element (C), Format, Long));
Next (C);
end loop;
end Append_Field_List;
-- Start of processing for To_String
begin
if Self.Func /= null then
Result := To_Unbounded_String (Self.Func.all & " (");
end if;
Append_Field_List (Self.Params);
if Self.Criteria /= No_Criteria then
Append (Result, GNATCOLL.SQL_Impl.To_String (Self.Criteria, Format));
end if;
-- Optional ORDER BY clause
if Self.Order_By /= Empty_Field_List then
Append (Result, " ORDER BY ");
Append_Field_List (Self.Order_By);
end if;
if Self.Func /= null then
Append (Result, ")");
end if;
return To_String (Result);
end To_String;
-----------
-- Apply --
-----------
function Apply
(Func : Aggregate_Function;
Criteria : SQL_Criteria;
Order_By : SQL_Field_Or_List'Class := Empty_Field_List)
return SQL_Field'Class
is
Data : Aggregate_Field_Internal;
F : Field_Pointers.Ref;
begin
Data.Criteria := Criteria;
Data.Func := new String'(String (Func));
if Order_By in SQL_Field'Class then
Data.Order_By := +SQL_Field'Class (Order_By);
else
Data.Order_By := SQL_Field_List (Order_By);
end if;
F.Set (Data);
return SQL_Field_Any'
(Table => null, Instance => null, Name => null,
Instance_Index => -1,
Data => F);
end Apply;
-----------
-- Apply --
-----------
function Apply
(Func : Aggregate_Function;
Fields : SQL_Field_List;
Order_By : SQL_Field_Or_List'Class := Empty_Field_List)
return SQL_Field'Class
is
Data : Aggregate_Field_Internal;
F : Field_Pointers.Ref;
begin
Data.Params := Fields;
Data.Func := new String'(String (Func));
if Order_By in SQL_Field'Class then
Data.Order_By := +SQL_Field'Class (Order_By);
else
Data.Order_By := SQL_Field_List (Order_By);
end if;
F.Set (Data);
return SQL_Field_Any'
(Table => null,
Instance => null,
Name => null,
Instance_Index => -1,
Data => F);
end Apply;
-----------
-- Apply --
-----------
function Apply
(Func : Aggregate_Function;
Field : SQL_Field'Class;
Order_By : SQL_Field_Or_List'Class := Empty_Field_List)
return SQL_Field'Class
is
Data : Aggregate_Field_Internal;
F : Field_Pointers.Ref;
begin
Data.Params := +Field;
Data.Func := new String'(String (Func));
if Order_By in SQL_Field'Class then
Data.Order_By := +SQL_Field'Class (Order_By);
else
Data.Order_By := SQL_Field_List (Order_By);
end if;
F.Set (Data);
return SQL_Field_Any'
(Table => null,
Instance => null,
Name => null,
Instance_Index => -1,
Data => F);
end Apply;
-------------
-- To_List --
-------------
function To_List (Fields : SQL_Field_Array) return SQL_Field_List is
S : SQL_Field_List;
begin
for A in Fields'Range loop
Append (S, Fields (A));
end loop;
return S;
end To_List;
-----------
-- "not" --
-----------
function "not" (Self : SQL_Criteria) return SQL_Criteria is
Data : SQL_Criteria_Data (Criteria_Not);
Result : SQL_Criteria;
begin
if Self = No_Criteria then
return No_Criteria;
end if;
Data.Criteria := Self;
Set_Data (Result, Data);
return Result;
end "not";
------------
-- Length --
------------
function Length (Self : SQL_Criteria) return Natural is
use type SQL_Criteria_Data_Access;
Ptr : constant SQL_Criteria_Data_Access := Get_Data (Self);
begin
if Ptr = null then
return 0;
end if;
if Ptr.all in SQL_Criteria_Data'Class
and then SQL_Criteria_Data (Ptr.all).Op in Criteria_Combine
then
return Natural (SQL_Criteria_Data (Ptr.all).Criterias.Length);
else
return 1;
end if;
end Length;
-----------
-- Is_Or --
-----------
function Is_Or (Self : SQL_Criteria) return Boolean is
use type SQL_Criteria_Data_Access;
Ptr : constant SQL_Criteria_Data_Access := Get_Data (Self);
begin
return Ptr /= null and then Ptr.all in SQL_Criteria_Data'Class
and then SQL_Criteria_Data (Ptr.all).Op = Criteria_Or;
end Is_Or;
------------
-- Is_And --
------------
function Is_And (Self : SQL_Criteria) return Boolean is
use type SQL_Criteria_Data_Access;
Ptr : constant SQL_Criteria_Data_Access := Get_Data (Self);
begin
return Ptr /= null and then Ptr.all in SQL_Criteria_Data'Class
and then SQL_Criteria_Data (Ptr.all).Op = Criteria_And;
end Is_And;
-------------
-- Combine --
-------------
function Combine
(List : Criteria_List; Op : Criteria_Combine) return SQL_Criteria
is
Result : SQL_Criteria;
Data : SQL_Criteria_Data (Op);
begin
Data.Criterias := List;
Set_Data (Result, Data);
return Result;
end Combine;
-------------
-- Combine --
-------------
function Combine
(Left, Right : SQL_Criteria; Op : Criteria_Combine) return SQL_Criteria
is
List : Criteria_List;
C : Criteria_Lists.Cursor;
begin
if Left = No_Criteria then
return Right;
elsif Right = No_Criteria then
return Left;
elsif Get_Data (Left).all in SQL_Criteria_Data'Class
and then SQL_Criteria_Data (Get_Data (Left).all).Op = Op
then
-- ??? We could optimize when Left.Refcount=1, since we are modifying
-- the last instance and thus do not need to copy the list
List := SQL_Criteria_Data (Get_Data (Left).all).Criterias;
if Get_Data (Right).all in SQL_Criteria_Data'Class
and then SQL_Criteria_Data (Get_Data (Right).all).Op = Op
then
C := First (SQL_Criteria_Data (Get_Data (Right).all).Criterias);
while Has_Element (C) loop
Append (List, Element (C));
Next (C);
end loop;
else
Append (List, Right);
end if;
elsif Get_Data (Right).all in SQL_Criteria_Data'Class
and then SQL_Criteria_Data (Get_Data (Right).all).Op = Op
then
List := SQL_Criteria_Data (Get_Data (Right).all).Criterias;
Prepend (List, Left);
else
Append (List, Left);
Append (List, Right);
end if;
return Combine (List, Op);
end Combine;
--------------
-- Overlaps --
--------------
function Overlaps (Left, Right : SQL_Field'Class) return SQL_Criteria is
begin
return Compare (Left, Right, Comparison_Overlaps'Access);
end Overlaps;
-----------
-- "and" --
-----------
function "and" (Left, Right : SQL_Criteria) return SQL_Criteria is
begin
return Combine (Left, Right, Criteria_And);
end "and";
----------
-- "or" --
----------
function "or" (Left, Right : SQL_Criteria) return SQL_Criteria is
begin
return Combine (Left, Right, Criteria_Or);
end "or";
-----------
-- "and" --
-----------
function "and"
(Left : SQL_Criteria; Right : Boolean_Fields.Field'Class)
return SQL_Criteria is
begin
return Left and (Right = True);
end "and";
----------
-- "or" --
----------
function "or"
(Left : SQL_Criteria; Right : Boolean_Fields.Field'Class)
return SQL_Criteria is
begin
return Left or (Right = True);
end "or";
-----------
-- "not" --
-----------
function "not" (Left : Boolean_Fields.Field'Class) return SQL_Criteria is
begin
return Left = False;
end "not";
------------
-- SQL_In --
------------
function SQL_In
(Self : SQL_Field'Class; List : SQL_Field_List) return SQL_Criteria
is
Data : SQL_Criteria_Data (Criteria_In);
Result : SQL_Criteria;
begin
Data.Arg := +Self;
Data.List := List;
Set_Data (Result, Data);
return Result;
end SQL_In;
function SQL_In
(Self : SQL_Field'Class; Subquery : SQL_Query) return SQL_Criteria
is
Data : SQL_Criteria_Data (Criteria_In);
Result : SQL_Criteria;
begin
Data.Arg := +Self;
Data.Subquery := Subquery;
Set_Data (Result, Data);
return Result;
end SQL_In;
function SQL_In
(Self : SQL_Field'Class; List : String) return SQL_Criteria
is
Data : SQL_Criteria_Data (Criteria_In);
Result : SQL_Criteria;
begin
Data.Arg := +Self;
Data.In_String := To_Unbounded_String (List);
Set_Data (Result, Data);
return Result;
end SQL_In;
------------
-- Exists --
------------
function Exists (Subquery : SQL_Query) return SQL_Criteria is
Data : SQL_Criteria_Data (Criteria_Exists);
Result : SQL_Criteria;
begin
Data.Subquery2 := Subquery;
Set_Data (Result, Data);
return Result;
end Exists;
----------------
-- SQL_Not_In --
----------------
function SQL_Not_In
(Self : SQL_Field'Class; List : SQL_Field_List) return SQL_Criteria
is
Data : SQL_Criteria_Data (Criteria_Not_In);
Result : SQL_Criteria;
begin
Data.Arg := +Self;
Data.List := List;
Set_Data (Result, Data);
return Result;
end SQL_Not_In;
function SQL_Not_In
(Self : SQL_Field'Class; Subquery : SQL_Query) return SQL_Criteria
is
Data : SQL_Criteria_Data (Criteria_Not_In);
Result : SQL_Criteria;
begin
Data.Arg := +Self;
Data.Subquery := Subquery;
Set_Data (Result, Data);
return Result;
end SQL_Not_In;
function SQL_Not_In
(Self : SQL_Field'Class; List : String) return SQL_Criteria
is
Data : SQL_Criteria_Data (Criteria_Not_In);
Result : SQL_Criteria;
begin
Data.Arg := +Self;
Data.In_String := To_Unbounded_String (List);
Set_Data (Result, Data);
return Result;
end SQL_Not_In;
-----------------
-- SQL_Between --
-----------------
function SQL_Between
(Self, Left, Right : SQL_Field'Class) return SQL_Criteria is
begin
return Result : SQL_Criteria do
Set_Data
(Result,
SQL_Criteria_Data'
(Criteria_Between,
Arg2 => +Self, Left => +Left, Right => +Right));
end return;
end SQL_Between;
---------------------
-- SQL_Not_Between --
---------------------
function SQL_Not_Between
(Self, Left, Right : SQL_Field'Class) return SQL_Criteria is
begin
return Result : SQL_Criteria do
Set_Data
(Result,
SQL_Criteria_Data'
(Criteria_Not_Between,
Arg2 => +Self, Left => +Left, Right => +Right));
end return;
end SQL_Not_Between;
-------------
-- Is_Null --
-------------
function Is_Null (Self : SQL_Field'Class) return SQL_Criteria is
Data : SQL_Criteria_Data (Criteria_Null);
Result : SQL_Criteria;
begin
Data.Arg3 := +Self;
Set_Data (Result, Data);
return Result;
end Is_Null;
-----------------
-- Is_Not_Null --
-----------------
function Is_Not_Null (Self : SQL_Field'Class) return SQL_Criteria is
Data : SQL_Criteria_Data (Criteria_Not_Null);
Result : SQL_Criteria;
begin
Data.Arg3 := +Self;
Set_Data (Result, Data);
return Result;
end Is_Not_Null;
---------
-- Any --
---------
function Any (Self, Str : Text_Fields.Field'Class) return SQL_Criteria is
begin
return Compare
(Self, Str, Comparison_Any'Access, Comparison_Parenthesis'Access);
end Any;
-----------
-- Ilike --
-----------
function Ilike
(Self : Text_Fields.Field'Class; Str : String) return SQL_Criteria is
begin
return Compare (Self, Expression (Str), Comparison_ILike'Access);
end Ilike;
----------
-- Like --
----------
function Like
(Self : Text_Fields.Field'Class; Str : String) return SQL_Criteria is
begin
return Compare (Self, Expression (Str), Comparison_Like'Access);
end Like;
-----------
-- Ilike --
-----------
function Ilike
(Self : Text_Fields.Field'Class; Field : SQL_Field'Class)
return SQL_Criteria is
begin
return Compare (Self, Field, Comparison_ILike'Access);
end Ilike;
----------
-- Like --
----------
function Like
(Self : Text_Fields.Field'Class; Field : Text_Fields.Field'Class)
return SQL_Criteria
is
begin
return Compare (Self, Field, Comparison_Like'Access);
end Like;
---------------
-- Not_Ilike --
---------------
function Not_Ilike
(Self : Text_Fields.Field'Class; Str : String) return SQL_Criteria is
begin
return Compare (Self, Expression (Str), Comparison_Not_ILike'Access);
end Not_Ilike;
--------------
-- Not_Like --
--------------
function Not_Like
(Self : Text_Fields.Field'Class; Str : String) return SQL_Criteria is
begin
return Compare (Self, Expression (Str), Comparison_Not_Like'Access);
end Not_Like;
---------------
-- To_String --
---------------
function To_String
(Self : SQL_Criteria_Data;
Format : Formatter'Class;
Long : Boolean := True) return String
is
Result : Unbounded_String;
List : Unbounded_String;
C : Criteria_Lists.Cursor;
C2 : Field_List.Cursor;
Is_First : Boolean;
Criteria : SQL_Criteria;
begin
case Self.Op is
when Criteria_Combine =>
C := First (Self.Criterias);
while Has_Element (C) loop
if C /= First (Self.Criterias) then
case Self.Op is
when Criteria_And => Append (Result, " AND ");
when Criteria_Or => Append (Result, " OR ");
when others => null;
end case;
end if;
Criteria := Element (C);
if Get_Data (Criteria).all in SQL_Criteria_Data'Class
and then SQL_Criteria_Data (Get_Data (Criteria).all).Op
in Criteria_Combine
then
Append (Result, "(");
Append (Result,
GNATCOLL.SQL_Impl.To_String (Element (C), Format));
Append (Result, ")");
else
Append (Result,
GNATCOLL.SQL_Impl.To_String (Element (C), Format));
end if;
Next (C);
end loop;
when Criteria_In | Criteria_Not_In =>
List := Null_Unbounded_String;
Is_First := True;
C2 := First (Self.List);
while Has_Element (C2) loop
if not Is_First then
Append (List, ",");
end if;
Is_First := False;
Append (List, To_String (Element (C2), Format, Long));
Next (C2);
end loop;
Append (List, To_String (Self.Subquery, Format));
Append (List, Self.In_String);
if List = "" then
-- "A in ()" is same as "False"
-- "A not in ()" is same as "True"
Result := To_Unbounded_String
(Expression (Self.Op = Criteria_Not_In)
.To_String (Format, Long));
else
Result :=
To_Unbounded_String (To_String (Self.Arg, Format, Long));
Append (Result,
(if Self.Op = Criteria_In
then " IN (" else " NOT IN ("));
Append (Result, List);
Append (Result, ")");
end if;
when Criteria_Exists =>
Result := To_Unbounded_String ("EXISTS (");
Append (Result, To_String (Self.Subquery2, Format));
Append (Result, ")");
when Criteria_Between | Criteria_Not_Between =>
Result := To_Unbounded_String
(To_String (Self.Arg2, Format, Long));
if Self.Op = Criteria_Not_Between then
Append (Result, " NOT");
end if;
Append
(Result,
" BETWEEN " & To_String (Self.Left, Format, Long) & " AND "
& To_String (Self.Right, Format, Long));
when Null_Criteria =>
Result := To_Unbounded_String
(To_String (Self.Arg3, Format, Long));
case Self.Op is
when Criteria_Null => Append (Result, " IS NULL");
when Criteria_Not_Null => Append (Result, " IS NOT NULL");
when others => null;
end case;
when Criteria_Not =>
Result := To_Unbounded_String
("NOT (" & To_String (Self.Criteria, Format, Long) & ")");
end case;
return To_String (Result);
end To_String;
----------------
-- SQL_Values --
----------------
function SQL_Values (Val : Field_List_Array) return SQL_Query is
Q : SQL_Query;
Data : constant Query_Pointers.Encapsulated_Access :=
new Query_Values_Contents'
(Query_Contents with Size => Val'Length, Values => Val);
-- We have to declare and assign Data with definite access type first
-- and then put it into Q.Set. If we use operator "new" as a parameter
-- for Q.Set we've got a runtime error "accessibility check failed"
-- inside of Q.Set. Checked at GNATLS Pro 18.0w (20170525-63).
begin
Q.Set (Data);
return Q;
end SQL_Values;
---------------
-- To_String --
---------------
overriding function To_String
(Self : Query_Values_Contents;
Format : Formatter'Class) return Unbounded_String
is
Result : Unbounded_String := To_Unbounded_String ("VALUES ");
begin
for R in Self.Values'Range loop
if R /= Self.Values'First then
Append (Result, ", (");
else
Append (Result, '(');
end if;
Append (Result, To_String (Self.Values (R), Format, Long => True));
Append (Result, ')');
end loop;
return Result;
end To_String;
----------------
-- SQL_Select --
----------------
function SQL_Select
(Fields : SQL_Field_Or_List'Class;
From : SQL_Table_Or_List'Class := Empty_Table_List;
Where : SQL_Criteria := No_Criteria;
Group_By : SQL_Field_Or_List'Class := Empty_Field_List;
Having : SQL_Criteria := No_Criteria;
Order_By : SQL_Field_Or_List'Class := Empty_Field_List;
Limit : Integer := -1;
Offset : Integer := -1;
Distinct : Boolean := False;
Auto_Complete : Boolean := False) return SQL_Query
is
Data : Query_Select_Contents;
Q : SQL_Query;
begin
if Fields in SQL_Field'Class then
Data.Fields := +SQL_Field'Class (Fields);
else
Data.Fields := SQL_Field_List (Fields);
end if;
if From in SQL_Table_List'Class then
Data.Tables := SQL_Table_List (From);
else
Data.Tables := +SQL_Single_Table'Class (From);
end if;
Data.Criteria := Where;
if Group_By in SQL_Field'Class then
Data.Group_By := +SQL_Field'Class (Group_By);
else
Data.Group_By := SQL_Field_List (Group_By);
end if;
Data.Having := Having;
if Order_By in SQL_Field'Class then
Data.Order_By := +SQL_Field'Class (Order_By);
else
Data.Order_By := SQL_Field_List (Order_By);
end if;
Data.Limit := Limit;
Data.Offset := Offset;
Data.Distinct := Distinct;
Q.Set (Data);
if Auto_Complete then
GNATCOLL.SQL.Auto_Complete (Q);
end if;
return Q;
end SQL_Select;
---------------
-- To_String --
---------------
overriding function To_String
(Self : Query_Select_Contents;
Format : Formatter'Class) return Unbounded_String
is
Result : Unbounded_String;
begin
Result := To_Unbounded_String ("SELECT ");
if Self.Distinct then
Append (Result, "DISTINCT ");
end if;
Append (Result, To_String (Self.Fields, Format, Long => True));
if Self.Tables /= Empty_Table_List
or else not Is_Empty (Self.Extra_Tables)
then
Append (Result, " FROM ");
if Self.Tables.Data.Is_Null or else Self.Tables.Data.Get.Is_Empty then
Append (Result, To_String (Self.Extra_Tables));
elsif Is_Empty (Self.Extra_Tables) then
Append (Result, To_String (Self.Tables, Format));
else
Append (Result, To_String (Self.Tables, Format));
Append (Result, ", ");
Append (Result, To_String (Self.Extra_Tables));
end if;
end if;
if Self.Criteria /= No_Criteria then
Append (Result, " WHERE ");
Append (Result, GNATCOLL.SQL_Impl.To_String (Self.Criteria, Format));
end if;
if Self.Group_By /= Empty_Field_List then
Append (Result, " GROUP BY ");
Append (Result, To_String (Self.Group_By, Format, Long => True));
if Self.Having /= No_Criteria then
Append (Result, " HAVING ");
Append (Result, GNATCOLL.SQL_Impl.To_String (Self.Having, Format));
end if;
end if;
if Self.Order_By /= Empty_Field_List then
Append (Result, " ORDER BY ");
Append (Result, To_String (Self.Order_By, Format, Long => True));
end if;
-- Need to output LIMIT before OFFSET for sqlite. This seems to be
-- compatible with other backends.
if Self.Limit >= 0 or else Self.Offset >= 0 then
Append (Result, " LIMIT" & Integer'Image (Self.Limit));
end if;
if Self.Offset >= 0 then
Append (Result, " OFFSET" & Integer'Image (Self.Offset));
end if;
return Result;
end To_String;
---------------
-- SQL_Union --
---------------
function SQL_Union
(Query1, Query2 : SQL_Query;
Order_By : SQL_Field_Or_List'Class := Empty_Field_List;
Limit : Integer := -1;
Offset : Integer := -1;
Distinct : Boolean := False) return SQL_Query
is
Data : Query_Union_Contents;
Q : SQL_Query;
begin
Data.Q1 := Query1;
Data.Q2 := Query2;
if Order_By in SQL_Field'Class then
Data.Order_By := +SQL_Field'Class (Order_By);
else
Data.Order_By := SQL_Field_List (Order_By);
end if;
Data.Limit := Limit;
Data.Offset := Offset;
Data.Distinct := Distinct;
Q.Set (Data);
return Q;
end SQL_Union;
---------------
-- To_String --
---------------
overriding function To_String
(Self : Query_Union_Contents;
Format : Formatter'Class) return Unbounded_String
is
Result : Unbounded_String;
begin
Append (Result, To_String (Self.Q1, Format));
Append (Result, " UNION ");
if not Self.Distinct then
Append (Result, "ALL ");
end if;
Append (Result, To_String (Self.Q2, Format));
Append (Result, " ");
if Self.Order_By /= Empty_Field_List then
Append (Result, " ORDER BY ");
Append (Result, To_String (Self.Order_By, Format, Long => True));
end if;
-- Need to output LIMIT before OFFSET for sqlite. This seems to be
-- compatible with other backends.
if Self.Limit >= 0 or else Self.Offset >= 0 then
Append (Result, " LIMIT" & Integer'Image (Self.Limit));
end if;
if Self.Offset >= 0 then
Append (Result, " OFFSET" & Integer'Image (Self.Offset));
end if;
return Result;
end To_String;
---------------
-- To_String --
---------------
function To_String
(Self : SQL_Query; Format : Formatter'Class) return Unbounded_String is
begin
if Self.Get = null then
return Null_Unbounded_String;
else
return To_String (Self.Get.all, Format);
end if;
end To_String;
----------
-- Free --
----------
procedure Free (Self : in out As_Field_Internal) is
begin
Free (Self.As);
end Free;
----------
-- Free --
----------
procedure Free (Self : in out Aggregate_Field_Internal) is
begin
Free (Self.Func);
end Free;
-------------------
-- Auto_Complete --
-------------------
procedure Auto_Complete
(Self : in out Query_Select_Contents;
Auto_Complete_From : Boolean := True;
Auto_Complete_Group_By : Boolean := True)
is
List2 : Table_Sets.Set;
Group_By : SQL_Field_List;
Has_Aggregate : Boolean := False;
begin
if Auto_Complete_From then
-- For each field, make sure the table is in the list
Append_Tables (Self.Fields, Self.Extra_Tables);
Append_Tables (Self.Group_By, Self.Extra_Tables);
Append_Tables (Self.Order_By, Self.Extra_Tables);
Append_Tables (Self.Criteria, Self.Extra_Tables);
Append_Tables (Self.Having, Self.Extra_Tables);
Append_Tables (Self.Tables, List2);
Difference (Self.Extra_Tables, List2);
end if;
if Auto_Complete_Group_By then
Append_If_Not_Aggregate (Self.Fields, Group_By, Has_Aggregate);
Append_If_Not_Aggregate (Self.Order_By, Group_By, Has_Aggregate);
Append_If_Not_Aggregate (Self.Having, Group_By, Has_Aggregate);
if Has_Aggregate then
Self.Group_By := Group_By;
end if;
end if;
end Auto_Complete;
-------------------
-- Auto_Complete --
-------------------
procedure Auto_Complete
(Self : in out SQL_Query;
Auto_Complete_From : Boolean := True;
Auto_Complete_Group_By : Boolean := True) is
begin
if Self.Get /= null then
Auto_Complete
(Self.Get.all, Auto_Complete_From, Auto_Complete_Group_By);
end if;
end Auto_Complete;
-------------------
-- Append_Tables --
-------------------
procedure Append_Tables
(Self : SQL_Criteria_Data; To : in out Table_Sets.Set)
is
C : Criteria_Lists.Cursor;
begin
case Self.Op is
when Criteria_Combine =>
C := First (Self.Criterias);
while Has_Element (C) loop
Append_Tables (Element (C), To);
Next (C);
end loop;
when Criteria_In | Criteria_Not_In =>
Append_Tables (Self.Arg, To);
when Criteria_Exists =>
null;
when Criteria_Between | Criteria_Not_Between =>
Append_Tables (Self.Arg2, To);
when Null_Criteria =>
Append_Tables (Self.Arg3, To);
when Criteria_Not =>
Append_Tables (Self.Criteria, To);
end case;
end Append_Tables;
-------------------
-- Append_Tables --
-------------------
procedure Append_Tables
(Self : SQL_Left_Join_Table; To : in out Table_Sets.Set)
is
C : Table_List.Cursor;
begin
if not Self.Data.Get.Tables.Data.Is_Null then
C := First (Self.Data.Get.Tables.Data.Get);
while Has_Element (C) loop
Append_Tables (Element (C), To);
Next (C);
end loop;
end if;
end Append_Tables;
-------------------
-- Append_Tables --
-------------------
procedure Append_Tables (Self : SQL_Table; To : in out Table_Sets.Set) is
begin
if Self.Table_Name /= null then
Include (To, (Name => Self.Table_Name,
Instance => Self.Instance,
Instance_Index => Self.Instance_Index));
end if;
end Append_Tables;
-------------------
-- Append_Tables --
-------------------
procedure Append_Tables
(Self : SQL_Table_List; To : in out Table_Sets.Set)
is
C : Table_List.Cursor;
begin
if not Self.Data.Is_Null then
C := First (Self.Data.Get);
while Has_Element (C) loop
Append_Tables (Element (C), To);
Next (C);
end loop;
end if;
end Append_Tables;
-------------------
-- Append_Tables --
-------------------
procedure Append_Tables
(From : SQL_Field_List; To : in out Table_Sets.Set)
is
C : Field_List.Cursor := First (From);
begin
while Has_Element (C) loop
Append_Tables (Element (C), To);
Next (C);
end loop;
end Append_Tables;
-------------------
-- Append_Tables --
-------------------
procedure Append_Tables
(Self : As_Field_Internal; To : in out Table_Sets.Set) is
begin
Append_Tables (Self.Renamed, To);
end Append_Tables;
-------------------
-- Append_Tables --
-------------------
procedure Append_Tables
(Self : Sorted_Field_Internal; To : in out Table_Sets.Set) is
begin
Append_Tables (Self.Sorted, To);
end Append_Tables;
-------------------
-- Append_Tables --
-------------------
procedure Append_Tables
(Self : Multiple_Args_Field_Internal; To : in out Table_Sets.Set)
is
C : Field_List.Cursor := First (Self.List);
begin
while Has_Element (C) loop
Append_Tables (Element (C), To);
Next (C);
end loop;
end Append_Tables;
-------------------
-- Append_Tables --
-------------------
procedure Append_Tables
(Self : Case_Stmt_Internal; To : in out Table_Sets.Set)
is
C : When_Lists.Cursor := First (Self.Criteria.List);
begin
while Has_Element (C) loop
Append_Tables (Element (C).Field, To);
Next (C);
end loop;
if Self.Else_Clause /= No_Field_Pointer then
Append_Tables (Self.Else_Clause, To);
end if;
end Append_Tables;
-------------------
-- Append_Tables --
-------------------
procedure Append_Tables
(Self : Aggregate_Field_Internal; To : in out Table_Sets.Set)
is
C : Field_List.Cursor := First (Self.Params);
begin
while Has_Element (C) loop
Append_Tables (Element (C), To);
Next (C);
end loop;
Append_Tables (Self.Criteria, To);
end Append_Tables;
-----------------------------
-- Append_If_Not_Aggregate --
-----------------------------
procedure Append_If_Not_Aggregate
(Self : SQL_Field_List;
To : in out SQL_Field_List'Class;
Is_Aggregate : in out Boolean)
is
C : Field_List.Cursor := First (Self);
begin
while Has_Element (C) loop
Append_If_Not_Aggregate (Element (C), To, Is_Aggregate);
Next (C);
end loop;
end Append_If_Not_Aggregate;
-----------------------------
-- Append_If_Not_Aggregate --
-----------------------------
procedure Append_If_Not_Aggregate
(Self : access As_Field_Internal;
To : in out SQL_Field_List'Class;
Is_Aggregate : in out Boolean) is
begin
Append_If_Not_Aggregate (Self.Renamed, To, Is_Aggregate);
end Append_If_Not_Aggregate;
-----------------------------
-- Append_If_Not_Aggregate --
-----------------------------
procedure Append_If_Not_Aggregate
(Self : access Sorted_Field_Internal;
To : in out SQL_Field_List'Class;
Is_Aggregate : in out Boolean) is
begin
Append_If_Not_Aggregate (Self.Sorted, To, Is_Aggregate);
end Append_If_Not_Aggregate;
-----------------------------
-- Append_If_Not_Aggregate --
-----------------------------
procedure Append_If_Not_Aggregate
(Self : access Multiple_Args_Field_Internal;
To : in out SQL_Field_List'Class;
Is_Aggregate : in out Boolean)
is
C : Field_List.Cursor := First (Self.List);
begin
while Has_Element (C) loop
Append_If_Not_Aggregate (Element (C), To, Is_Aggregate);
Next (C);
end loop;
end Append_If_Not_Aggregate;
-----------------------------
-- Append_If_Not_Aggregate --
-----------------------------
procedure Append_If_Not_Aggregate
(Self : access Case_Stmt_Internal;
To : in out SQL_Field_List'Class;
Is_Aggregate : in out Boolean)
is
C : When_Lists.Cursor := First (Self.Criteria.List);
begin
while Has_Element (C) loop
Append_If_Not_Aggregate (Element (C).Criteria, To, Is_Aggregate);
Append_If_Not_Aggregate (Element (C).Field, To, Is_Aggregate);
Next (C);
end loop;
if Self.Else_Clause /= No_Field_Pointer then
Append_If_Not_Aggregate (Self.Else_Clause, To, Is_Aggregate);
end if;
end Append_If_Not_Aggregate;
-----------------------------
-- Append_If_Not_Aggregate --
-----------------------------
procedure Append_If_Not_Aggregate
(Self : SQL_Criteria_Data;
To : in out SQL_Field_List'Class;
Is_Aggregate : in out Boolean)
is
C : Criteria_Lists.Cursor;
begin
case Self.Op is
when Criteria_Combine =>
C := First (Self.Criterias);
while Has_Element (C) loop
Append_If_Not_Aggregate (Element (C), To, Is_Aggregate);
Next (C);
end loop;
when Criteria_In | Criteria_Not_In =>
Append_If_Not_Aggregate (Self.Arg, To, Is_Aggregate);
when Criteria_Exists =>
null;
when Criteria_Between | Criteria_Not_Between =>
Append_If_Not_Aggregate (Self.Arg2, To, Is_Aggregate);
when Null_Criteria =>
Append_If_Not_Aggregate (Self.Arg3, To, Is_Aggregate);
when Criteria_Not =>
Append_If_Not_Aggregate (Self.Criteria, To, Is_Aggregate);
end case;
end Append_If_Not_Aggregate;
-----------------------------
-- Append_If_Not_Aggregate --
-----------------------------
procedure Append_If_Not_Aggregate
(Self : access Aggregate_Field_Internal;
To : in out SQL_Field_List'Class;
Is_Aggregate : in out Boolean)
is
pragma Unreferenced (Self, To);
begin
Is_Aggregate := True;
end Append_If_Not_Aggregate;
----------------------
-- SQL_Create_Table --
----------------------
function SQL_Create_Table
(Name : String;
As : SQL_Query;
Temp : Boolean := False;
On_Commit : Temp_Table_Behavior := Preserve_Rows) return SQL_Query
is
Data : Query_Create_Table_As_Contents;
Q : SQL_Query;
begin
Data.Name := To_Unbounded_String (Name);
Data.As := As;
Data.Temp := Temp;
Data.On_Commit := On_Commit;
Q.Set (Data);
return Q;
end SQL_Create_Table;
---------------
-- To_String --
---------------
function To_String
(Self : Query_Create_Table_As_Contents; Format : Formatter'Class)
return Unbounded_String
is
Result : Unbounded_String;
begin
Result := To_Unbounded_String ("CREATE ");
if Self.Temp then
Append (Result, "TEMPORARY ");
end if;
Append (Result, "TABLE ");
Append (Result, Self.Name);
if Self.Temp then
Append (Result, " ON COMMIT ");
case Self.On_Commit is
when Preserve_Rows => Append (Result, "PRESERVE ROWS");
when Delete_Rows => Append (Result, "DELETE ROWS");
when Drop => Append (Result, "DROP");
end case;
end if;
Append (Result, " AS (");
Append (Result, Unbounded_String'(To_String (Self.As, Format)));
Append (Result, ')');
return Result;
end To_String;
----------------
-- SQL_Delete --
----------------
function SQL_Delete
(From : SQL_Table'Class;
Where : SQL_Criteria := No_Criteria) return SQL_Query
is
Data : Query_Delete_Contents;
Q : SQL_Query;
begin
Data.Table := +From;
Data.Where := Where;
Q.Set (Data);
return Q;
end SQL_Delete;
---------------
-- To_String --
---------------
function To_String
(Self : Query_Delete_Contents; Format : Formatter'Class)
return Unbounded_String
is
Result : Unbounded_String;
begin
Result := To_Unbounded_String ("DELETE FROM ");
Append (Result,
To_String (Element (First (Self.Table.Data.Get)), Format));
if Self.Where /= No_Criteria then
Append (Result, " WHERE ");
Append
(Result,
GNATCOLL.SQL_Impl.To_String (Self.Where, Format, Long => False));
end if;
return Result;
end To_String;
-------------------------------
-- SQL_Insert_Default_Values --
-------------------------------
function SQL_Insert_Default_Values
(Table : SQL_Table'Class) return SQL_Query
is
Data : Query_Insert_Contents;
Q : SQL_Query;
begin
Data.Into := (Name => Table.Table_Name,
Instance => Table.Instance,
Instance_Index => Table.Instance_Index);
Data.Default_Values := True;
Q.Set (Data);
return Q;
end SQL_Insert_Default_Values;
----------------
-- SQL_Insert --
----------------
function SQL_Insert
(Fields : SQL_Field_Or_List'Class;
Values : SQL_Query;
Qualifier : String := "") return SQL_Query
is
Data : Query_Insert_Contents;
Q : SQL_Query;
begin
if Fields in SQL_Field'Class then
Data.Fields := +SQL_Field'Class (Fields);
else
Data.Fields := SQL_Field_List (Fields);
end if;
Data.Into := No_Names;
Data.Subquery := Values;
if Qualifier /= "" then
Data.Qualifier := To_Unbounded_String (Qualifier);
end if;
Q.Set (Data);
Auto_Complete (Q);
return Q;
end SQL_Insert;
----------------
-- SQL_Insert --
----------------
function SQL_Insert
(Values : SQL_Assignment;
Where : SQL_Criteria := No_Criteria;
Limit : Integer := -1;
Qualifier : String := "") return SQL_Query
is
Data : Query_Insert_Contents;
Q : SQL_Query;
begin
Data.Into := No_Names;
Data.Values := Values;
Data.Where := Where;
Data.Limit := Limit;
if Qualifier /= "" then
Data.Qualifier := To_Unbounded_String (Qualifier);
end if;
Q.Set (Data);
Auto_Complete (Q);
return Q;
end SQL_Insert;
---------------
-- To_String --
---------------
function To_String
(Self : Query_Insert_Contents; Format : Formatter'Class)
return Unbounded_String
is
Result : Unbounded_String;
begin
if Self.Qualifier = "" then
Result := To_Unbounded_String ("INSERT INTO ");
else
Result := "INSERT " & Self.Qualifier & " INTO ";
end if;
Append (Result, To_String (Self.Into));
if Self.Default_Values then
Append (Result, " DEFAULT VALUES");
else
if Self.Fields /= Empty_Field_List then
Append (Result, " (");
Append (Result, To_String (Self.Fields, Format, Long => False));
Append (Result, ")");
end if;
declare
Assign : constant String :=
To_String (Self.Values, Format, With_Field => False);
begin
if Assign /= "" then
Append (Result, " VALUES (" & Assign & ")");
end if;
end;
if Self.Subquery /= No_Query then
Append (Result, " ");
Append (Result, To_String (Self.Subquery, Format));
end if;
end if;
return Result;
end To_String;
-------------------
-- Auto_Complete --
-------------------
procedure Auto_Complete
(Self : in out Query_Insert_Contents;
Auto_Complete_From : Boolean := True;
Auto_Complete_Group_By : Boolean := True)
is
pragma Unreferenced (Auto_Complete_Group_By);
List, List2 : Table_Sets.Set;
Subfields : SQL_Field_List;
begin
if Auto_Complete_From then
-- Get the list of fields first, so that we'll also know what table
-- is being updated
if Self.Fields = Empty_Field_List then
Get_Fields (Self.Values, Self.Fields);
end if;
if Self.Into = No_Names then
-- For each field, make sure the table is in the list
Append_Tables (Self.Fields, List);
-- We must have a single table here, or that's a bug
if Length (List) /= 1 then
raise Program_Error
with "Invalid list of fields to insert, they all must modify"
& " the same table";
end if;
-- Grab the table from the first field
Self.Into := Element (First (List));
end if;
if Self.Subquery = No_Query then
-- Do we have other tables impacted from the list of values we
-- set for the fields ? If yes, we'll need to transform the
-- simple query into a subquery
Clear (List);
Append_Tables (Self.Values, List);
if Self.Into /= No_Names then
Table_Sets.Include (List2, Self.Into);
end if;
Difference (List, List2); -- Remove tables already in the list
if Length (List) > 0 then
To_List (Self.Values, Subfields);
Self.Subquery := SQL_Select
(Fields => Subfields, Where => Self.Where,
Limit => Self.Limit);
Auto_Complete (Self.Subquery);
Self.Values := No_Assignment;
end if;
end if;
end if;
end Auto_Complete;
----------------
-- SQL_Update --
----------------
function SQL_Update
(Table : SQL_Table'Class;
Set : SQL_Assignment;
Where : SQL_Criteria := No_Criteria;
From : SQL_Table_Or_List'Class := Empty_Table_List) return SQL_Query
is
Data : Query_Update_Contents;
Q : SQL_Query;
begin
Data.Table := +Table;
Data.Set := Set;
Data.Where := Where;
if From in SQL_Table'Class then
Data.From := +SQL_Table'Class (From);
else
Data.From := SQL_Table_List (From);
end if;
Q.Set (Data);
return Q;
end SQL_Update;
---------------
-- To_String --
---------------
function To_String
(Self : Query_Update_Contents; Format : Formatter'Class)
return Unbounded_String
is
Result : Unbounded_String;
begin
Result := To_Unbounded_String ("UPDATE ");
Append (Result,
To_String (Element (First (Self.Table.Data.Get)), Format));
Append (Result, " SET ");
Append (Result, To_String (Self.Set, Format, With_Field => True));
if Self.From /= Empty_Table_List
or else not Is_Empty (Self.Extra_From)
then
Append (Result, " FROM ");
if Self.From.Data.Is_Null or else Self.From.Data.Get.Is_Empty then
Append (Result, To_String (Self.Extra_From));
elsif Is_Empty (Self.Extra_From) then
Append (Result, To_String (Self.From, Format));
else
Append (Result, To_String (Self.From, Format));
Append (Result, ", ");
Append (Result, To_String (Self.Extra_From));
end if;
end if;
if Self.Where /= No_Criteria then
Append (Result, " WHERE ");
Append
(Result,
GNATCOLL.SQL_Impl.To_String (Self.Where, Format, Long => True));
end if;
return Result;
end To_String;
-------------------
-- Auto_Complete --
-------------------
procedure Auto_Complete
(Self : in out Query_Update_Contents;
Auto_Complete_From : Boolean := True;
Auto_Complete_Group_By : Boolean := True)
is
pragma Unreferenced (Auto_Complete_Group_By);
List2 : Table_Sets.Set;
begin
if Auto_Complete_From then
-- For each field, make sure the table is in the list
Append_Tables (Self.Set, Self.Extra_From);
Append_Tables (Self.Where, Self.Extra_From);
-- Remove tables already in the list
Append_Tables (Self.From, List2);
Append_Tables (Self.Table, List2);
Difference (Self.Extra_From, List2);
end if;
end Auto_Complete;
---------------
-- Left_Join --
---------------
function Left_Join
(Full : SQL_Single_Table'Class;
Partial : SQL_Single_Table'Class;
On : SQL_Criteria) return SQL_Left_Join_Table
is
begin
return Result : SQL_Left_Join_Table
(Instance => null, Instance_Index => -1)
do
Result.Data.Set
(Join_Table_Internal'
(Tables => Full & Partial,
Is_Left_Join => True,
On => On));
end return;
end Left_Join;
----------
-- Join --
----------
function Join
(Table1 : SQL_Single_Table'Class;
Table2 : SQL_Single_Table'Class;
On : SQL_Criteria := No_Criteria) return SQL_Left_Join_Table
is
R : constant SQL_Left_Join_Table := Left_Join (Table1, Table2, On);
begin
R.Data.Get.Is_Left_Join := False;
return R;
end Join;
------------
-- Rename --
------------
function Rename
(Self : SQL_Left_Join_Table; Name : Cst_String_Access)
return SQL_Left_Join_Table'Class
is
R : SQL_Left_Join_Table (Instance => Name, Instance_Index => -1);
begin
R.Data := Self.Data;
return R;
end Rename;
---------------
-- To_String --
---------------
function To_String
(Self : Simple_Query_Contents; Format : Formatter'Class)
return Unbounded_String
is
pragma Unreferenced (Format);
begin
return Self.Command;
end To_String;
--------------
-- SQL_Lock --
--------------
function SQL_Lock (Table : SQL_Table'Class) return SQL_Query is
Data : Simple_Query_Contents;
Q : SQL_Query;
begin
Data.Command := To_Unbounded_String ("LOCK " & To_String (Table));
Q.Set (Data);
return Q;
end SQL_Lock;
---------------
-- SQL_Begin --
---------------
function SQL_Begin return SQL_Query is
Data : Simple_Query_Contents;
Q : SQL_Query;
begin
Data.Command := To_Unbounded_String ("BEGIN");
Q.Set (Data);
return Q;
end SQL_Begin;
------------------
-- SQL_Rollback --
------------------
function SQL_Rollback return SQL_Query is
Data : Simple_Query_Contents;
Q : SQL_Query;
begin
Data.Command := To_Unbounded_String ("ROLLBACK");
Q.Set (Data);
return Q;
end SQL_Rollback;
----------------
-- SQL_Commit --
----------------
function SQL_Commit return SQL_Query is
Data : Simple_Query_Contents;
Q : SQL_Query;
begin
Data.Command := To_Unbounded_String ("COMMIT");
Q.Set (Data);
return Q;
end SQL_Commit;
--------------
-- Subquery --
--------------
function Subquery
(Query : SQL_Query'Class; Table_Name : Cst_String_Access)
return Subquery_Table
is
begin
return R : Subquery_Table
(Instance => Table_Name, Instance_Index => -1)
do
R.Query := SQL_Query (Query);
end return;
end Subquery;
----------
-- Free --
----------
procedure Free (A : in out SQL_Table_Access) is
begin
Unchecked_Free (A);
end Free;
---------------
-- Where_And --
---------------
function Where_And
(Query : SQL_Query; Where : SQL_Criteria) return SQL_Query
is
Q2 : SQL_Query;
begin
if Query.Get.all not in Query_Select_Contents'Class then
raise Program_Error with "not a SELECT query";
end if;
declare
Contents : Query_Select_Contents'Class := -- clone contents
Query_Select_Contents'Class (Query.Get.all);
begin
Contents.Criteria := Contents.Criteria and Where;
Q2.Set (Contents);
return Q2;
end;
end Where_And;
--------------
-- Where_Or --
--------------
function Where_Or
(Query : SQL_Query; Where : SQL_Criteria) return SQL_Query
is
Q2 : SQL_Query;
begin
if Query.Get.all not in Query_Select_Contents'Class then
raise Program_Error with "not a SELECT query";
end if;
declare
Contents : Query_Select_Contents'Class := -- clone contents
Query_Select_Contents'Class (Query.Get.all);
begin
Contents.Criteria := Contents.Criteria or Where;
Q2.Set (Contents);
return Q2;
end;
end Where_Or;
--------------
-- Order_By --
--------------
function Order_By
(Query : SQL_Query; Order_By : SQL_Field_Or_List'Class)
return SQL_Query
is
Q2 : SQL_Query;
begin
if Query.Get.all not in Query_Select_Contents'Class then
raise Program_Error with "not a SELECT query";
end if;
declare
Contents : Query_Select_Contents'Class := -- clone contents
Query_Select_Contents'Class (Query.Get.all);
begin
if Order_By in SQL_Field'Class then
Contents.Order_By :=
SQL_Field'Class (Order_By) & Contents.Order_By;
else
Contents.Order_By := SQL_Field_List (Order_By) & Contents.Order_By;
end if;
Q2.Set (Contents);
return Q2;
end;
end Order_By;
--------------
-- Distinct --
--------------
function Distinct (Query : SQL_Query) return SQL_Query is
Q2 : SQL_Query;
begin
if Query.Get.all not in Query_Select_Contents'Class then
raise Program_Error with "not a SELECT query";
end if;
declare
Contents : Query_Select_Contents'Class := -- clone contents
Query_Select_Contents'Class (Query.Get.all);
begin
Contents.Distinct := True;
Q2.Set (Contents);
return Q2;
end;
end Distinct;
-----------
-- Limit --
-----------
function Limit (Query : SQL_Query; Limit : Natural) return SQL_Query is
Q2 : SQL_Query;
begin
if Query.Get.all not in Query_Select_Contents'Class then
raise Program_Error with "not a SELECT query";
end if;
declare
Contents : Query_Select_Contents'Class := -- clone contents
Query_Select_Contents'Class (Query.Get.all);
begin
Contents.Limit := Limit;
Q2.Set (Contents);
return Q2;
end;
end Limit;
------------
-- Offset --
------------
function Offset (Query : SQL_Query; Offset : Natural) return SQL_Query is
Q2 : SQL_Query;
begin
if Query.Get.all not in Query_Select_Contents'Class then
raise Program_Error with "not a SELECT query";
end if;
declare
Contents : Query_Select_Contents'Class := -- clone contents
Query_Select_Contents'Class (Query.Get.all);
begin
Contents.Offset := Offset;
Q2.Set (Contents);
return Q2;
end;
end Offset;
---------
-- "=" --
---------
function "="
(Left : SQL_Field'Class; Query : SQL_Query) return SQL_Assignment
is
Data : Query_Field_Internal;
F : Field_Pointers.Ref;
begin
Data.Query := Query;
F.Set (Data);
return Create
(Left,
SQL_Field_Any'
(Table => null,
Instance => null,
Name => null,
Instance_Index => -1,
Data => F));
end "=";
---------------
-- To_String --
---------------
overriding function To_String
(Self : Query_Field_Internal;
Format : Formatter'Class;
Long : Boolean) return String
is
pragma Unreferenced (Long);
begin
return "(" & To_String (To_String (Self.Query, Format)) & ")";
end To_String;
end GNATCOLL.SQL;
Reference in New Issue View Git Blame Copy Permalink