Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
873 lines (809 sloc) 20.4 KB
unit LibPQData;
{
LibPQData: thin LibPQ wrapper to connect to a PostgreSQL server.
https://github.com/stijnsanders/DataLank
ATTENTION:
Include following files in the folder that contains the executable,
or in a folder included in the default DLL search path.
They are provided with the Windows PostgreSQL server install.
ssleay32.dll
libeay32.dll
libiconv-2.dll
libintl-8.dll
libpq.dll
}
interface
//debugging: prevent step-into from debugging TQueryResult calls:
{$D-}
{$L-}
{$DEFINE LIBPQDATA_TRANSFORMQM}
uses SysUtils, LibPQ;
type
TPostgresConnection=class(TObject)
private
FDB:PGConn;
procedure Exec(const SQL:UTF8String);
public
constructor Create(const ConnectionInfo: WideString);
destructor Destroy; override;
procedure BeginTrans;
procedure CommitTrans;
procedure RollbackTrans;
function Execute(const SQL: WideString;
const Values: array of OleVariant): integer;
function Insert(const TableName: UTF8String; const Values: array of OleVariant;
const PKFieldName: UTF8String=''): int64;
procedure Update(const TableName: UTF8String; const Values:array of OleVariant);
end;
TPostgresCommand=class(TObject)
private
FFirstRead:boolean;
function GetValue(Idx:OleVariant):OleVariant;
function IsEof:boolean;
function GetCount:integer;
protected
FDB:PGConn;
FRecordSet:PGResult;
FTuple:integer;
public
constructor Create(Connection: TPostgresConnection; const SQL: WideString;
const Values: array of OleVariant);
destructor Destroy; override;
procedure Reset;
function Read:boolean;
property Fields[Idx:OleVariant]:OleVariant read GetValue; default;
property EOF: boolean read IsEof;
property Count: integer read GetCount;
function GetInt(Idx:OleVariant):integer;
function GetStr(Idx:OleVariant):WideString;
function GetDate(Idx:OleVariant):TDateTime;
function IsNull(Idx:OleVariant):boolean;
end;
EPostgres=class(Exception);
EQueryResultError=class(Exception);
function RefCursor(const CursorName:WideString):OleVariant;
implementation
uses Variants;
//hardcoded object ID's (defined by \include\server\catalog\pg_type.h)
const
Oid_bool = 16; //boolean, 'true'/'false'
Oid_bytea = 17; //variable-length string, binary values escaped
Oid_int8 = 20; //~18 digit integer, 8-byte storage
Oid_int2 = 21; //-32 thousand to 32 thousand, 2-byte storage
Oid_int4 = 23; //-2 billion to 2 billion integer, 4-byte storage
Oid_text = 25; //variable-length string, no limit specified
Oid_xml = 142; //XML content
Oid_float4 = 700; //single-precision floating point number, 4-byte storage
Oid_float8 = 701; //double-precision floating point number, 8-byte storage
Oid_unknown = 705; //(used with varNull below)
Oid_money = 790; //monetary amounts, $d,ddd.cc
Oid_bpchar = 1042; //char(length), blank-padded string, fixed storage length
Oid_varchar = 1043; //varchar(length), non-blank-padded string, variable storage length
Oid_date = 1082; //date
Oid_time = 1083; //time of day
Oid_timestamp = 1114; //date and time
Oid_timestamptz = 1184; //date and time with time zone
Oid_numeric = 1700; //numeric(precision, decimal), arbitrary precision number
Oid_refcursor = 1790; //reference to cursor (portal name)
Oid_uuid = 2950; //UUID datatype
var
RefCursorCatch:OleVariant;//see initialization
function RefCursor(const CursorName:WideString):OleVariant;
begin
//assert: caller does transaction!
//package a bespoke array with a reference to secret fixed thing,
//see AddParam that check this when VarType=varArray or varVariant
Result:=VarArrayCreate([0,1],varVariant);
Result[0]:=VarArrayRef(RefCursorCatch);
Result[1]:=CursorName;
end;
function AddParam(const v: OleVariant; var vt: Oid; var vs: UTF8String;
var vv: pointer; var vl: integer; var vf: integer): boolean;
var
ods:Char;
rds:PChar;
d:TDateTime;
const
NullStr:AnsiString=#0;
begin
rds:=@{$IFDEF DELPHIXE_UP}FormatSettings.{$ENDIF}DecimalSeparator;
Result:=true;//default
//TODO: varArray
case VarType(v) of
varEmpty,varNull:
begin
vt:=Oid_unknown;
vs:='';
vv:=nil;
vl:=0;
vf:=0;
end;
varSmallint,varShortInt,varByte,varWord:
begin
vt:=Oid_int2;
vs:=AnsiString(VarToStr(v));//IntToStr?
vv:=@vs[1];
vl:=Length(vs);
vf:=0;
end;
varInteger,varLongWord:
begin
vt:=Oid_int4;
vs:=AnsiString(VarToStr(v));//IntToStr?
vv:=@vs[1];
vl:=Length(vs);
vf:=0;
end;
varInt64,$15{varUInt64}:
begin
vt:=Oid_int8;
vs:=AnsiString(VarToStr(v));//IntToStr64?
vv:=@vs[1];
vl:=Length(vs);
vf:=0;
end;
varSingle:
begin
ods:=rds^;
rds^:='.';
try
vt:=Oid_float4;
vs:=AnsiString(FloatToStr(v));
vv:=@vs[1];
vl:=Length(vs);
vf:=0;
finally
rds^:=ods;
end;
end;
varDouble,$E{varDecimal}:
begin
ods:=rds^;
rds^:='.';
try
vt:=Oid_float8;
vs:=AnsiString(FloatToStr(v));
vv:=@vs[1];
vl:=Length(vs);
vf:=0;
finally
rds^:=ods;
end;
end;
varCurrency:
begin
ods:=rds^;
rds^:='.';
try
vt:=Oid_money;
vs:=AnsiString(FloatToStr(v));
vv:=@vs[1];
vl:=Length(vs);
vf:=0;
finally
rds^:=ods;
end;
end;
varDate:
begin
d:=VarToDateTime(v);
vt:=Oid_timestamp;//?
if d=0.0 then
begin
vs:='';
vv:=nil;
vl:=0;
end
else
begin
vs:=AnsiString(FormatDateTime('yyyy-mm-dd hh:nn:ss.zzz',d));
vv:=@vs[1];
vl:=Length(vs);
end;
vf:=0;
end;
varOleStr,varString:
begin
vt:=Oid_varchar;//?Oid_text?
vs:=UTF8Encode(VarToWideStr(v));
if vs='' then vv:=@NullStr[1] else vv:=@vs[1];
vl:=Length(vs);
vf:=0;
end;
{
varDispatch,varUnknown:
begin
//check is XML doc?
vt:=Oid_xml;
vs:=UTF8Encode((IUnknown(v) as IXMLDOMNode).xml);
vv:=@vs[1];
vl:=Length(vs);
vf:=0;
end;
}
varBoolean:
begin
vt:=Oid_bool;
if v then vs:='t' else vs:='f';
vv:=@vs[1];
vl:=1;//Length(vs);
vf:=0;
end;
//varVariant...
//varRecord?
varStrArg:
begin
vt:=Oid_uuid;
vs:=UTF8Encode(VarToWideStr(v));
vv:=@vs[1];
vl:=Length(vs);
vf:=0;
end;
//varObject?
//varUStrArg?
//varAny?
//varUString?
varArray or varVariant:
if (VarArrayLowBound(v,1)=0) and (VarArrayHighBound(v,1)=1)
and (TVarData(v[0]).VPointer=@TVarData(RefCursorCatch).VArray) then
begin
vt:=Oid_refcursor;
vs:=UTF8Encode(VarToWideStr(v[1]));
vv:=@vs[1];
vl:=Length(vs);
vf:=0;
end
else
Result:=false;
else
Result:=false;
end;
end;
{$IF not Declared(UTF8ToWideString)}
function UTF8ToWideString(const s: UTF8String): WideString;
begin
Result:=UTF8Decode(s);
end;
{$IFEND}
function PrepSQL(const SQL: UTF8String): PAnsiChar;
var
s:string;
i,j,k,l:integer;
begin
{$IFDEF LIBPQDATA_TRANSFORMQM}
i:=1;
j:=1;
k:=0;
l:=Length(SQL);
SetLength(s,l*2);
while (i<=l) do
begin
while (i<=l) and (SQL[i]<>'?') do
begin
s[j]:=SQL[i];
inc(i);
inc(j);
end;
if i<=l then
begin
s[j]:='$';
inc(i);
inc(j);
inc(k);
if k<10 then
begin
s[j]:=AnsiChar(k or $30);
inc(j);
end
else
if k<100 then
begin
s[j]:=AnsiChar((k div 10) or $30);
inc(j);
s[j]:=AnsiChar((k mod 10) or $30);
inc(j);
end
else
raise EPostgres.Create('Maximum number of question marks exceeded');
end;
end;
SetLength(s,j-1);
Result:=@s[1];
{$ELSE}
Result:=@SQL[1];
{$ENDIF}
end;
procedure SendQuery(DB: PGConn; const SQL: UTF8String;
const Values: array of OleVariant);
var
i:integer;
pn:integer;
pt:array of Oid;
ps:array of UTF8String;
pv:array of pointer;
pl:array of integer;
pf:array of integer;
begin
pn:=Length(Values);
if pn=0 then
begin
if PQsendQuery(DB,PrepSQL(SQL))=0 then
raise EPostgres.Create(UTF8ToWideString(PQerrorMessage(DB)));
end
else
begin
SetLength(pt,pn);
SetLength(ps,pn);
SetLength(pv,pn);
SetLength(pl,pn);
SetLength(pf,pn);
for i:=0 to pn-1 do
if not AddParam(Values[i],pt[i],ps[i],pv[i],pl[i],pf[i]) then
raise Exception.Create('Unsupported Parameter Type: #'+IntToStr(i+1));
if PQsendQueryParams(DB,PrepSQL(SQL),pn,@pt[0],@pv[0],@pl[0],@pf[0],0)=0 then
raise EPostgres.Create(UTF8ToWideString(PQerrorMessage(DB)));
end;
end;
{ TPostgresConnection }
constructor TPostgresConnection.Create(const ConnectionInfo: WideString);
var
s,e:UTF8String;
begin
inherited Create;
s:=UTF8Encode(ConnectionInfo);
FDB:=PQconnectdb(@s[1]);
if FDB.Handle=nil then
raise EPostgres.Create('Connect failed');
e:=PQerrorMessage(FDB);
if e<>'' then
raise EPostgres.Create(UTF8ToWideString(e));
end;
destructor TPostgresConnection.Destroy;
begin
if FDB.Handle<>nil then
begin
PQfinish(FDB);
FDB.Handle:=nil;
end;
inherited;
end;
procedure TPostgresConnection.Exec(const SQL: UTF8String);
var
r:PGResult;
e:UTF8String;
begin
r:=PQexec(FDB,@SQL[1]);
if r.Handle=nil then
raise EPostgres.Create('Exec error '+UTF8ToWideString(PQerrorMessage(FDB)));
try
e:=PQresultErrorMessage(r);
if e<>'' then
raise EPostgres.Create(UTF8ToWideString(e));
finally
PQclear(r);
end;
end;
procedure TPostgresConnection.BeginTrans;
begin
Exec('begin');
//TODO: support savepoints
end;
procedure TPostgresConnection.CommitTrans;
begin
Exec('commit');
end;
procedure TPostgresConnection.RollbackTrans;
begin
Exec('rollback');
end;
function TPostgresConnection.Execute(const SQL: WideString;
const Values: array of OleVariant): integer;
var
r:PGResult;
s,e:UTF8String;
i:integer;
begin
try
SendQuery(FDB,UTF8Encode(SQL),Values);
Result:=0;//see below
r:=PQgetResult(FDB);
if r.Handle=nil then
e:=PQerrorMessage(FDB)
else
e:=PQresultErrorMessage(r);
if e<>'' then
raise EPostgres.Create(UTF8ToWideString(e));
while r.Handle<>nil do
begin
s:=PQcmdTuples(r);
if s<>'' then
if TryStrToInt(string(s),i) then inc(Result,i) else
raise EPostgres.Create('Unexpected Tuples Response: "'+
UTF8ToWideString(s)+'"');
PQclear(r);
r:=PQgetResult(FDB);
if r.Handle<>nil then
begin
e:=PQresultErrorMessage(r);
if e<>'' then
raise EPostgres.Create(UTF8ToWideString(e));
end;
end;
except
on e:Exception do
begin
r:=PQgetResult(FDB);
while r.Handle<>nil do
begin
PQclear(r);
r:=PQgetResult(FDB);
end;
raise;
end;
end;
end;
function TPostgresConnection.Insert(const TableName: UTF8String;
const Values: array of OleVariant; const PKFieldName: UTF8String=''): int64;
var
r:PGResult;
i,l:integer;
pn:integer;
pt:array of Oid;
ps:array of UTF8String;
pv:array of pointer;
pl:array of integer;
pf:array of integer;
sql1,sql2,e:UTF8String;
begin
sql1:='';
sql2:='';
l:=Length(Values);
if (l and 1)<>0 then
raise EQueryResultError.Create('Insert('''+string(TableName)+''') requires an even number of values');
pn:=l div 2;
SetLength(pt,pn);
SetLength(ps,pn);
SetLength(pv,pn);
SetLength(pl,pn);
SetLength(pf,pn);
pn:=0;//re-count, see below
i:=1;
while i<l do
begin
if not VarIsNull(Values[i]) then
begin
sql1:=sql1+','+UTF8Encode(VarToWideStr(Values[i-1]));
if not AddParam(Values[i],pt[pn],ps[pn],pv[pn],pl[pn],pf[pn]) then
raise Exception.Create('Unsupported Parameter Type: TableName="'+string(TableName)+'" #'+IntToStr((i div 2)+1));
inc(pn);
sql2:=sql2+',$'+AnsiString(IntToStr(pn));
end;
inc(i,2);
end;
//TODO: check TableName,Values[i*2] on sql-safe!
sql1[1]:='(';
sql2[1]:='(';
if PKFieldName='' then
sql2:=sql2+')'
else
sql2:=sql2+') returning '+PKFieldName;
sql1:='insert into '+TableName+' '+sql1+') values '+sql2;
if PQsendQueryParams(FDB,@sql1[1],pn,@pt[0],@pv[0],@pl[0],@pf[0],0)=0 then
raise EPostgres.Create(UTF8ToWideString(PQerrorMessage(FDB)));
r:=PQgetResult(FDB);
if r.Handle=nil then
e:=PQerrorMessage(FDB)
else
e:=PQresultErrorMessage(r);
if e<>'' then
raise EPostgres.Create(UTF8ToWideString(e));
e:=PQgetvalue(r,0,0);
if e='' then Result:=-1 else Result:=StrToInt64(string(e));
while r.Handle<>nil do
begin
PQclear(r);
r:=PQgetResult(FDB);
end;
end;
procedure TPostgresConnection.Update(const TableName: UTF8String; const Values: array of OleVariant);
var
r:PGResult;
i,l:integer;
pn:integer;
pt:array of Oid;
ps:array of UTF8String;
pv:array of pointer;
pl:array of integer;
pf:array of integer;
sql1,sql2,e:UTF8String;
begin
sql1:='';
sql2:='';
l:=Length(Values);
if (l and 1)<>0 then
raise EQueryResultError.Create('Update('''+string(TableName)+''') requires an even number of values');
pn:=l div 2;
SetLength(pt,pn);
SetLength(ps,pn);
SetLength(pv,pn);
SetLength(pl,pn);
SetLength(pf,pn);
pn:=0;//re-count, see below
i:=1;
while i<l do
begin
if not VarIsNull(Values[i]) then
begin
if not AddParam(Values[i],pt[pn],ps[pn],pv[pn],pl[pn],pf[pn]) then
raise Exception.Create('Unsupported Parameter Type: TableName="'+string(TableName)+'" #'+IntToStr((i div 2)+1));
inc(pn);
if pn=1 then
sql2:=' where '+UTF8Encode(VarToWideStr(Values[i-1]))+'=$1'//'+IntToStr(i)
else
sql1:=sql1+','+UTF8Encode(VarToWideStr(Values[i-1]))+'=$'+AnsiString(IntToStr(pn));
end;
inc(i,2);
end;
sql1[1]:=' ';
sql1:='update '+TableName+' set'+sql1+sql2;
if PQsendQueryParams(FDB,@sql1[1],pn,@pt[0],@pv[0],@pl[0],@pf[0],0)=0 then
raise EPostgres.Create(UTF8ToWideString(PQerrorMessage(FDB)));
r:=PQgetResult(FDB);
if r.Handle=nil then
e:=PQerrorMessage(FDB)
else
e:=PQresultErrorMessage(r);
if e<>'' then
raise EPostgres.Create(UTF8ToWideString(e));
while r.Handle<>nil do
begin
PQclear(r);
r:=PQgetResult(FDB);
end;
end;
{ TPostgresCommand }
constructor TPostgresCommand.Create(Connection: TPostgresConnection;
const SQL: WideString; const Values: array of OleVariant);
var
e:UTF8String;
r:PGResult;
begin
inherited Create;
//TODO: check PQisbusy?
try
FDB:=Connection.FDB;
SendQuery(FDB,UTF8Encode(SQL),Values);
//PQsetSingleRowMode(QueryDbConLive); //TODO!!
FTuple:=0;
FRecordSet:=PQgetResult(FDB);
if FRecordSet.Handle=nil then
e:=PQerrorMessage(FDB)
else
e:=PQresultErrorMessage(FRecordSet);
if e<>'' then
raise EPostgres.Create(UTF8ToWideString(e));
FFirstRead:=true;
finally
r:=PQgetResult(FDB);
while r.Handle<>nil do
begin
PQclear(r);
r:=PQgetResult(FDB);
end;
end;
end;
destructor TPostgresCommand.Destroy;
begin
while FRecordSet.Handle<>nil do
begin
PQclear(FRecordSet);
FRecordSet:=PQgetResult(FDB);
end;
inherited;
end;
function TPostgresCommand.Read: boolean;
begin
if (FRecordSet.Handle=nil) or (PQntuples(FRecordSet)=FTuple) then Result:=false else
begin
if FFirstRead then FFirstRead:=false else
begin
{if streaming then
begin
if FRecordSet<>nil then PQclear(FRecordSet);
FRecordSet:=PQgetResult(FRecordSet);
end
else
}
inc(FTuple);
end;
Result:=not((FRecordSet.Handle=nil) or (PQntuples(FRecordSet)=FTuple));
end;
end;
procedure TPostgresCommand.Reset;
begin
FFirstRead:=true;
if FTuple<>0 then FTuple:=0;
end;
function TPostgresCommand.GetInt(Idx: OleVariant): integer;
var
i:integer;
s:UTF8String;
begin
if VarIsNumeric(Idx) then i:=Idx else
begin
s:=AnsiString(VarToStr(Idx));
i:=PQfnumber(FRecordSet,@s[1]);
end;
if i=-1 then
raise EQueryResultError.Create('GetInt: Field not found: '+VarToStr(Idx));
if PQgetisnull(FRecordSet,FTuple,i)=0 then
Result:=StrToInt(string(PQgetvalue(FRecordSet,FTuple,i)))
else
Result:=0;//?
end;
function TPostgresCommand.GetStr(Idx: OleVariant): WideString;
var
i:integer;
s:UTF8String;
begin
if VarIsNumeric(Idx) then i:=Idx else
begin
s:=AnsiString(VarToStr(Idx));
i:=PQfnumber(FRecordSet,@s[1]);
end;
if i=-1 then
raise EQueryResultError.Create('GetStr: Field not found: '+VarToStr(Idx));
if PQgetisnull(FRecordSet,FTuple,i)=0 then
Result:=UTF8ToWideString(PQgetvalue(FRecordSet,FTuple,i))
else
Result:='';//?
end;
function TPostgresCommand.GetDate(Idx: OleVariant): TDateTime;
var
i,l,f:integer;
dy,dm,dd,th,tm,ts,tz:word;
s:UTF8String;
function Next:word;
begin
Result:=0;
while (i<=l) and (s[i] in ['0'..'9']) do
begin
Result:=Result*10+(byte(s[i]) and $F);
inc(i);
end;
end;
begin
if VarIsNumeric(Idx) then i:=Idx else
begin
s:=AnsiString(VarToStr(Idx));
i:=PQfnumber(FRecordSet,@s[1]);
end;
if i=-1 then
raise EQueryResultError.Create('GetDate: Field not found: '+VarToStr(Idx));
if PQgetisnull(FRecordSet,FTuple,i)=0 then
begin
s:=PQgetvalue(FRecordSet,FTuple,i);
i:=1;
l:=Length(s);
dy:=Next;
inc(i);//'-'
dm:=Next;
inc(i);//'-'
dd:=Next;
inc(i);//' '
th:=Next;
inc(i);//':'
tm:=Next;
inc(i);//':'
ts:=Next;
inc(i);//'.'
tz:=0;//Next;//more precision than milliseconds here, encode floating:
f:=24*60*60;
Result:=0.0;
while (i<=l) and (s[i] in ['0'..'9']) do
begin
f:=f*10;
Result:=Result+(byte(s[i]) and $F)/f;
inc(i);
end;
//assert i>l
Result:=EncodeDate(dy,dm,dd)+EncodeTime(th,tm,ts,tz)+Result;
end
else
Result:=0;//Now?
end;
function TPostgresCommand.GetValue(Idx: OleVariant): OleVariant;
var
i:integer;
s:UTF8String;
ods:char;
rds:PChar;
begin
rds:=@{$IFDEF DELPHIXE_UP}FormatSettings.{$ENDIF}DecimalSeparator;
if VarIsNumeric(Idx) then i:=Idx else
begin
s:=AnsiString(VarToStr(Idx));
i:=PQfnumber(FRecordSet,@s[1]);
end;
if i=-1 then
raise EQueryResultError.Create('Field not found: '+VarToStr(Idx));
if PQgetisnull(FRecordSet,FTuple,i)=0 then
begin
s:=PQgetvalue(FRecordSet,FTuple,i);
case PQftype(FRecordset,i) of
Oid_bool:Result:=s='t';
//Oid_bytea
Oid_int8:Result:=StrToInt64(string(s));
Oid_int2:Result:=Word(StrToInt(string(s)));
Oid_int4:Result:=StrToInt(string(s));
{
Oid_xml:
begin
d:=CreateComObject(CLASS_DOMDocument60) as DOMDocument60;
d.async:=false;
d.preserveWhiteSpace:=true;//?
if not d.loadXML(UTF8ToWideString(s)) then
raise EQueryResultError.Create('Field holds invalid XML: '+VarToStr(Idx)+' '+d.parseError.reason);
Result:=d;
end;
}
Oid_float4,Oid_float8,Oid_numeric:
begin
ods:=rds^;
rds^:='.';
try
Result:=StrToFloat(string(s));
finally
rds^:=ods;
end;
end;
Oid_money:
begin
ods:=rds^;
rds^:='.';
try
Result:=StrToCurr(string(s));
finally
rds^:=ods;
end;
end;
Oid_bpchar,Oid_varchar,Oid_text:Result:=UTF8ToWideString(s);
//Oid_date
//Oid_time
Oid_timestamp:Result:=GetDate(Idx);
//Oid_timestamptz
//Oid_uuid
else
raise EQueryResultError.Create('Unsupported result type oid='+
IntToStr(PQftype(FRecordset,i))+': '+VarToStr(Idx));
end;
end
else
Result:=Null;
end;
function TPostgresCommand.IsNull(Idx: OleVariant): boolean;
var
i:integer;
s:UTF8String;
begin
if VarIsNumeric(Idx) then i:=Idx else
begin
s:=AnsiString(VarToStr(Idx));
i:=PQfnumber(FRecordSet,@s[1]);
end;
if i=-1 then
raise EQueryResultError.Create('IsNull: Field not found: '+VarToStr(Idx));
Result:=PQgetisnull(FRecordSet,FTuple,i)<>0;
end;
function TPostgresCommand.IsEof: boolean;
begin
Result:=(FRecordSet.Handle=nil) or (PQntuples(FRecordSet)=FTuple);
end;
function TPostgresCommand.GetCount: integer;
begin
if FRecordSet.Handle=nil then Result:=-1 else Result:=PQntuples(FRecordSet);
end;
initialization
//something fixed invalid, see function RefCursor
RefCursorCatch:=VarArrayCreate([0,0],varError);
end.