-------------------------------------------------------------------------------
-- --
-- GNADE : GNu Ada Database Environment --
-- --
-- Copyright (C) 2000-2003 Juergen Pfeifer --
-- Copyright (C) 2004-2020, AdaCore --
-- --
-- GNADE is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License along with this program; see file COPYING. If not, see --
-- . --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNADE is implemented to work with GNAT, the GNU Ada compiler. --
-------------------------------------------------------------------------------
with Ada.Unchecked_Conversion;
with Interfaces.C; use Interfaces.C;
with System; use System;
package body GNATCOLL.SQL.Postgres.Gnade is
package C renames Interfaces.C;
package CS renames Interfaces.C.Strings;
subtype char_array is C.char_array;
subtype chars_ptr is CS.chars_ptr;
function PQexec (Conn : PGconnection; Qry : String) return PGresult
with Import, Convention => C, External_Name => "PQexec";
-- Postgres API routine. Qry parameter has to be ended with ASCII.NUL.
--------------
-- Finalize --
--------------
procedure Finalize (Object : in out Database) is
procedure PQfinish (Connection : PGconnection);
pragma Import (C, PQfinish, "PQfinish");
begin
if Object.Connection /= Null_Connection then
PQfinish (Object.Connection);
Object.Connection := Null_Connection;
end if;
end Finalize;
-------------
-- Connect --
-------------
function Connect (Params : access String) return PGconnection is
function PQConnect (Options : char_array) return PGconnection;
pragma Import (C, PQConnect, "PQconnectdb");
Conn : PGconnection;
begin
Conn := PQConnect (C.To_C (Params.all));
if Conn = Null_Connection then
raise PostgreSQL_Error;
else
return Conn;
end if;
end Connect;
-----------
-- Reset --
-----------
procedure Reset (DB : Database'Class) is
procedure PQreset (Connection : PGconnection);
pragma Import (C, PQreset, "PQreset");
begin
PQreset (DB.Connection);
end Reset;
-------------------------
-- Connection_Accessor --
-------------------------
generic
with function Accessor (Conn : PGconnection) return chars_ptr;
function Connection_Accessor (DB : Database'Class) return String;
function Connection_Accessor (DB : Database'Class) return String is
begin
return CS.Value (Accessor (DB.Connection));
end Connection_Accessor;
function PQdb (Conn : PGconnection) return chars_ptr;
pragma Import (C, PQdb, "PQdb");
function Get_Name is new Connection_Accessor (Accessor => PQdb);
function PQuser (Conn : PGconnection) return chars_ptr;
pragma Import (C, PQuser, "PQuser");
function Get_User is new Connection_Accessor (Accessor => PQuser);
function PQpass (Conn : PGconnection) return chars_ptr;
pragma Import (C, PQpass, "PQpass");
function Get_Pass is new Connection_Accessor (Accessor => PQpass);
function PQhost (Conn : PGconnection) return chars_ptr;
pragma Import (C, PQhost, "PQhost");
function Get_Host is new Connection_Accessor (Accessor => PQhost);
function PQport (Conn : PGconnection) return chars_ptr;
pragma Import (C, PQport, "PQport");
function Get_Port is new Connection_Accessor (Accessor => PQport);
function PQtty (Conn : PGconnection) return chars_ptr;
pragma Import (C, PQtty, "PQtty");
function Get_TTY is new Connection_Accessor (Accessor => PQtty);
function PQopt (Conn : PGconnection) return chars_ptr;
pragma Import (C, PQopt, "PQoptions");
function Get_Options is new Connection_Accessor (Accessor => PQopt);
function Name (DB : Database'Class) return String renames Get_Name;
function User (DB : Database'Class) return String renames Get_User;
function Password (DB : Database'Class) return String renames Get_Pass;
function Host (DB : Database'Class) return String renames Get_Host;
function Port (DB : Database'Class) return String renames Get_Port;
function TTY (DB : Database'Class) return String renames Get_TTY;
function Options (DB : Database'Class) return String
renames Get_Options;
-----------
-- Error --
-----------
function Error (DB : Database'Class) return String is
function PQerr (Conn : PGconnection) return chars_ptr;
pragma Import (C, PQerr, "PQerrorMessage");
begin
return CS.Value (PQerr (DB.Connection));
end Error;
------------
-- Status --
------------
function Status (DB : Database'Class) return ConnStatus is
function PQstatus (Conn : PGconnection) return Interfaces.C.int;
pragma Import (C, PQstatus, "PQstatus");
begin
return ConnStatus'Val (PQstatus (DB.Connection));
end Status;
----------------
-- Server_PID --
----------------
function Server_PID (DB : Database'Class) return Backend_PID is
function PQpid (Conn : PGconnection) return Interfaces.C.int;
pragma Import (C, PQpid, "PQbackendPID");
function To_PID is new Ada.Unchecked_Conversion
(Source => Interfaces.C.int, Target => Backend_PID);
begin
return To_PID (PQpid (DB.Connection));
end Server_PID;
-------------
-- Execute --
-------------
procedure Execute
(Res : in out Result;
DB : Database'Class;
Query : String;
Format : GNATCOLL.SQL_Impl.Formatter'Class;
Params : SQL_Parameters := No_Parameters)
is
function PQexecParams
(Conn : PGconnection;
Command : String;
nParams : Interfaces.C.int;
paramTypes : System.Address := System.Null_Address; -- Oid*
paramValues : CS.chars_ptr_array; -- const char* const *
paramLengths : System.Address := System.Null_Address; -- int*
paramFormats : System.Address := System.Null_Address; -- int*
resultFormat : Interfaces.C.int := 0) return PGresult;
pragma Import (C, PQexecParams, "PQexecParams");
-- paramTypes can be left to NULL for automatic guessing
--
-- paramValues:
-- Specifies the actual values of the parameters. A null pointer in
-- this array means the corresponding parameter is null; otherwise
-- the pointer points to a zero-terminated text string (for text
-- format) or binary data in the format expected by the server (for
-- binary format).
--
-- paramLengths:
-- Specifies the actual data lengths of binary-format parameters. It
-- is ignored for null parameters and text-format parameters. The
-- array pointer can be null when there are no binary parameters.
--
-- paramFormats:
-- Specifies whether parameters are text (put a zero in the array
-- entry for the corresponding parameter) or binary (put a one in the
-- array entry for the corresponding parameter). If the array pointer
-- is null then all parameters are presumed to be text strings.
-- Values passed in binary format require knowledge of the internal
-- representation expected by the backend. For example, integers must
-- be passed in network byte order. Passing numeric values requires
-- knowledge of the server storage format.
--
-- resultFormat
-- Specify zero to obtain results in text format, or one to obtain
-- results in binary format. (There is not currently a provision to
-- obtain different result columns in different formats, although
-- that is possible in the underlying protocol.)
Q : constant String := Query & ASCII.NUL;
R : PGresult;
begin
if Params'Length = 0 then
R := PQexec (DB.Connection, Q);
else
declare
Vals : CS.chars_ptr_array (0 .. Params'Length - 1);
begin
for P in Params'Range loop
Vals (size_t (P - Params'First)) :=
CS.New_String (Params (P).Image (Format));
end loop;
R := PQexecParams
(Conn => DB.Connection,
Command => Q,
nParams => C.int (Vals'Length),
paramValues => Vals);
for P in Vals'Range loop
CS.Free (Vals (P));
end loop;
end;
end if;
Clear (Res); -- Free previous results
Res.Res := R;
end Execute;
-------------
-- Prepare --
-------------
procedure Prepare
(Res : out Result;
DB : Database'Class;
Stmt_Name : String;
Query : String)
is
PQprepare : access function
(Conn : PGconnection;
Name : String;
Query : String;
nParams : Natural := 0;
Types : System.Address := System.Null_Address) return PGresult
with Import, Convention => C, External_Name => "gnatcoll_pqprepare";
begin
Clear (Res); -- Free previous results
if PQprepare = null then
Res.Res := PQexec
(DB.Connection,
"PREPARE """ & Stmt_Name & """ AS " & Query & ASCII.NUL);
else
Res.Res := PQprepare
(DB.Connection, Stmt_Name & ASCII.NUL, Query & ASCII.NUL);
end if;
end Prepare;
-------------------
-- Exec_Prepared --
-------------------
procedure Exec_Prepared
(Res : out Result;
DB : Database'Class;
Stmt_Name : String;
Format : GNATCOLL.SQL_Impl.Formatter'Class;
Params : SQL_Parameters := No_Parameters)
is
function PQexecPrepared
(Conn : PGconnection;
Name : String;
Nparams : Natural := 0;
Values : System.Address := System.Null_Address;
Lengths : System.Address := System.Null_Address;
Formats : System.Address := System.Null_Address;
Format : Natural := 0) return PGresult;
pragma Import (C, PQexecPrepared, "PQexecPrepared");
R : PGresult;
begin
Clear (Res); -- Free previous results
if Params'Length = 0 then
R := PQexecPrepared (DB.Connection, Stmt_Name & ASCII.NUL);
else
declare
Vals : aliased CS.chars_ptr_array (0 .. Params'Length - 1);
begin
for P in Vals'Range loop
Vals (P) := CS.New_String
(Params (Integer (P) + Params'First).Image (Format));
end loop;
R := PQexecPrepared
(DB.Connection,
Stmt_Name & ASCII.NUL,
Nparams => Vals'Length,
Values => Vals (0)'Address);
for P in Vals'Range loop
CS.Free (Vals (P));
end loop;
end;
end if;
Res.Res := R;
end Exec_Prepared;
-----------------
-- BLOB_Create --
-----------------
function BLOB_Create
(DB : Database'Class; Mode : File_Mode) return OID
is
function LO_Creat (Conn : PGconnection; Mode : C.int) return OID;
pragma Import (C, LO_Creat, "lo_creat");
begin
return LO_Creat (DB.Connection, C.int (Mode));
end BLOB_Create;
-----------------
-- BLOB_Import --
-----------------
function BLOB_Import (DB : Database'Class;
In_File_Name : String) return OID
is
function LO_Import (Conn : PGconnection; File : chars_ptr) return OID;
pragma Import (C, LO_Import, "lo_import");
P : chars_ptr := CS.New_String (In_File_Name);
Obj_Id : constant OID := LO_Import (DB.Connection, P);
begin
CS.Free (P);
return Obj_Id;
end BLOB_Import;
-----------------
-- BLOB_Export --
-----------------
function BLOB_Export (DB : Database'Class;
Object_Id : OID;
Out_File_Name : String) return Boolean
is
function LO_Export (Conn : PGconnection;
Obj_Id : OID;
File : chars_ptr) return C.int;
pragma Import (C, LO_Export, "lo_export");
P : chars_ptr := CS.New_String (Out_File_Name);
B : constant Boolean := LO_Export (DB.Connection, Object_Id, P) >= 0;
begin
CS.Free (P);
return B;
end BLOB_Export;
---------------
-- BLOB_Open --
---------------
function BLOB_Open (DB : Database'Class;
Object_Id : OID;
Mode : File_Mode)
return File_Descriptor
is
function LO_Open (Conn : PGconnection;
Obj_Id : OID;
Mode : C.int) return Integer;
pragma Import (C, LO_Open, "lo_open");
begin
return File_Descriptor
(LO_Open (DB.Connection, Object_Id, C.int (Mode)));
end BLOB_Open;
----------------
-- BLOB_Write --
----------------
function BLOB_Write (DB : Database'Class;
FD : File_Descriptor;
A : System.Address;
N : Integer)
return Integer
is
function LO_Write (Conn : PGconnection;
FD : C.int;
A : System.Address;
N : C.int) return Integer;
pragma Import (C, LO_Write, "lo_write");
begin
return LO_Write (DB.Connection, C.int (FD), A, C.int (N));
end BLOB_Write;
---------------
-- BLOB_Read --
---------------
function BLOB_Read (DB : Database'Class;
FD : File_Descriptor;
A : System.Address;
N : Integer)
return Integer
is
function LO_Read (Conn : PGconnection;
FD : C.int;
A : System.Address;
N : C.int) return Integer;
pragma Import (C, LO_Read, "lo_read");
begin
return LO_Read (DB.Connection, C.int (FD), A, C.int (N));
end BLOB_Read;
----------------
-- BLOB_Lseek --
----------------
function BLOB_Lseek (DB : Database'Class;
FD : File_Descriptor;
Offset : Integer;
Origin : Integer)
return Integer
is
function LO_Lseek (Conn : PGconnection;
FD : C.int;
Offset : C.int;
Origin : C.int) return C.int;
pragma Import (C, LO_Lseek, "lo_lseek");
begin
return Integer
(LO_Lseek (DB.Connection, C.int (FD), C.int (Offset), C.int (Origin)));
end BLOB_Lseek;
---------------
-- BLOB_Tell --
---------------
function BLOB_Tell (DB : Database'Class;
FD : File_Descriptor)
return Integer
is
function LO_Tell (Conn : PGconnection; FD : C.int) return C.int;
pragma Import (C, LO_Tell, "lo_tell");
begin
return Integer (LO_Tell (DB.Connection, C.int (FD)));
end BLOB_Tell;
----------------
-- BLOB_Close --
----------------
function BLOB_Close (DB : Database'Class;
FD : File_Descriptor)
return Boolean
is
function LO_Close (Conn : PGconnection; FD : C.int) return C.int;
pragma Import (C, LO_Close, "lo_close");
begin
return LO_Close (DB.Connection, C.int (FD)) >= 0;
end BLOB_Close;
-----------------
-- BLOB_Unlink --
-----------------
function BLOB_Unlink (DB : Database'Class;
Object_Id : OID) return Boolean
is
function LO_Unlink (Conn : PGconnection; Object_Id : OID) return C.int;
pragma Import (C, LO_Unlink, "lo_unlink");
begin
return LO_Unlink (DB.Connection, Object_Id) >= 0;
end BLOB_Unlink;
-----------------------
-- Make_Empty_Result --
-----------------------
procedure Make_Empty_Result
(Res : out Result;
DB : Database'Class;
Status : ExecStatus := PGRES_EMPTY_QUERY)
is
function PQemptyRes (D : PGconnection; Status : C.int) return PGresult;
pragma Import (C, PQemptyRes, "PQmakeEmptyPGresult");
R : constant PGresult :=
PQemptyRes (DB.Connection, ExecStatus'Pos (Status));
begin
if R = Null_Result then
raise PostgreSQL_Error;
end if;
Res.Res := R;
end Make_Empty_Result;
-----------
-- Clear --
-----------
procedure Clear (Res : in out Result) is
procedure PQclear (Res : PGresult);
pragma Import (C, PQclear, "PQclear");
begin
if Res.Res /= Null_Result then
PQclear (Res.Res);
Res.Res := Null_Result;
end if;
end Clear;
------------
-- Status --
------------
function Status (Res : Result) return ExecStatus is
function PQresStatus (Res : PGresult) return Interfaces.C.int;
pragma Import (C, PQresStatus, "PQresultStatus");
begin
if Res.Res = Null_Result then
return PGRES_Null_Result;
else
return ExecStatus'Val (PQresStatus (Res.Res));
end if;
end Status;
------------
-- Status --
------------
function Status (Status : ExecStatus) return String is
function PQresStat (stat : Interfaces.C.int) return chars_ptr;
pragma Import (C, PQresStat, "PQresStatus");
begin
if Status = PGRES_Null_Result then
return "";
else
return CS.Value (PQresStat (ExecStatus'Pos (Status)));
end if;
end Status;
------------
-- Status --
------------
function Status (Res : Result) return String is
Stat : constant ExecStatus := Status (Res);
begin
return Status (Stat);
end Status;
-----------
-- Error --
-----------
function Error (Res : Result) return String is
function PQresErr (Res : PGresult) return chars_ptr;
pragma Import (C, PQresErr, "PQresultErrorMessage");
begin
return CS.Value (PQresErr (Res.Res));
end Error;
function Quote_Identifier (Identifier : String) return String is
begin
return '"' & Identifier & '"';
end Quote_Identifier;
-------------------
-- Info_Accessor --
-------------------
generic
with function Accessor (Res : PGresult) return C.int;
function Info_Accessor (Res : Result) return Integer;
function Info_Accessor (Res : Result) return Integer is
begin
return Integer (Accessor (Res.Res));
end Info_Accessor;
function PQntuples (Res : PGresult) return C.int;
pragma Import (C, PQntuples, "PQntuples");
function Get_Count is new Info_Accessor (Accessor => PQntuples);
function PQnfields (Res : PGresult) return C.int;
pragma Import (C, PQnfields, "PQnfields");
function Get_FCount is new Info_Accessor (Accessor => PQnfields);
function PQbinaryTuples (Res : PGresult) return C.int;
pragma Import (C, PQbinaryTuples, "PQbinaryTuples");
function Get_BinaryTuples is new Info_Accessor (Accessor => PQbinaryTuples);
-----------------
-- Tuple_Count --
-----------------
function Tuple_Count (Res : Result) return Tuple_Index is
begin
return Tuple_Index (Get_Count (Res));
end Tuple_Count;
-----------------
-- Field_Count --
-----------------
function Field_Count (Res : Result) return Field_Index is
begin
return Field_Index (Get_FCount (Res));
end Field_Count;
----------------
-- Field_Name --
----------------
function Field_Name (Res : Result; Index : Field_Index) return String is
function PQfname (Res : PGresult; Idx : C.int) return chars_ptr;
pragma Import (C, PQfname, "PQfname");
begin
return CS.Value (PQfname (Res.Res, C.int (Index)));
end Field_Name;
------------------
-- Field_Lookup --
------------------
procedure Field_Lookup (Res : Result;
Name : String;
Index : out Field_Index;
Found : out Boolean)
is
function PQfnumber (Res : PGresult; Name : chars_ptr) return C.int;
pragma Import (C, PQfnumber, "PQfnumber");
P : chars_ptr := CS.New_String (Name);
I : constant C.int := PQfnumber (Res.Res, P);
begin
CS.Free (P);
if I < 0 then
Found := False;
Index := Field_Index'Last;
else
Found := True;
Index := Field_Index (I);
end if;
end Field_Lookup;
---------------
-- Is_Binary --
---------------
function Is_Binary (Res : Result) return Boolean is
begin
return Get_BinaryTuples (Res) /= 0;
end Is_Binary;
----------------
-- Field_Type --
----------------
function Field_Type
(Res : Result; Index : Field_Index) return TypeID
is
function PQftype (Res : PGresult; Idx : C.int) return TypeID;
pragma Import (C, PQftype, "PQftype");
begin
return PQftype (Res.Res, C.int (Index));
end Field_Type;
-----------
-- Value --
-----------
procedure Value (Res : Result;
Tuple : Tuple_Index;
Field : Field_Index;
Pointer : out System.Address)
is
function Cvt is new Ada.Unchecked_Conversion (chars_ptr, System.Address);
function PQgetvalue (Res : PGresult;
Tuple : C.int;
Field : C.int) return chars_ptr;
pragma Import (C, PQgetvalue, "PQgetvalue");
P : constant chars_ptr :=
PQgetvalue (Res.Res, C.int (Tuple), C.int (Field));
begin
Pointer := Cvt (P);
end Value;
-------------
-- C_Value --
-------------
function C_Value
(Res : Result;
Tuple : Tuple_Index := 0;
Field : Field_Index := 0) return Interfaces.C.Strings.chars_ptr
is
function PQgetvalue (Res : PGresult;
Tuple : C.int;
Field : C.int) return chars_ptr;
pragma Import (C, PQgetvalue, "PQgetvalue");
begin
return PQgetvalue (Res.Res, C.int (Tuple), C.int (Field));
end C_Value;
-----------
-- Value --
-----------
function Value (Res : Result;
Tuple : Tuple_Index := 0;
Field : Field_Index := 0) return String
is
function PQgetvalue
(Res : PGresult; Tuple, Field : C.int) return chars_ptr;
pragma Import (C, PQgetvalue, "PQgetvalue");
P : constant chars_ptr :=
PQgetvalue (Res.Res, C.int (Tuple), C.int (Field));
begin
if Is_Binary (Res) then
raise PostgreSQL_Error;
end if;
return CS.Value (P);
end Value;
-------------------
-- Boolean_Value --
-------------------
function Boolean_Value (Res : Result;
Tuple : Tuple_Index := 0;
Field : Field_Index := 0) return Boolean is
begin
return Value (Res, Tuple, Field) = "t";
end Boolean_Value;
-----------
-- Value --
-----------
function Value (Res : Result;
Tuple : Tuple_Index := 0;
Field_Name : String) return String
is
Found : Boolean;
Idx : Field_Index;
begin
Field_Lookup (Res, Field_Name, Idx, Found);
if Found then
return Value (Res, Tuple, Idx);
else
raise PostgreSQL_Error;
end if;
end Value;
-------------------
-- Boolean_Value --
-------------------
function Boolean_Value (Res : Result;
Tuple : Tuple_Index := 0;
Field_Name : String) return Boolean is
begin
return Value (Res, Tuple, Field_Name) = "t";
end Boolean_Value;
-------------------
-- Integer_Value --
-------------------
function Integer_Value (Res : Result;
Tuple : Tuple_Index := 0;
Field : Field_Index := 0;
Default : Integer := Integer'First) return Integer
is
begin
return Integer'Value (Value (Res, Tuple, Field));
exception
when Constraint_Error =>
if Default = Integer'First then
raise PostgreSQL_Error;
else
return Default;
end if;
end Integer_Value;
----------------
-- Field_Size --
----------------
function Field_Size
(Res : Result; Field : Field_Index) return Integer
is
function PQfsize (Res : PGresult; Idx : C.int) return C.int;
pragma Import (C, PQfsize, "PQfsize");
begin
return Integer (PQfsize (Res.Res, C.int (Field)));
end Field_Size;
------------------------
-- Field_Modification --
------------------------
function Field_Modification
(Res : Result; Field : Field_Index) return Integer
is
function PQfmod (Res : PGresult; Idx : C.int) return C.int;
pragma Import (C, PQfmod, "PQfmod");
begin
return Integer (PQfmod (Res.Res, C.int (Field)));
end Field_Modification;
------------------
-- Field_Length --
------------------
function Field_Length
(Res : Result; Tuple : Tuple_Index; Field : Field_Index) return Natural
is
function PQgetlen (Res : PGresult; Row, Idx : C.int) return C.int;
pragma Import (C, PQgetlen, "PQgetlength");
begin
return Natural (PQgetlen (Res.Res, C.int (Tuple), C.int (Field)));
end Field_Length;
-------------
-- Is_Null --
-------------
function Is_Null
(Res : Result;
Tuple : Tuple_Index;
Field : Field_Index) return Boolean
is
function PQisnull (Res : PGresult; Row, Idx : C.int) return C.int;
pragma Import (C, PQisnull, "PQgetisnull");
begin
return PQisnull (Res.Res, C.int (Tuple), C.int (Field)) /= 0;
end Is_Null;
--------------------
-- Command_Status --
--------------------
function Command_Status (Res : Result) return String is
function PQcmdStatus (Res : PGresult) return chars_ptr;
pragma Import (C, PQcmdStatus, "PQcmdStatus");
begin
return CS.Value (PQcmdStatus (Res.Res));
end Command_Status;
--------------------
-- Command_Tuples --
--------------------
function Command_Tuples (Res : Result) return String is
function PQcmdTuples (Res : PGresult) return chars_ptr;
pragma Import (C, PQcmdTuples, "PQcmdTuples");
begin
return CS.Value (PQcmdTuples (Res.Res));
end Command_Tuples;
--------------------
-- Command_Tuples --
--------------------
function Command_Tuples (Res : Result) return Natural is
S : constant String := Command_Tuples (Res);
begin
if S = "" then
return 0;
else
return Natural'Value (S);
end if;
end Command_Tuples;
---------------
-- OID_Value --
---------------
function OID_Value (Res : Result) return OID is
function PQoidValue (Res : PGresult) return OID;
pragma Import (C, PQoidValue, "PQoidValue");
begin
return PQoidValue (Res.Res);
end OID_Value;
---------------------
-- Is_Non_Blocking --
---------------------
function Is_Non_Blocking (DB : Database'Class) return Boolean is
function PQisnonblocking (Conn : PGconnection) return C.int;
pragma Import (C, PQisnonblocking, "PQisnonblocking");
begin
return PQisnonblocking (DB.Connection) /= 0;
end Is_Non_Blocking;
----------------
-- Send_Query --
----------------
function Send_Query
(DB : Database'Class; Query : String) return Boolean
is
function PQsendQuery (Conn : PGconnection; Qry : String) return C.int;
pragma Import (C, PQsendQuery, "PQsendQuery");
begin
return PQsendQuery (DB.Connection, Query & ASCII.NUL) /= 0;
end Send_Query;
----------------
-- Get_Result --
----------------
procedure Get_Result (DB : Database'Class;
Res : out Result;
Done : out Boolean)
is
function PQgetResult (Conn : PGconnection) return PGresult;
pragma Import (C, PQgetResult, "PQgetResult");
R : constant PGresult := PQgetResult (DB.Connection);
begin
Res.Res := R;
Done := R = Null_Result;
end Get_Result;
-------------------
-- Consume_Input --
-------------------
function Consume_Input (DB : Database'Class) return Boolean is
function PQconsumeInput (Conn : PGconnection) return C.int;
pragma Import (C, PQconsumeInput, "PQconsumeInput");
begin
return PQconsumeInput (DB.Connection) /= 0;
end Consume_Input;
-----------
-- Flush --
-----------
function Flush (DB : Database'Class) return Boolean is
function PQflush (Conn : PGconnection) return C.int;
pragma Import (C, PQflush, "PQflush");
begin
return PQflush (DB.Connection) = 0;
end Flush;
-------------
-- Is_Busy --
-------------
function Is_Busy (DB : Database'Class) return Boolean is
function PQisBusy (Conn : PGconnection) return C.int;
pragma Import (C, PQisBusy, "PQisBusy");
begin
return PQisBusy (DB.Connection) /= 0;
end Is_Busy;
--------------------
-- Request_Cancel --
--------------------
function Request_Cancel (DB : Database'Class) return Boolean is
function PQrequestCancel (Conn : PGconnection) return C.int;
pragma Import (C, PQrequestCancel, "PQrequestCancel");
begin
return PQrequestCancel (DB.Connection) /= 0;
end Request_Cancel;
------------
-- Socket --
------------
function Socket (DB : Database'Class) return Interfaces.C.int is
function PQsocket (Conn : PGconnection) return C.int;
pragma Import (C, PQsocket, "PQsocket");
begin
return PQsocket (DB.Connection);
end Socket;
--------------
-- Notifies --
--------------
procedure Notifies (DB : Database'Class;
Message : out Notification;
Done : out Boolean)
is
type pgNotify is record
relname : CS.chars_ptr;
be_pid : Backend_PID;
extra : CS.chars_ptr;
end record;
pragma Convention (C, pgNotify);
function PQnotifies (Conn : PGconnection) return access pgNotify;
pragma Import (C, PQnotifies, "PQnotifies");
procedure PQ_Free (Addr : access pgNotify);
pragma Import (C, PQ_Free, "PQfreemem");
N : constant access pgNotify := PQnotifies (DB.Connection);
begin
Done := N = null;
if not Done then
Message.Channel_Name := To_XString (CS.Value (N.relname));
Message.Payload := To_XString (CS.Value (N.extra));
Message.Notifier_PID := Integer (N.be_pid);
PQ_Free (N);
end if;
end Notifies;
-----------------
-- Array_Field --
-----------------
function Array_Field (Value : String; Field : Positive) return String is
Pos : Integer := Value'First + 1;
Last : Integer;
Index : Positive := 1;
begin
if Value (Value'First) = '{' then
while Pos <= Value'Last loop
Last := Pos + 1;
-- Will raise Constraint_Error in the end
while Value (Last) /= '}' and then Value (Last) /= ',' loop
Last := Last + 1;
end loop;
if Field = Index then
return Value (Pos .. Last - 1);
end if;
Index := Index + 1;
Pos := Last + 1;
end loop;
end if;
raise Constraint_Error;
end Array_Field;
end GNATCOLL.SQL.Postgres.Gnade;