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
26.1
gnatcoll-db/postgres/gnatcoll-sql-postgres.adb
Dmitriy Anisimkov 7ff0255592 Add db2ada routine for all available DB backends 
Change-Id: Idcc8bbac22b110bdab8f204529ee5b26d90c6d55
2018-02-22 00:14:24 +06:00

466 lines
14 KiB
Ada
Raw Permalink Blame History

------------------------------------------------------------------------------
-- 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. --
-- --
-- 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.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with Interfaces.C;
with GNAT.Sockets;
with GNATCOLL.SQL.Postgres.Builder;
with GNATCOLL.SQL.Postgres.Gnade;
with GNATCOLL.Utils; use GNATCOLL.Utils;
package body GNATCOLL.SQL.Postgres is
N_OID : aliased constant String := "OID";
Comparison_Regexp : aliased constant String := " ~* ";
type Query_Postgres_Contents is new Query_Contents with record
Base : SQL_Query;
Extra : SQL_PG_Extension_Access;
end record;
overriding procedure Free (Self : in out Query_Postgres_Contents);
overriding function To_String
(Self : Query_Postgres_Contents;
Format : Formatter'Class) return Unbounded_String;
overriding procedure Auto_Complete
(Self : in out Query_Postgres_Contents;
Auto_Complete_From : Boolean := True;
Auto_Complete_Group_By : Boolean := True);
-- Supports adding a suffix string to the base_query
type SQL_PG_For_Update is new SQL_PG_Extension with record
Tables : SQL_Table_List := Empty_Table_List;
-- List of updated tables (empty means ALL tables in query)
No_Wait : Boolean := False;
-- Set True if NO WAIT
end record;
overriding function To_String
(Self : SQL_PG_For_Update;
Format : Formatter'Class) return Unbounded_String;
-- Extensions for UPDATE
type SQL_PG_Returning is new SQL_PG_Extension with record
Returning : SQL_Field_List;
end record;
overriding function To_String
(Self : SQL_PG_Returning;
Format : Formatter'Class) return Unbounded_String;
-- Extensions for SELECT
type Postgres_Engine is new Database_Engine with null record;
overriding function Setup
(Engine : Postgres_Engine;
Options : Name_Values.Map;
Errors : access Error_Reporter'Class) return Database_Description;
----------
-- Free --
----------
overriding procedure Free (Self : in out Query_Postgres_Contents) is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(SQL_PG_Extension'Class, SQL_PG_Extension_Access);
begin
Unchecked_Free (Self.Extra);
Free (Query_Contents (Self));
end Free;
---------------
-- To_String --
---------------
overriding function To_String
(Self : Query_Postgres_Contents;
Format : Formatter'Class) return Unbounded_String is
begin
return To_String (Self.Base, Format)
& To_String (Self.Extra.all, Format);
end To_String;
-------------------
-- Auto_Complete --
-------------------
overriding procedure Auto_Complete
(Self : in out Query_Postgres_Contents;
Auto_Complete_From : Boolean := True;
Auto_Complete_Group_By : Boolean := True) is
begin
Auto_Complete (Self.Base, Auto_Complete_From, Auto_Complete_Group_By);
end Auto_Complete;
-----------
-- Setup --
-----------
function Setup
(Database : String;
User : String := "";
Host : String := "";
Password : String := "";
Port : Integer := -1;
SSL : SSL_Mode := Allow;
Cache_Support : Boolean := True;
Errors : access Error_Reporter'Class := null)
return Database_Description
is
Result : Postgres_Description_Access;
begin
Result := new Postgres_Description
(Caching => Cache_Support, Errors => Errors);
Result.SSL := SSL;
Result.Dbname := To_XString (Database);
Result.User := To_XString (User);
Result.Password := To_XString (Password);
Result.Port := Port;
Result.Host := To_XString (Host);
return Database_Description (Result);
end Setup;
-----------
-- Setup --
-----------
overriding function Setup
(Engine : Postgres_Engine;
Options : Name_Values.Map;
Errors : access Error_Reporter'Class) return Database_Description
is
pragma Unreferenced (Engine);
type Setup_Parameters is
(Database, User, Host, Password, Port, SSL, Caching);
Params : array (Setup_Parameters) of Name_Values.Cursor;
function Value (P : Setup_Parameters; Default : String) return String is
(if Name_Values.Has_Element (Params (P))
then Name_Values.Element (Params (P)) else Default);
begin
for C in Options.Iterate loop
Params (Setup_Parameters'Value (Name_Values.Key (C))) := C;
end loop;
return Setup
(Database => Value (Database, ""),
User => Value (User, ""),
Host => Value (Host, ""),
Password => Value (Password, ""),
Port => Integer'Value (Value (Port, "-1")),
SSL => SSL_Mode'Value (Value (SSL, "Allow")),
Cache_Support => Boolean'Value (Value (Caching, "True")),
Errors => Errors);
end Setup;
----------------------
-- Build_Connection --
----------------------
overriding function Build_Connection
(Self : access Postgres_Description) return Database_Connection
is
DB : Database_Connection;
begin
DB := GNATCOLL.SQL.Postgres.Builder.Build_Connection (Self);
Reset_Connection (DB);
return DB;
end Build_Connection;
--------------
-- Notifies --
--------------
procedure Notifies
(DB : Database_Connection;
Message : out Notification;
Done : out Boolean) is
begin
Builder.To_Native (DB).Notifies (Message, Done);
end Notifies;
-------------------
-- Consume_Input --
-------------------
procedure Consume_Input (DB : Database_Connection) is
DBG : constant access Gnade.Database'Class := Builder.To_Native (DB);
begin
if not DBG.Consume_Input then
DB.Set_Failure (DBG.Error);
end if;
end Consume_Input;
--------------------
-- Wait_For_Input --
--------------------
function Wait_For_Input
(DB : Database_Connection;
Timeout : Duration := Duration'Last) return Boolean
is
use GNAT.Sockets;
function To_Ada is new Ada.Unchecked_Conversion
(Interfaces.C.int, Socket_Type);
DBG : constant access Gnade.Database'Class := Builder.To_Native (DB);
Sel : Selector_Type;
Soc : constant Socket_Type := To_Ada (DBG.Socket);
St : Selector_Status;
SS : Socket_Set_Type;
SE : Socket_Set_Type;
Rq : Request_Type (N_Bytes_To_Read);
begin
if DBG.Is_Non_Blocking then
raise Program_Error with "Non blocking connection is not supported";
end if;
Set (SS, Soc);
Create_Selector (Sel);
Check_Selector
(Sel, R_Socket_Set => SS, W_Socket_Set => SE, Status => St,
Timeout => Duration'Min (Forever, Timeout));
Close_Selector (Sel);
if St = Completed then
Control_Socket (Soc, Rq);
if Rq.Size = 0 then
-- Socket ready to read but without data available mean socket
-- closed by peer.
DB.Set_Failure ("Connection closed on PostgreSQL server side");
return False;
end if;
if not DBG.Consume_Input then
DB.Set_Failure (DBG.Error);
return False;
end if;
return True;
end if;
return False;
end Wait_For_Input;
---------------
-- OID_Field --
---------------
function OID_Field (Table : SQL_Table'Class) return SQL_Field_Integer is
begin
return SQL_Field_Integer'
(Table => Table.Table_Name,
Instance => Table.Instance,
Instance_Index => Table.Instance_Index,
Name => N_OID'Access);
end OID_Field;
------------
-- Regexp --
------------
function Regexp
(Self : Text_Fields.Field'Class;
Str : String) return SQL_Criteria is
begin
return Compare (Self, Expression (Str), Comparison_Regexp'Access);
end Regexp;
----------------
-- For_Update --
----------------
function For_Update
(Tables : SQL_Table_List := Empty_Table_List;
No_Wait : Boolean := False) return SQL_PG_Extension'Class
is
begin
return SQL_PG_For_Update'(Tables => Tables, No_Wait => No_Wait);
end For_Update;
---------------
-- Returning --
---------------
function Returning
(Fields : SQL_Field_List) return SQL_PG_Extension'Class
is
begin
return SQL_PG_Returning'(Returning => Fields);
end Returning;
---------
-- "&" --
---------
function "&"
(Query : SQL_Query;
Extension : SQL_PG_Extension'Class) return SQL_Query
is
Data : Query_Postgres_Contents;
Q : SQL_Query;
begin
if Query.Get.all in Query_Postgres_Contents'Class then
-- Merge the information with what has already been set.
-- For now, assume that Extension is the same type as was
-- already set, since we have a single extension for Update
-- and a single extension for Select. Any other combination
-- is invalid.
if Extension in SQL_PG_For_Update'Class then
declare
Orig : SQL_PG_For_Update'Class renames
SQL_PG_For_Update'Class
(Query_Postgres_Contents'Class (Query.Get.all).Extra.all);
begin
Orig.Tables := Orig.Tables &
SQL_PG_For_Update'Class (Extension).Tables;
Orig.No_Wait := Orig.No_Wait or else
SQL_PG_For_Update'Class (Extension).No_Wait;
end;
else
declare
Orig : SQL_PG_Returning'Class renames
SQL_PG_Returning'Class
(Query_Postgres_Contents'Class (Query.Get.all).Extra.all);
begin
Orig.Returning := Orig.Returning &
SQL_PG_Returning'Class (Extension).Returning;
end;
end if;
return Query;
else
Data.Base := Query;
Data.Extra := new SQL_PG_Extension'Class'(Extension);
Q.Set (Data);
return Q;
end if;
end "&";
---------------
-- To_String --
---------------
overriding function To_String
(Self : SQL_PG_For_Update;
Format : Formatter'Class) return Unbounded_String
is
Result : Unbounded_String;
begin
Append (Result, " FOR UPDATE");
if Self.Tables /= Empty_Table_List then
Append (Result, " OF ");
Append (Result, To_String (Self.Tables, Format));
end if;
if Self.No_Wait then
Append (Result, " NO WAIT");
end if;
return Result;
end To_String;
---------------
-- To_String --
---------------
overriding function To_String
(Self : SQL_PG_Returning;
Format : Formatter'Class) return Unbounded_String
is
Result : Unbounded_String;
begin
Append (Result, " RETURNING ");
Append (Result, To_String (Self.Returning, Format, Long => True));
return Result;
end To_String;
---------------------------
-- Get_Connection_String --
---------------------------
function Get_Connection_String
(Description : Database_Description;
With_Password : Boolean) return String
is
Descr : constant Postgres_Description_Access :=
Postgres_Description_Access (Description);
Str : XString;
procedure Escape (Value : XString);
procedure Escape (Value : XString) is
begin
for C of Value loop
if C = ''' or else C = '\' then
Str.Append ('\');
end if;
Str.Append (C);
end loop;
end Escape;
begin
Str.Append ("dbname='");
Escape (Descr.Dbname);
Str.Append (''');
if Descr.User /= Null_XString then
Str.Append (" user='");
Escape (Descr.User);
Str.Append (''');
end if;
if Descr.Host /= Null_XString then
Str.Append (" host='");
Escape (Descr.Host);
Str.Append (''');
end if;
if Descr.Port /= -1 then
Str.Append (" port=" & Image (Descr.Port, Min_Width => 1));
end if;
if With_Password and then Descr.Password /= Null_XString then
Str.Append (" password='");
Escape (Descr.Password);
Str.Append (''');
end if;
case Descr.SSL is
when Disable => Str.Append (" sslmode=disable");
when Allow => Str.Append (" sslmode=allow");
when Prefer => Str.Append (" sslmode=prefer");
when Require => Str.Append (" sslmode=require");
end case;
return Str.To_String;
end Get_Connection_String;
end GNATCOLL.SQL.Postgres;
Reference in New Issue View Git Blame Copy Permalink