pqconnection.pp 49 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680
  1. unit PQConnection;
  2. {
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1999-2022 by Michael van Canney and other members of the
  5. Free Pascal development team
  6. Postgres database connection component
  7. See the file COPYING.FPC, included in this distribution,
  8. for details about the copyright.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  12. **********************************************************************}
  13. {$mode objfpc}{$H+}
  14. {$Define LinkDynamically}
  15. interface
  16. uses
  17. Classes, SysUtils, sqldb, db, dbconst,bufdataset,
  18. {$IfDef LinkDynamically}
  19. postgres3dyn;
  20. {$Else}
  21. postgres3;
  22. {$EndIf}
  23. type
  24. TPQCursor = Class;
  25. { TPQTrans }
  26. TPQTrans = Class(TSQLHandle)
  27. protected
  28. PGConn : PPGConn;
  29. FList : TThreadList;
  30. Procedure RegisterCursor(Cursor : TPQCursor);
  31. Procedure UnRegisterCursor(Cursor : TPQCursor);
  32. Public
  33. Constructor Create;
  34. Destructor Destroy; override;
  35. end;
  36. // TField and TFieldDef only support a limited amount of fields.
  37. // TFieldBinding and TExtendedFieldType can be used to map PQ types
  38. // on standard fields and retain mapping info.
  39. TExtendedFieldType = (eftNone,eftEnum,eftCitext);
  40. TFieldBinding = record
  41. FieldDef : TSQLDBFieldDef; // FieldDef this is associated with
  42. Index : Integer; // Tuple index
  43. TypeOID : oid; // Filled with type OID if it is not standard.
  44. TypeName : String; // Filled with type name by GetExtendedFieldInfo
  45. ExtendedFieldType: TExtendedFieldType; //
  46. end;
  47. PFieldBinding = ^TFieldBinding;
  48. TFieldBindings = Array of TFieldBinding;
  49. { TPQCursor }
  50. TPQCursor = Class(TSQLCursor)
  51. protected
  52. Statement : string;
  53. StmtName : string;
  54. tr : TPQTrans;
  55. res : PPGresult;
  56. CurTuple : integer;
  57. FieldBinding : TFieldBindings;
  58. Function GetFieldBinding(F : TFieldDef): PFieldBinding;
  59. Public
  60. Destructor Destroy; override;
  61. end;
  62. { EPQDatabaseError }
  63. EPQDatabaseError = class(EDatabaseError)
  64. public
  65. SEVERITY:string;
  66. SQLSTATE: string;
  67. MESSAGE_PRIMARY:string;
  68. MESSAGE_DETAIL:string;
  69. MESSAGE_HINT:string;
  70. STATEMENT_POSITION:string;
  71. end;
  72. { TPQTranConnection }
  73. TPQTranConnection = class
  74. protected
  75. FPGConn : PPGConn;
  76. FTranActive : boolean;
  77. end;
  78. { TPQConnection }
  79. TPQConnection = class (TSQLConnection)
  80. private
  81. FConnectionPool : TThreadList;
  82. FCursorCount : dword;
  83. FConnectString : string;
  84. FIntegerDateTimes : boolean;
  85. FVerboseErrors : Boolean;
  86. protected
  87. // Protected so they can be used by descendents.
  88. procedure CheckConnectionStatus(var conn: PPGconn);
  89. procedure CheckResultError(var res: PPGresult; conn:PPGconn; ErrMsg: string);
  90. function TranslateFldType(res : PPGresult; Tuple : integer; out Size : integer; Out ATypeOID : oid) : TFieldType;
  91. procedure ExecuteDirectPG(const Query : String);
  92. Procedure GetExtendedFieldInfo(cursor: TPQCursor; Bindings : TFieldBindings);
  93. procedure ApplyFieldUpdate(C : TSQLCursor; P: TSQLDBParam; F: TField; UseOldValue: Boolean); override;
  94. Function ErrorOnUnknownType : Boolean;
  95. // Add connection to pool.
  96. procedure AddConnection(T: TPQTranConnection);
  97. // Release connection in pool.
  98. procedure ReleaseConnection(Conn: PPGConn; DoClear : Boolean);
  99. function PortParamName: string; override;
  100. procedure DoInternalConnect; override;
  101. procedure DoInternalDisconnect; override;
  102. function GetHandle : pointer; override;
  103. Function AllocateCursorHandle : TSQLCursor; override;
  104. Procedure DeAllocateCursorHandle(var cursor : TSQLCursor); override;
  105. Function AllocateTransactionHandle : TSQLHandle; override;
  106. procedure PrepareStatement(cursor: TSQLCursor;ATransaction : TSQLTransaction;buf : string; AParams : TParams); override;
  107. procedure Execute(cursor: TSQLCursor;atransaction:tSQLtransaction; AParams : TParams); override;
  108. procedure AddFieldDefs(cursor: TSQLCursor; FieldDefs : TfieldDefs); override;
  109. function Fetch(cursor : TSQLCursor) : boolean; override;
  110. procedure UnPrepareStatement(cursor : TSQLCursor); override;
  111. function LoadField(cursor : TSQLCursor;FieldDef : TfieldDef;buffer : pointer; out CreateBlob : boolean) : boolean; override;
  112. function GetTransactionHandle(trans : TSQLHandle): pointer; override;
  113. function RollBack(trans : TSQLHandle) : boolean; override;
  114. function Commit(trans : TSQLHandle) : boolean; override;
  115. procedure CommitRetaining(trans : TSQLHandle); override;
  116. function StartImplicitTransaction(trans : TSQLHandle; AParams : string) : boolean; override;
  117. function StartDBTransaction(trans : TSQLHandle; AParams : string) : boolean; override;
  118. procedure RollBackRetaining(trans : TSQLHandle); override;
  119. procedure UpdateIndexDefs(IndexDefs : TIndexDefs;TableName : string); override;
  120. procedure LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField; cursor: TSQLCursor;ATransaction : TSQLTransaction); override;
  121. function RowsAffected(cursor: TSQLCursor): TRowsCount; override;
  122. function GetSchemaInfoSQL(SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string; override;
  123. function GetNextValueSQL(const SequenceName: string; IncrementBy: Integer): string; override;
  124. public
  125. constructor Create(AOwner : TComponent); override;
  126. destructor Destroy; override;
  127. function GetConnectionInfo(InfoType:TConnInfoType): string; override;
  128. procedure CreateDB; override;
  129. procedure DropDB; override;
  130. published
  131. property DatabaseName;
  132. property KeepConnection;
  133. property LoginPrompt;
  134. property Params;
  135. property OnLogin;
  136. Property VerboseErrors : Boolean Read FVerboseErrors Write FVerboseErrors default true;
  137. end;
  138. { TPQConnectionDef }
  139. TPQConnectionDef = Class(TConnectionDef)
  140. Class Function TypeName : String; override;
  141. Class Function ConnectionClass : TSQLConnectionClass; override;
  142. Class Function Description : String; override;
  143. Class Function DefaultLibraryName : String; override;
  144. Class Function LoadFunction : TLibraryLoadFunction; override;
  145. Class Function UnLoadFunction : TLibraryUnLoadFunction; override;
  146. Class Function LoadedLibraryName: string; override;
  147. end;
  148. implementation
  149. uses math, strutils, FmtBCD;
  150. ResourceString
  151. SErrRollbackFailed = 'Rollback transaction failed';
  152. SErrCommitFailed = 'Commit transaction failed';
  153. SErrConnectionFailed = 'Connection to database failed';
  154. SErrTransactionFailed = 'Start of transacion failed';
  155. SErrExecuteFailed = 'Execution of query failed';
  156. SErrPrepareFailed = 'Preparation of query failed.';
  157. SErrUnPrepareFailed = 'Unpreparation of query failed.';
  158. const Oid_Bool = 16;
  159. Oid_Bytea = 17;
  160. Oid_char = 18;
  161. Oid_Text = 25;
  162. Oid_Oid = 26;
  163. Oid_Name = 19;
  164. Oid_Int8 = 20;
  165. Oid_int2 = 21;
  166. Oid_Int4 = 23;
  167. Oid_JSON = 114;
  168. Oid_Float4 = 700;
  169. Oid_Money = 790;
  170. Oid_Float8 = 701;
  171. Oid_Unknown = 705;
  172. Oid_MacAddr = 829;
  173. Oid_Inet = 869;
  174. Oid_bpchar = 1042;
  175. Oid_varchar = 1043;
  176. oid_date = 1082;
  177. oid_time = 1083;
  178. Oid_timeTZ = 1266;
  179. Oid_timestamp = 1114;
  180. Oid_timestampTZ = 1184;
  181. Oid_interval = 1186;
  182. oid_numeric = 1700;
  183. Oid_uuid = 2950;
  184. { TPQTrans }
  185. constructor TPQTrans.Create;
  186. begin
  187. FList:=TThreadList.Create;
  188. FList.Duplicates:=dupIgnore;
  189. end;
  190. destructor TPQTrans.Destroy;
  191. Var
  192. L : TList;
  193. I : integer;
  194. begin
  195. L:=FList.LockList;
  196. try
  197. For I:=0 to L.Count-1 do
  198. TPQCursor(L[i]).tr:=Nil;
  199. finally
  200. FList.UnlockList;
  201. end;
  202. FreeAndNil(FList);
  203. inherited Destroy;
  204. end;
  205. procedure TPQTrans.RegisterCursor(Cursor: TPQCursor);
  206. begin
  207. FList.Add(Cursor);
  208. Cursor.tr:=Self;
  209. end;
  210. procedure TPQTrans.UnRegisterCursor(Cursor: TPQCursor);
  211. begin
  212. Cursor.tr:=Nil;
  213. FList.Remove(Cursor);
  214. end;
  215. { TPQCursor }
  216. destructor TPQCursor.Destroy;
  217. begin
  218. if Assigned(tr) then
  219. tr.UnRegisterCursor(Self);
  220. inherited Destroy;
  221. end;
  222. function TPQCursor.GetFieldBinding(F: TFieldDef): PFieldBinding;
  223. Var
  224. I : Integer;
  225. begin
  226. Result:=Nil;
  227. if (F=Nil) then exit;
  228. // This is an optimization: it is so for 99% of cases (FieldNo-1=array index)
  229. if F is TSQLDBFieldDef then
  230. Result:=PFieldBinding(TSQLDBFieldDef(F).SQLDBData)
  231. else If (FieldBinding[F.FieldNo-1].FieldDef=F) then
  232. Result:=@FieldBinding[F.FieldNo-1]
  233. else
  234. begin
  235. I:=Length(FieldBinding)-1;
  236. While (I>=0) and (FieldBinding[i].FieldDef<>F) do
  237. Dec(I);
  238. if I>=0 then
  239. Result:=@FieldBinding[i];
  240. end;
  241. end;
  242. { TPQConnection }
  243. constructor TPQConnection.Create(AOwner : TComponent);
  244. begin
  245. inherited;
  246. FConnOptions := FConnOptions + [sqSupportParams, sqSupportEmptyDatabaseName, sqEscapeRepeat, sqEscapeSlash, sqImplicitTransaction,sqSupportReturning,sqSequences];
  247. FieldNameQuoteChars:=DoubleQuotes;
  248. VerboseErrors:=True;
  249. FConnectionPool:=TThreadlist.Create;
  250. end;
  251. destructor TPQConnection.Destroy;
  252. begin
  253. // We must disconnect here. If it is done in inherited, then connection pool is gone.
  254. Connected:=False;
  255. FreeAndNil(FConnectionPool);
  256. inherited destroy;
  257. end;
  258. procedure TPQConnection.CreateDB;
  259. begin
  260. ExecuteDirectPG('CREATE DATABASE ' +DatabaseName);
  261. end;
  262. procedure TPQConnection.DropDB;
  263. begin
  264. ExecuteDirectPG('DROP DATABASE ' +DatabaseName);
  265. end;
  266. procedure TPQConnection.ExecuteDirectPG(const Query: String);
  267. var ASQLDatabaseHandle : PPGConn;
  268. res : PPGresult;
  269. begin
  270. CheckDisConnected;
  271. {$IfDef LinkDynamically}
  272. InitialisePostgres3;
  273. {$EndIf}
  274. FConnectString := '';
  275. if (UserName <> '') then FConnectString := FConnectString + ' user=''' + UserName + '''';
  276. if (Password <> '') then FConnectString := FConnectString + ' password=''' + Password + '''';
  277. if (HostName <> '') then FConnectString := FConnectString + ' host=''' + HostName + '''';
  278. FConnectString := FConnectString + ' dbname=''template1''';
  279. if (Params.Text <> '') then FConnectString := FConnectString + ' '+Params.Text;
  280. ASQLDatabaseHandle := PQconnectdb(pchar(FConnectString));
  281. CheckConnectionStatus(ASQLDatabaseHandle);
  282. res := PQexec(ASQLDatabaseHandle,pchar(query));
  283. CheckResultError(res,ASQLDatabaseHandle,SDBCreateDropFailed);
  284. PQclear(res);
  285. PQFinish(ASQLDatabaseHandle);
  286. {$IfDef LinkDynamically}
  287. ReleasePostgres3;
  288. {$EndIf}
  289. end;
  290. procedure TPQConnection.GetExtendedFieldInfo(cursor: TPQCursor;
  291. Bindings: TFieldBindings);
  292. Var
  293. tt,tc,Tn,S : String;
  294. I,J : Integer;
  295. Res : PPGResult;
  296. toid : oid;
  297. begin
  298. For I:=0 to Length(Bindings)-1 do
  299. if (Bindings[i].TypeOID>0) then
  300. begin
  301. if (S<>'') then
  302. S:=S+', ';
  303. S:=S+IntToStr(Bindings[i].TypeOID);
  304. end;
  305. if (S='') then
  306. exit;
  307. S:='select oid,typname,typtype,typcategory from pg_type where oid in ('+S+') order by oid';
  308. Res:=PQExec(Cursor.tr.PGConn,PChar(S));
  309. if (PQresultStatus(res)<>PGRES_TUPLES_OK) then
  310. CheckResultError(Res,Cursor.tr.PGConn,'Error getting type info');
  311. try
  312. For I:=0 to PQntuples(Res)-1 do
  313. begin
  314. toid:=Strtoint(pqgetvalue(Res,i,0));
  315. tn:=pqgetvalue(Res,i,1);
  316. tt:=pqgetvalue(Res,i,2);
  317. tc:=pqgetvalue(Res,i,3);
  318. J:=length(Bindings)-1;
  319. while (J>= 0) do
  320. begin
  321. if (Bindings[j].TypeOID=toid) then
  322. Case tt of
  323. 'e':
  324. Bindings[j].ExtendedFieldType:=eftEnum;
  325. 'citext':
  326. Bindings[j].ExtendedFieldType:=eftCitext;
  327. end;
  328. Dec(J);
  329. end;
  330. end;
  331. finally
  332. PQClear(Res);
  333. end;
  334. end;
  335. procedure TPQConnection.ApplyFieldUpdate(C : TSQLCursor; P: TSQLDBParam; F: TField;
  336. UseOldValue: Boolean);
  337. begin
  338. inherited ApplyFieldUpdate(C,P, F, UseOldValue);
  339. if (C is TPQCursor) then
  340. P.SQLDBData:=TPQCursor(C).GetFieldBinding(F.FieldDef);
  341. end;
  342. function TPQConnection.ErrorOnUnknownType: Boolean;
  343. begin
  344. Result:=False;
  345. end;
  346. procedure TPQConnection.AddConnection(T: TPQTranConnection);
  347. begin
  348. FConnectionPool.Add(T);
  349. end;
  350. procedure TPQConnection.ReleaseConnection(Conn: PPGConn; DoClear: Boolean);
  351. Var
  352. I : Integer;
  353. L : TList;
  354. T : TPQTranConnection;
  355. begin
  356. L:=FConnectionPool.LockList;
  357. // make connection available in pool
  358. try
  359. for i:=0 to L.Count-1 do
  360. begin
  361. T:=TPQTranConnection(L[i]);
  362. if (T.FPGConn=Conn) then
  363. begin
  364. T.FTranActive:=false;
  365. if DoClear then
  366. T.FPGConn:=Nil;
  367. break;
  368. end;
  369. end
  370. finally
  371. FConnectionPool.UnlockList;
  372. end;
  373. end;
  374. function TPQConnection.GetTransactionHandle(trans : TSQLHandle): pointer;
  375. begin
  376. Result := trans;
  377. end;
  378. function TPQConnection.RollBack(trans : TSQLHandle) : boolean;
  379. var
  380. res : PPGresult;
  381. tr : TPQTrans;
  382. i : Integer;
  383. L : TList;
  384. begin
  385. result := false;
  386. tr := trans as TPQTrans;
  387. // unprepare statements associated with given transaction
  388. L:=tr.FList.LockList;
  389. try
  390. For I:=0 to L.Count-1 do
  391. begin
  392. UnprepareStatement(TPQCursor(L[i]));
  393. TPQCursor(L[i]).tr:=Nil;
  394. end;
  395. L.Clear;
  396. finally
  397. tr.FList.UnlockList;
  398. end;
  399. res := PQexec(tr.PGConn, 'ROLLBACK');
  400. CheckResultError(res,tr.PGConn,SErrRollbackFailed);
  401. PQclear(res);
  402. ReleaseConnection(tr.PGCOnn,false);
  403. result := true;
  404. end;
  405. function TPQConnection.Commit(trans : TSQLHandle) : boolean;
  406. var
  407. res : PPGresult;
  408. tr : TPQTrans;
  409. begin
  410. result := false;
  411. tr := trans as TPQTrans;
  412. res := PQexec(tr.PGConn, 'COMMIT');
  413. CheckResultError(res,tr.PGConn,SErrCommitFailed);
  414. PQclear(res);
  415. //make connection available in pool
  416. ReleaseConnection(tr.PGConn,false);
  417. result := true;
  418. end;
  419. procedure TPQConnection.RollBackRetaining(trans : TSQLHandle);
  420. var
  421. res : PPGresult;
  422. tr : TPQTrans;
  423. begin
  424. tr := trans as TPQTrans;
  425. res := PQexec(tr.PGConn, 'ROLLBACK');
  426. CheckResultError(res,tr.PGConn,SErrRollbackFailed);
  427. PQclear(res);
  428. res := PQexec(tr.PGConn, 'BEGIN');
  429. CheckResultError(res,tr.PGConn,sErrTransactionFailed);
  430. PQclear(res);
  431. end;
  432. procedure TPQConnection.CommitRetaining(trans : TSQLHandle);
  433. var
  434. res : PPGresult;
  435. tr : TPQTrans;
  436. begin
  437. tr := trans as TPQTrans;
  438. res := PQexec(tr.PGConn, 'COMMIT');
  439. CheckResultError(res,tr.PGConn,SErrCommitFailed);
  440. PQclear(res);
  441. res := PQexec(tr.PGConn, 'BEGIN');
  442. CheckResultError(res,tr.PGConn,sErrTransactionFailed);
  443. PQclear(res);
  444. end;
  445. function TPQConnection.StartImplicitTransaction(trans : TSQLHandle; AParams : string) : boolean;
  446. var
  447. i : Integer;
  448. T : TPQTranConnection;
  449. L : TList;
  450. begin
  451. //find an unused connection in the pool
  452. i:=0;
  453. T:=Nil;
  454. L:=FConnectionPool.LockList;
  455. try
  456. while (i<L.Count) do
  457. begin
  458. T:=TPQTranConnection(L[i]);
  459. if (T.FPGConn=nil) or not T.FTranActive then
  460. break
  461. else
  462. T:=Nil;
  463. i:=i+1;
  464. end;
  465. // set to active now, so when we exit critical section,
  466. // it will be marked active and will not be found.
  467. if Assigned(T) then
  468. T.FTranActive:=true;
  469. finally
  470. FConnectionPool.UnLockList;
  471. end;
  472. if (T=Nil) then
  473. begin
  474. T:=TPQTranConnection.Create;
  475. T.FTranActive:=True;
  476. AddConnection(T);
  477. end;
  478. if (T.FPGConn=nil) then
  479. begin
  480. T.FPGConn := PQconnectdb(pchar(FConnectString));
  481. CheckConnectionStatus(T.FPGConn);
  482. if CharSet <> '' then
  483. PQsetClientEncoding(T.FPGConn, pchar(CharSet));
  484. end;
  485. TPQTrans(trans).PGConn := T.FPGConn;
  486. Result := true;
  487. end;
  488. function TPQConnection.StartDBTransaction(trans: TSQLHandle; AParams: string
  489. ): boolean;
  490. Var
  491. res : PPGresult;
  492. tr : TPQTrans;
  493. begin
  494. Result:=StartImplicitTransaction(trans, AParams);
  495. if Result then
  496. begin
  497. tr := trans as TPQTrans;
  498. res := PQexec(tr.PGConn, 'BEGIN');
  499. CheckResultError(res,tr.PGConn,sErrTransactionFailed);
  500. PQclear(res);
  501. end;
  502. end;
  503. procedure TPQConnection.DoInternalConnect;
  504. var
  505. ASQLDatabaseHandle : PPGConn;
  506. T : TPQTranConnection;
  507. begin
  508. {$IfDef LinkDynamically}
  509. InitialisePostgres3;
  510. {$EndIf}
  511. inherited DoInternalConnect;
  512. FConnectString := '';
  513. if (UserName <> '') then FConnectString := FConnectString + ' user=''' + UserName + '''';
  514. if (Password <> '') then FConnectString := FConnectString + ' password=''' + Password + '''';
  515. if (HostName <> '') then FConnectString := FConnectString + ' host=''' + HostName + '''';
  516. if (DatabaseName <> '') then FConnectString := FConnectString + ' dbname=''' + DatabaseName + '''';
  517. if (Params.Text <> '') then FConnectString := FConnectString + ' '+Params.Text;
  518. ASQLDatabaseHandle := PQconnectdb(pchar(FConnectString));
  519. try
  520. CheckConnectionStatus(ASQLDatabaseHandle);
  521. except
  522. DoInternalDisconnect;
  523. raise;
  524. end;
  525. // This only works for pg>=8.0, so timestamps won't work with earlier versions of pg which are compiled with integer_datetimes on
  526. if PQparameterStatus<>nil then
  527. FIntegerDateTimes := PQparameterStatus(ASQLDatabaseHandle,'integer_datetimes') = 'on';
  528. T:=TPQTranConnection.Create;
  529. T.FPGConn:=ASQLDatabaseHandle;
  530. T.FTranActive:=false;
  531. AddConnection(T);
  532. end;
  533. procedure TPQConnection.DoInternalDisconnect;
  534. var
  535. i:integer;
  536. L : TList;
  537. T : TPQTranConnection;
  538. begin
  539. Inherited;
  540. L:=FConnectionPool.LockList;
  541. try
  542. for i:=0 to L.Count-1 do
  543. begin
  544. T:=TPQTranConnection(L[i]);
  545. if assigned(T.FPGConn) then
  546. PQfinish(T.FPGConn);
  547. T.Free;
  548. end;
  549. L.Clear;
  550. finally
  551. FConnectionPool.UnLockList;
  552. end;
  553. {$IfDef LinkDynamically}
  554. ReleasePostgres3;
  555. {$EndIf}
  556. end;
  557. procedure TPQConnection.CheckConnectionStatus(var conn: PPGconn);
  558. var sErr: string;
  559. begin
  560. if (PQstatus(conn) = CONNECTION_BAD) then
  561. begin
  562. sErr := PQerrorMessage(conn);
  563. //make connection available in pool
  564. ReleaseConnection(Conn,True);
  565. PQfinish(conn);
  566. DatabaseError(sErrConnectionFailed + ' (PostgreSQL: ' + sErr + ')', Self);
  567. end;
  568. end;
  569. procedure TPQConnection.CheckResultError(var res: PPGresult; conn: PPGconn;
  570. ErrMsg: string);
  571. Procedure MaybeAdd(Var S : String; Prefix,Msg : String);
  572. begin
  573. if (Msg='') then
  574. exit;
  575. S:=S+LineEnding+Prefix+': '+Msg;
  576. end;
  577. var
  578. E: EPQDatabaseError;
  579. sErr: string;
  580. CompName: string;
  581. SEVERITY: string;
  582. SQLSTATE: string;
  583. MESSAGE_PRIMARY: string;
  584. MESSAGE_DETAIL: string;
  585. MESSAGE_HINT: string;
  586. STATEMENT_POSITION: string;
  587. P : Pchar;
  588. haveError : Boolean;
  589. begin
  590. HaveError:=False;
  591. if (Res=Nil) then
  592. begin
  593. HaveError:=True;
  594. P:=PQerrorMessage(conn);
  595. If Assigned(p) then
  596. ErrMsg:=StrPas(P);
  597. end
  598. else if (PQresultStatus(res) <> PGRES_COMMAND_OK) then
  599. begin
  600. HaveError:=True;
  601. SEVERITY:=PQresultErrorField(res,ord('S'));
  602. SQLSTATE:=PQresultErrorField(res,ord('C'));
  603. MESSAGE_PRIMARY:=PQresultErrorField(res,ord('M'));
  604. MESSAGE_DETAIL:=PQresultErrorField(res,ord('D'));
  605. MESSAGE_HINT:=PQresultErrorField(res,ord('H'));
  606. STATEMENT_POSITION:=PQresultErrorField(res,ord('P'));
  607. sErr:=PQresultErrorMessage(res);
  608. if VerboseErrors then
  609. begin
  610. MaybeAdd(sErr,'Severity',SEVERITY);
  611. MaybeAdd(sErr,'SQL State',SQLSTATE);
  612. MaybeAdd(sErr,'Primary Error',MESSAGE_PRIMARY);
  613. MaybeAdd(sErr,'Error Detail',MESSAGE_DETAIL);
  614. MaybeAdd(sErr,'Hint',MESSAGE_HINT);
  615. MaybeAdd(sErr,'Character',STATEMENT_POSITION);
  616. end;
  617. end;
  618. if HaveError then
  619. begin
  620. if (Self.Name='') then CompName := Self.ClassName else CompName := Self.Name;
  621. E:=EPQDatabaseError.CreateFmt('%s : %s (PostgreSQL: %s)', [CompName, ErrMsg, sErr]);
  622. E.SEVERITY:=SEVERITY;
  623. E.SQLSTATE:=SQLSTATE;
  624. E.MESSAGE_PRIMARY:=MESSAGE_PRIMARY;
  625. E.MESSAGE_DETAIL:=MESSAGE_DETAIL;
  626. E.MESSAGE_HINT:=MESSAGE_HINT;
  627. E.STATEMENT_POSITION:=STATEMENT_POSITION;
  628. PQclear(res);
  629. res:=nil;
  630. if assigned(conn) then
  631. begin
  632. PQFinish(conn);
  633. ReleaseConnection(Conn,True);
  634. end;
  635. raise E;
  636. end;
  637. end;
  638. function TPQConnection.TranslateFldType(res: PPGresult; Tuple: integer; out
  639. Size: integer; out ATypeOID: oid): TFieldType;
  640. const
  641. VARHDRSZ=sizeof(longint);
  642. var
  643. li : longint;
  644. aoid : oid;
  645. begin
  646. Size := 0;
  647. ATypeOID:=0;
  648. AOID:=PQftype(res,Tuple);
  649. case AOID of
  650. Oid_varchar,Oid_bpchar,
  651. Oid_name : begin
  652. Result := ftString;
  653. size := PQfsize(Res, Tuple);
  654. if (size = -1) then
  655. begin
  656. li := PQfmod(res,Tuple);
  657. if li = -1 then
  658. size := dsMaxStringSize
  659. else
  660. size := (li-VARHDRSZ) and $FFFF;
  661. end;
  662. if size > MaxSmallint then size := MaxSmallint;
  663. end;
  664. // Oid_text : Result := ftString;
  665. Oid_text,Oid_JSON : Result := ftMemo;
  666. Oid_Bytea : Result := ftBlob;
  667. Oid_oid : Result := ftInteger;
  668. Oid_int8 : Result := ftLargeInt;
  669. Oid_int4 : Result := ftInteger;
  670. Oid_int2 : Result := ftSmallInt;
  671. Oid_Float4 : Result := ftFloat;
  672. Oid_Float8 : Result := ftFloat;
  673. Oid_TimeStamp,
  674. Oid_TimeStampTZ : Result := ftDateTime;
  675. Oid_Date : Result := ftDate;
  676. Oid_Interval,
  677. Oid_Time,
  678. Oid_TimeTZ : Result := ftTime;
  679. Oid_Bool : Result := ftBoolean;
  680. Oid_Numeric : begin
  681. Result := ftBCD;
  682. li := PQfmod(res,Tuple);
  683. if li = -1 then
  684. size := 4 // No information about the size available, use the maximum value
  685. else
  686. // The precision is the high 16 bits, the scale the
  687. // low 16 bits with an offset of sizeof(int32).
  688. begin
  689. size := (li-VARHDRSZ) and $FFFF;
  690. if (size > MaxBCDScale) or ((li shr 16)-size > MaxBCDPrecision-MaxBCDScale) then
  691. Result := ftFmtBCD;
  692. end;
  693. end;
  694. Oid_Money : Result := ftCurrency;
  695. Oid_char : begin
  696. Result := ftFixedChar;
  697. Size := 1;
  698. end;
  699. Oid_uuid : begin
  700. Result := ftGuid;
  701. Size := 38;
  702. end;
  703. Oid_MacAddr : begin
  704. Result := ftFixedChar;
  705. Size := 17;
  706. end;
  707. Oid_Inet : begin
  708. Result := ftString;
  709. Size := 39;
  710. end;
  711. Oid_Unknown : Result := ftUnknown;
  712. else
  713. Result:=ftUnknown;
  714. ATypeOID:=AOID;
  715. end;
  716. end;
  717. function TPQConnection.AllocateCursorHandle: TSQLCursor;
  718. begin
  719. result := TPQCursor.create;
  720. end;
  721. procedure TPQConnection.DeAllocateCursorHandle(var cursor: TSQLCursor);
  722. begin
  723. FreeAndNil(cursor);
  724. end;
  725. function TPQConnection.AllocateTransactionHandle: TSQLHandle;
  726. begin
  727. result := TPQTrans.create;
  728. end;
  729. procedure TPQConnection.PrepareStatement(cursor: TSQLCursor;ATransaction : TSQLTransaction;buf : string; AParams : TParams);
  730. const TypeStrings : array[TFieldType] of string =
  731. (
  732. 'Unknown', // ftUnknown
  733. 'text', // ftString
  734. 'smallint', // ftSmallint
  735. 'int', // ftInteger
  736. 'int', // ftWord
  737. 'bool', // ftBoolean
  738. 'float', // ftFloat
  739. 'money', // ftCurrency
  740. 'numeric', // ftBCD
  741. 'date', // ftDate
  742. 'time', // ftTime
  743. 'timestamp', // ftDateTime
  744. 'Unknown', // ftBytes
  745. 'bytea', // ftVarBytes
  746. 'Unknown', // ftAutoInc
  747. 'bytea', // ftBlob
  748. 'text', // ftMemo
  749. 'bytea', // ftGraphic
  750. 'text', // ftFmtMemo
  751. 'Unknown', // ftParadoxOle
  752. 'Unknown', // ftDBaseOle
  753. 'Unknown', // ftTypedBinary
  754. 'Unknown', // ftCursor
  755. 'char', // ftFixedChar
  756. 'text', // ftWideString
  757. 'bigint', // ftLargeint
  758. 'Unknown', // ftADT
  759. 'Unknown', // ftArray
  760. 'Unknown', // ftReference
  761. 'Unknown', // ftDataSet
  762. 'Unknown', // ftOraBlob
  763. 'Unknown', // ftOraClob
  764. 'Unknown', // ftVariant
  765. 'Unknown', // ftInterface
  766. 'Unknown', // ftIDispatch
  767. 'uuid', // ftGuid
  768. 'Unknown', // ftTimeStamp
  769. 'numeric', // ftFMTBcd
  770. 'Unknown', // ftFixedWideChar
  771. 'Unknown', // ftWideMemo
  772. 'Unknown', // ftOraTimeStamp
  773. 'Unknown', // ftOraInterval
  774. 'Unknown', // ftLongWord
  775. 'Unknown', // ftShortint
  776. 'Unknown', // ftByte
  777. 'Unknown', // ftExtended
  778. 'real' // ftSingle
  779. );
  780. var
  781. s,ts : string;
  782. i : integer;
  783. P : TParam;
  784. PQ : TSQLDBParam;
  785. begin
  786. with (cursor as TPQCursor) do
  787. begin
  788. FPrepared := False;
  789. FDirect := False;
  790. // Prior to v8 there is no support for cursors and parameters.
  791. // So that's not supported.
  792. if FStatementType in [stInsert,stUpdate,stDelete, stSelect] then
  793. begin
  794. StmtName := 'prepst'+inttostr(FCursorCount);
  795. InterlockedIncrement(FCursorCount);
  796. TPQTrans(aTransaction.Handle).RegisterCursor(Cursor as TPQCursor);
  797. // Only available for pq 8.0, so don't use it...
  798. // Res := pqprepare(tr,'prepst'+name+nr,pchar(buf),params.Count,pchar(''));
  799. s := 'prepare '+StmtName+' ';
  800. if Assigned(AParams) and (AParams.Count > 0) then
  801. begin
  802. s := s + '(';
  803. for i := 0 to AParams.Count-1 do
  804. begin
  805. P:=AParams[i];
  806. If (P is TSQLDBParam) then
  807. PQ:=TSQLDBParam(P)
  808. else
  809. PQ:=Nil;
  810. TS:=TypeStrings[P.DataType];
  811. if (TS<>'Unknown') then
  812. begin
  813. If Assigned(PQ)
  814. and Assigned(PQ.SQLDBData)
  815. and (PFieldBinding(PQ.SQLDBData)^.ExtendedFieldType=eftEnum) then
  816. ts:='unknown';
  817. s := s + ts + ','
  818. end
  819. else
  820. begin
  821. if P.DataType = ftUnknown then
  822. begin
  823. if P.IsNull then
  824. s:=s+' unknown ,'
  825. else
  826. DatabaseErrorFmt(SUnknownParamFieldType,[P.Name],self)
  827. end
  828. else
  829. DatabaseErrorFmt(SUnsupportedParameter,[Fieldtypenames[P.DataType]],self);
  830. end;
  831. end;
  832. s[length(s)] := ')';
  833. buf := AParams.ParseSQL(buf,false,sqEscapeSlash in ConnOptions, sqEscapeRepeat in ConnOptions,psPostgreSQL);
  834. end;
  835. s := s + ' as ' + buf;
  836. if LogEvent(detActualSQL) then
  837. Log(detActualSQL,S);
  838. res := PQexec(tr.PGConn,pchar(s));
  839. CheckResultError(res,nil,SErrPrepareFailed);
  840. // if statement is INSERT, UPDATE, DELETE with RETURNING clause, then
  841. // override the statement type derrived by parsing the query.
  842. if (FStatementType in [stInsert,stUpdate,stDelete]) and (pos('RETURNING', upcase(s)) > 0) then
  843. begin
  844. PQclear(res);
  845. res := PQdescribePrepared(tr.PGConn,pchar(StmtName));
  846. if (PQresultStatus(res) = PGRES_COMMAND_OK) and (PQnfields(res) > 0) then
  847. FStatementType := stSelect;
  848. end;
  849. FPrepared := True;
  850. end
  851. else
  852. begin
  853. if Assigned(AParams) then
  854. Statement := AParams.ParseSQL(buf,false,sqEscapeSlash in ConnOptions, sqEscapeRepeat in ConnOptions,psPostgreSQL)
  855. else
  856. Statement:=Buf;
  857. FDirect:=True;
  858. end;
  859. end;
  860. end;
  861. procedure TPQConnection.UnPrepareStatement(cursor : TSQLCursor);
  862. begin
  863. with (cursor as TPQCursor) do
  864. begin
  865. PQclear(res);
  866. res:=nil;
  867. if FPrepared then
  868. begin
  869. if assigned(tr) and (PQtransactionStatus(tr.PGConn) <> PQTRANS_INERROR) then
  870. begin
  871. res := PQexec(tr.PGConn,pchar('deallocate '+StmtName));
  872. CheckResultError(res,nil,SErrUnPrepareFailed);
  873. PQclear(res);
  874. res:=nil;
  875. end;
  876. FPrepared := False;
  877. end;
  878. end;
  879. end;
  880. procedure TPQConnection.Execute(cursor: TSQLCursor;atransaction:tSQLtransaction;AParams : TParams);
  881. var ar : array of PAnsiChar;
  882. handled : boolean;
  883. l,i : integer;
  884. s : RawByteString;
  885. bd : TBlobData;
  886. lengths,formats : array of integer;
  887. ParamNames,
  888. ParamValues : array of string;
  889. cash: int64;
  890. function FormatTimeInterval(Time: TDateTime): string; // supports Time >= '24:00:00'
  891. var hour, minute, second, millisecond: word;
  892. begin
  893. DecodeTime(Time, hour, minute, second, millisecond);
  894. Result := Format('%.2d:%.2d:%.2d.%.3d',[Trunc(Time)*24+hour,minute,second,millisecond]);
  895. end;
  896. begin
  897. with cursor as TPQCursor do
  898. begin
  899. CurTuple:=-1;
  900. PQclear(res);
  901. if FStatementType in [stInsert,stUpdate,stDelete,stSelect] then
  902. begin
  903. if LogEvent(detParamValue) then
  904. LogParams(AParams);
  905. if Assigned(AParams) and (AParams.Count > 0) then
  906. begin
  907. l:=AParams.Count;
  908. setlength(ar,l);
  909. setlength(lengths,l);
  910. setlength(formats,l);
  911. for i := 0 to AParams.Count -1 do if not AParams[i].IsNull then
  912. begin
  913. handled:=False;
  914. case AParams[i].DataType of
  915. ftDateTime:
  916. s := FormatDateTime('yyyy"-"mm"-"dd hh":"nn":"ss.zzz', AParams[i].AsDateTime);
  917. ftDate:
  918. s := FormatDateTime('yyyy"-"mm"-"dd', AParams[i].AsDateTime);
  919. ftTime:
  920. s := FormatTimeInterval(AParams[i].AsDateTime);
  921. ftFloat:
  922. Str(AParams[i].AsFloat, s);
  923. ftBCD:
  924. Str(AParams[i].AsCurrency, s);
  925. ftCurrency:
  926. begin
  927. cash:=NtoBE(round(AParams[i].AsCurrency*100));
  928. setlength(s, sizeof(cash));
  929. Move(cash, s[1], sizeof(cash));
  930. end;
  931. ftFmtBCD:
  932. s := BCDToStr(AParams[i].AsFMTBCD, FSQLFormatSettings);
  933. ftBlob, ftGraphic, ftVarBytes:
  934. begin
  935. Handled:=true;
  936. bd:= AParams[i].AsBlob;
  937. l:=length(BD);
  938. if l>0 then
  939. begin
  940. GetMem(ar[i],l+1);
  941. ar[i][l]:=#0;
  942. Move(BD[0],ar[i]^, L);
  943. lengths[i]:=l;
  944. end;
  945. end
  946. else
  947. s := GetAsString(AParams[i]);
  948. end; {case}
  949. if not handled then
  950. begin
  951. l:=length(s);
  952. GetMem(ar[i],l+1);
  953. StrMove(PAnsiChar(ar[i]), PAnsiChar(s), L+1);
  954. lengths[i]:=L;
  955. end;
  956. if (AParams[i].DataType in [ftBlob,ftMemo,ftGraphic,ftCurrency,ftVarBytes]) then
  957. Formats[i]:=1
  958. else
  959. Formats[i]:=0;
  960. end
  961. else
  962. FreeAndNil(ar[i]);
  963. res := PQexecPrepared(tr.PGConn,pchar(StmtName),AParams.Count,@Ar[0],@Lengths[0],@Formats[0],1);
  964. for i := 0 to AParams.Count -1 do
  965. FreeMem(ar[i]);
  966. end
  967. else
  968. res := PQexecPrepared(tr.PGConn,pchar(StmtName),0,nil,nil,nil,1);
  969. end
  970. else
  971. begin
  972. // RegisterCursor sets tr
  973. TPQTrans(aTransaction.Handle).RegisterCursor(Cursor as TPQCursor);
  974. if Assigned(AParams) and (AParams.Count > 0) then
  975. begin
  976. setlength(ParamNames,AParams.Count);
  977. setlength(ParamValues,AParams.Count);
  978. for i := 0 to AParams.Count -1 do
  979. begin
  980. ParamNames[AParams.Count-i-1] := '$'+inttostr(AParams[i].index+1);
  981. ParamValues[AParams.Count-i-1] := GetAsSQLText(AParams[i]);
  982. end;
  983. s := stringsreplace(Statement,ParamNames,ParamValues,[rfReplaceAll]);
  984. end
  985. else
  986. s := Statement;
  987. res := PQexec(tr.PGConn,pchar(s));
  988. if (PQresultStatus(res) in [PGRES_COMMAND_OK]) then
  989. begin
  990. PQclear(res);
  991. res:=nil;
  992. end;
  993. end;
  994. if assigned(res) and not (PQresultStatus(res) in [PGRES_COMMAND_OK,PGRES_TUPLES_OK]) then
  995. begin
  996. // Don't perform the rollback, only make it possible to do a rollback.
  997. // The other databases also don't do this.
  998. //atransaction.Rollback;
  999. CheckResultError(res,nil,SErrExecuteFailed);
  1000. end;
  1001. FSelectable := assigned(res) and (PQresultStatus(res)=PGRES_TUPLES_OK);
  1002. end;
  1003. end;
  1004. procedure TPQConnection.AddFieldDefs(cursor: TSQLCursor; FieldDefs : TfieldDefs);
  1005. var
  1006. i : integer;
  1007. asize : integer;
  1008. aoid : oid;
  1009. fieldtype : tfieldtype;
  1010. nFields : integer;
  1011. b : Boolean;
  1012. Q : TPQCursor;
  1013. FD : TSQLDBFieldDef;
  1014. FB : PFieldBinding;
  1015. begin
  1016. B:=False;
  1017. Q:=cursor as TPQCursor;
  1018. with Q do
  1019. begin
  1020. nFields := PQnfields(Res);
  1021. setlength(FieldBinding,nFields);
  1022. for i := 0 to nFields-1 do
  1023. begin
  1024. fieldtype := TranslateFldType(Res, i, asize, aoid );
  1025. FD := AddFieldDef(FieldDefs, i+1, PQfname(Res, i), fieldtype, asize, -1, False, False, False) as TSQLDBFieldDef;
  1026. With FD do
  1027. begin
  1028. SQLDBData:=@FieldBinding[i];
  1029. FieldBinding[i].Index:=i;
  1030. FieldBinding[i].FieldDef:=FD;
  1031. FieldBinding[i].TypeOID:=aOID;
  1032. B:=B or (aOID>0);
  1033. end;
  1034. end;
  1035. CurTuple := -1;
  1036. end;
  1037. if B then
  1038. begin
  1039. // get all information in 1 go.
  1040. GetExtendedFieldInfo(Q,Q.FieldBinding);
  1041. For I:=0 to Length(Q.FieldBinding)-1 do
  1042. begin
  1043. FB:[email protected][i];
  1044. if (FB^.TypeOID>0) then
  1045. begin
  1046. FD:=FB^.FieldDef;
  1047. Case FB^.ExtendedFieldType of
  1048. eftEnum :
  1049. begin
  1050. FD.DataType:=ftString;
  1051. FD.Size:=64;
  1052. //FD.Attributes:=FD.Attributes+[faReadonly];
  1053. end;
  1054. eftCitext:
  1055. begin
  1056. FD.DataType:=ftMemo;
  1057. end
  1058. else
  1059. if ErrorOnUnknownType then
  1060. DatabaseError('Unhandled field type :'+FB^.TypeName,Self);
  1061. end;
  1062. end;
  1063. end;
  1064. end;
  1065. end;
  1066. function TPQConnection.GetHandle: pointer;
  1067. var
  1068. i:integer;
  1069. L : TList;
  1070. T : TPQTranConnection;
  1071. begin
  1072. result:=nil;
  1073. if not Connected then
  1074. exit;
  1075. //Get any handle that is (still) connected
  1076. L:=FConnectionPool.LockList;
  1077. try
  1078. I:=L.Count-1;
  1079. While (I>=0) and (Result=Nil) do
  1080. begin
  1081. T:=TPQTranConnection(L[i]);
  1082. if assigned(T.FPGConn) and (PQstatus(T.FPGConn)<>CONNECTION_BAD) then
  1083. Result:=T.FPGConn;
  1084. Dec(I);
  1085. end;
  1086. finally
  1087. FConnectionPool.UnLockList;
  1088. end;
  1089. if Result<>Nil then
  1090. exit;
  1091. //Nothing connected!! Reconnect
  1092. // T is element 0 after loop
  1093. if assigned(T.FPGConn) then
  1094. PQreset(T.FPGConn)
  1095. else
  1096. T.FPGConn := PQconnectdb(pchar(FConnectString));
  1097. CheckConnectionStatus(T.FPGConn);
  1098. if CharSet <> '' then
  1099. PQsetClientEncoding(T.FPGConn, pchar(CharSet));
  1100. result:=T.FPGConn;
  1101. end;
  1102. function TPQConnection.Fetch(cursor : TSQLCursor) : boolean;
  1103. begin
  1104. with cursor as TPQCursor do
  1105. begin
  1106. inc(CurTuple);
  1107. Result := (PQntuples(res)>CurTuple);
  1108. end;
  1109. end;
  1110. function TPQConnection.LoadField(cursor : TSQLCursor;FieldDef : TfieldDef;buffer : pointer; out CreateBlob : boolean) : boolean;
  1111. const NBASE=10000;
  1112. DAYS_PER_MONTH=30;
  1113. type TNumericRecord = record
  1114. Digits : SmallInt;
  1115. Weight : SmallInt;
  1116. Sign : SmallInt;
  1117. Scale : Smallint;
  1118. end;
  1119. TIntervalRec = packed record
  1120. time : int64;
  1121. day : longint;
  1122. month : longint;
  1123. end;
  1124. TMacAddrRec = packed record
  1125. a, b, c, d, e, f: byte;
  1126. end;
  1127. TInetRec = packed record
  1128. family : byte;
  1129. bits : byte;
  1130. is_cidr: byte;
  1131. nb : byte;
  1132. ipaddr : array[1..16] of byte;
  1133. end;
  1134. var
  1135. x,i : integer;
  1136. s : string;
  1137. li : Longint;
  1138. CurrBuff : pchar;
  1139. dbl : pdouble;
  1140. cur : currency;
  1141. NumericRecord : ^TNumericRecord;
  1142. guid : TGUID;
  1143. bcd : TBCD;
  1144. macaddr : ^TMacAddrRec;
  1145. inet : ^TInetRec;
  1146. begin
  1147. Createblob := False;
  1148. with cursor as TPQCursor do
  1149. begin
  1150. x := GetFieldBinding(FieldDef)^.Index;
  1151. // Joost, 5 jan 2006: I disabled the following, since it's useful for
  1152. // debugging, but it also slows things down. In principle things can only go
  1153. // wrong when FieldDefs is changed while the dataset is opened. A user just
  1154. // shoudn't do that. ;) (The same is done in IBConnection)
  1155. //if PQfname(Res, x) <> FieldDef.Name then
  1156. // DatabaseErrorFmt(SFieldNotFound,[FieldDef.Name],self);
  1157. if pqgetisnull(res,CurTuple,x)=1 then
  1158. result := false
  1159. else
  1160. begin
  1161. CurrBuff := pqgetvalue(res,CurTuple,x);
  1162. result := true;
  1163. case FieldDef.DataType of
  1164. ftInteger, ftSmallint, ftLargeInt :
  1165. case PQfsize(res, x) of // postgres returns big-endian numbers
  1166. sizeof(int64) : pint64(buffer)^ := BEtoN(pint64(CurrBuff)^); // INT8
  1167. sizeof(integer) : pinteger(buffer)^ := BEtoN(pinteger(CurrBuff)^); // INT4
  1168. sizeof(smallint) : psmallint(buffer)^ := BEtoN(psmallint(CurrBuff)^); // INT2
  1169. end; {case}
  1170. ftFloat :
  1171. case PQfsize(res, x) of // postgres returns big-endian numbers
  1172. sizeof(int64) : // FLOAT8
  1173. pint64(buffer)^ := BEtoN(pint64(CurrBuff)^);
  1174. sizeof(integer) : // FLOAT4
  1175. begin
  1176. li := BEtoN(pinteger(CurrBuff)^);
  1177. pdouble(buffer)^ := psingle(@li)^
  1178. end;
  1179. end; {case}
  1180. ftString, ftFixedChar :
  1181. begin
  1182. case PQftype(res, x) of
  1183. Oid_MacAddr:
  1184. begin
  1185. macaddr := Pointer(CurrBuff);
  1186. li := FormatBuf(Buffer^, FieldDef.Size, '%.2x:%.2x:%.2x:%.2x:%.2x:%.2x', 29,
  1187. [macaddr^.a,macaddr^.b,macaddr^.c,macaddr^.d,macaddr^.e,macaddr^.f]);
  1188. end;
  1189. Oid_Inet:
  1190. begin
  1191. inet := Pointer(CurrBuff);
  1192. if inet^.nb = 4 then
  1193. li := FormatBuf(Buffer^, FieldDef.Size, '%d.%d.%d.%d', 11,
  1194. [inet^.ipaddr[1],inet^.ipaddr[2],inet^.ipaddr[3],inet^.ipaddr[4]])
  1195. else if inet^.nb = 16 then
  1196. li := FormatBuf(Buffer^, FieldDef.Size, '%x%.2x:%x%.2x:%x%.2x:%x%.2x:%x%.2x:%x%.2x:%x%.2x:%x%.2x', 55,
  1197. [inet^.ipaddr[1],inet^.ipaddr[2],inet^.ipaddr[3],inet^.ipaddr[4],inet^.ipaddr[5],inet^.ipaddr[6],inet^.ipaddr[7],inet^.ipaddr[8],inet^.ipaddr[9],inet^.ipaddr[10],inet^.ipaddr[11],inet^.ipaddr[12],inet^.ipaddr[13],inet^.ipaddr[14],inet^.ipaddr[15],inet^.ipaddr[16]])
  1198. else
  1199. li := 0;
  1200. end
  1201. else
  1202. begin
  1203. li := pqgetlength(res,curtuple,x);
  1204. if li > FieldDef.Size then li := FieldDef.Size;
  1205. Move(CurrBuff^, Buffer^, li);
  1206. end;
  1207. end;
  1208. pchar(Buffer + li)^ := #0;
  1209. end;
  1210. ftBlob, ftMemo, ftVarBytes :
  1211. CreateBlob := True;
  1212. ftDate :
  1213. begin
  1214. dbl := pointer(buffer);
  1215. dbl^ := BEtoN(plongint(CurrBuff)^) + 36526;
  1216. end;
  1217. ftDateTime, ftTime :
  1218. begin
  1219. dbl := pointer(buffer);
  1220. if FIntegerDateTimes then
  1221. dbl^ := BEtoN(pint64(CurrBuff)^) / 1000000
  1222. else
  1223. pint64(dbl)^ := BEtoN(pint64(CurrBuff)^);
  1224. case PQftype(res, x) of
  1225. Oid_Timestamp, Oid_TimestampTZ:
  1226. dbl^ := dbl^ + 3.1558464E+009; // postgres counts seconds elapsed since 1-1-2000
  1227. Oid_Interval:
  1228. dbl^ := dbl^ + BEtoN(plongint(CurrBuff+ 8)^) * SecsPerDay
  1229. + BEtoN(plongint(CurrBuff+12)^) * SecsPerDay * DAYS_PER_MONTH;
  1230. end;
  1231. dbl^ := dbl^ / SecsPerDay;
  1232. // Now convert the mathematically-correct datetime to the
  1233. // illogical windows/delphi/fpc TDateTime:
  1234. if (dbl^ <= 0) and (frac(dbl^) < 0) then
  1235. dbl^ := trunc(dbl^)-2-frac(dbl^);
  1236. end;
  1237. ftBCD, ftFmtBCD:
  1238. begin
  1239. NumericRecord := pointer(CurrBuff);
  1240. NumericRecord^.Digits := BEtoN(NumericRecord^.Digits);
  1241. NumericRecord^.Weight := BEtoN(NumericRecord^.Weight);
  1242. NumericRecord^.Sign := BEtoN(NumericRecord^.Sign);
  1243. NumericRecord^.Scale := BEtoN(NumericRecord^.Scale);
  1244. inc(pointer(currbuff),sizeof(TNumericRecord));
  1245. if (NumericRecord^.Digits = 0) and (NumericRecord^.Scale = 0) then // = NaN, which is not supported by Currency-type, so we return NULL
  1246. result := false
  1247. else if FieldDef.DataType = ftBCD then
  1248. begin
  1249. cur := 0;
  1250. for i := 0 to NumericRecord^.Digits-1 do
  1251. begin
  1252. cur := cur + beton(pword(CurrBuff)^) * intpower(NBASE, NumericRecord^.weight-i);
  1253. inc(pointer(CurrBuff),2);
  1254. end;
  1255. if NumericRecord^.Sign <> 0 then cur := -cur;
  1256. Move(Cur, Buffer^, sizeof(currency));
  1257. end
  1258. else //ftFmtBCD
  1259. begin
  1260. bcd := 0;
  1261. for i := 0 to NumericRecord^.Digits-1 do
  1262. begin
  1263. BCDAdd(bcd, beton(pword(CurrBuff)^) * intpower(NBASE, NumericRecord^.weight-i), bcd);
  1264. inc(pointer(CurrBuff),2);
  1265. end;
  1266. if NumericRecord^.Sign <> 0 then BCDNegate(bcd);
  1267. Move(bcd, Buffer^, sizeof(bcd));
  1268. end;
  1269. end;
  1270. ftCurrency :
  1271. begin
  1272. dbl := pointer(buffer);
  1273. dbl^ := BEtoN(PInt64(CurrBuff)^) / 100;
  1274. end;
  1275. ftBoolean:
  1276. pchar(buffer)[0] := CurrBuff[0];
  1277. ftGuid:
  1278. begin
  1279. Move(CurrBuff^, guid, sizeof(guid));
  1280. guid.D1:=BEtoN(guid.D1);
  1281. guid.D2:=BEtoN(guid.D2);
  1282. guid.D3:=BEtoN(guid.D3);
  1283. s:=GUIDToString(guid);
  1284. StrPLCopy(PChar(Buffer), s, FieldDef.Size);
  1285. end
  1286. else
  1287. result := false;
  1288. end;
  1289. end;
  1290. end;
  1291. end;
  1292. function TPQConnection.PortParamName: string;
  1293. begin
  1294. Result := 'port';
  1295. end;
  1296. procedure TPQConnection.UpdateIndexDefs(IndexDefs : TIndexDefs;TableName : string);
  1297. var qry : TSQLQuery;
  1298. relname : string;
  1299. begin
  1300. if not assigned(Transaction) then
  1301. DatabaseError(SErrConnTransactionnSet);
  1302. if (length(TableName)>2) and (TableName[1]='"') and (TableName[length(TableName)]='"') then
  1303. relname := QuotedStr(AnsiDequotedStr(TableName, '"'))
  1304. else
  1305. relname := 'lower(' + QuotedStr(TableName) + ')'; // unquoted names are stored lower case in PostgreSQL which is incompatible with the SQL standard
  1306. qry := tsqlquery.Create(nil);
  1307. qry.transaction := Transaction;
  1308. qry.database := Self;
  1309. with qry do
  1310. begin
  1311. ReadOnly := True;
  1312. sql.clear;
  1313. sql.add('select '+
  1314. 'ic.relname as indexname, '+
  1315. 'tc.relname as tablename, '+
  1316. 'ia.attname, '+
  1317. 'i.indisprimary, '+
  1318. 'i.indisunique '+
  1319. 'from '+
  1320. 'pg_attribute ta, '+
  1321. 'pg_attribute ia, '+
  1322. 'pg_class tc, '+
  1323. 'pg_class ic, '+
  1324. 'pg_index i '+
  1325. 'where '+
  1326. '(i.indrelid = tc.oid) and '+
  1327. '(ta.attrelid = tc.oid) and '+
  1328. '(ia.attrelid = i.indexrelid) and '+
  1329. '(ic.oid = i.indexrelid) and '+
  1330. '(ta.attnum = i.indkey[ia.attnum-1]) and '+
  1331. '(tc.relname = ' + relname + ') '+
  1332. 'order by '+
  1333. 'ic.relname;');
  1334. open;
  1335. end;
  1336. while not qry.eof do with IndexDefs.AddIndexDef do
  1337. begin
  1338. Name := trim(qry.fields[0].asstring);
  1339. Fields := trim(qry.Fields[2].asstring);
  1340. If qry.fields[3].asboolean then options := options + [ixPrimary];
  1341. If qry.fields[4].asboolean then options := options + [ixUnique];
  1342. qry.next;
  1343. while (name = qry.fields[0].asstring) and (not qry.eof) do
  1344. begin
  1345. Fields := Fields + ';' + trim(qry.Fields[2].asstring);
  1346. qry.next;
  1347. end;
  1348. end;
  1349. qry.close;
  1350. qry.free;
  1351. end;
  1352. function TPQConnection.GetSchemaInfoSQL(SchemaType: TSchemaType;
  1353. SchemaObjectName, SchemaPattern: string): string;
  1354. var s : string;
  1355. begin
  1356. // select * from information_schema.tables with
  1357. // where table_schema [not] in ('pg_catalog','information_schema') may be better.
  1358. // But the following should work:
  1359. case SchemaType of
  1360. stTables : s := 'select '+
  1361. 'relfilenode as recno, '+
  1362. 'current_database() as catalog_name, '+
  1363. 'nspname as schema_name, '+
  1364. 'relname as table_name, '+
  1365. '0 as table_type '+
  1366. 'from pg_class c '+
  1367. 'left join pg_namespace n on c.relnamespace=n.oid '+
  1368. 'where (relkind=''r'') and not (nspname in (''pg_catalog'',''information_schema''))' +
  1369. 'order by relname';
  1370. stSysTables : s := 'select '+
  1371. 'relfilenode as recno, '+
  1372. 'current_database() as catalog_name, '+
  1373. 'nspname as schema_name, '+
  1374. 'relname as table_name, '+
  1375. '0 as table_type '+
  1376. 'from pg_class c '+
  1377. 'left join pg_namespace n on c.relnamespace=n.oid '+
  1378. 'where (relkind=''r'') and nspname in ((''pg_catalog'',''information_schema'')) ' + // only system tables
  1379. 'order by relname';
  1380. stColumns : s := 'select '+
  1381. 'a.attnum as recno, '+
  1382. 'current_database() as catalog_name, '+
  1383. 'nspname as schema_name, '+
  1384. 'c.relname as table_name, '+
  1385. 'a.attname as column_name, '+
  1386. 'a.attnum as column_position, '+
  1387. '0 as column_type, '+
  1388. 'a.atttypid as column_datatype, '+
  1389. 't.typname as column_typename, '+
  1390. '0 as column_subtype, '+
  1391. '0 as column_precision, '+
  1392. '0 as column_scale, '+
  1393. 'a.atttypmod as column_length, '+
  1394. 'not a.attnotnull as column_nullable '+
  1395. 'from pg_class c '+
  1396. 'join pg_attribute a on c.oid=a.attrelid '+
  1397. 'join pg_type t on t.oid=a.atttypid '+
  1398. 'left join pg_namespace n on c.relnamespace=n.oid '+
  1399. // This can lead to problems when case-sensitive tablenames are used.
  1400. 'where (a.attnum>0) and (not a.attisdropped) and (upper(c.relname)=''' + Uppercase(SchemaObjectName) + ''') '+
  1401. 'order by a.attname';
  1402. else
  1403. s := inherited;
  1404. end; {case}
  1405. result := s;
  1406. end;
  1407. function TPQConnection.GetNextValueSQL(const SequenceName: string; IncrementBy: Integer): string;
  1408. begin
  1409. Result := Format('SELECT nextval(''%s'')', [SequenceName]);
  1410. end;
  1411. procedure TPQConnection.LoadBlobIntoBuffer(FieldDef: TFieldDef;
  1412. ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction: TSQLTransaction);
  1413. var
  1414. x : integer;
  1415. li : Longint;
  1416. begin
  1417. with cursor as TPQCursor do
  1418. begin
  1419. x := FieldBinding[FieldDef.FieldNo-1].Index;
  1420. li := pqgetlength(res,curtuple,x);
  1421. ReAllocMem(ABlobBuf^.BlobBuffer^.Buffer,li);
  1422. Move(pqgetvalue(res,CurTuple,x)^, ABlobBuf^.BlobBuffer^.Buffer^, li);
  1423. ABlobBuf^.BlobBuffer^.Size := li;
  1424. end;
  1425. end;
  1426. function TPQConnection.RowsAffected(cursor: TSQLCursor): TRowsCount;
  1427. begin
  1428. if assigned(cursor) and assigned((cursor as TPQCursor).res) then
  1429. Result := StrToIntDef(PQcmdTuples((cursor as TPQCursor).res),-1)
  1430. else
  1431. Result := -1;
  1432. end;
  1433. function TPQConnection.GetConnectionInfo(InfoType: TConnInfoType): string;
  1434. begin
  1435. Result:='';
  1436. try
  1437. {$IFDEF LinkDynamically}
  1438. InitialisePostgres3;
  1439. {$ENDIF}
  1440. case InfoType of
  1441. citServerType:
  1442. Result:=TPQConnectionDef.TypeName;
  1443. citServerVersion,
  1444. citServerVersionString:
  1445. if Connected then
  1446. Result:=format('%6.6d', [PQserverVersion(GetHandle)]);
  1447. citClientName:
  1448. Result:=TPQConnectionDef.LoadedLibraryName;
  1449. else
  1450. Result:=inherited GetConnectionInfo(InfoType);
  1451. end;
  1452. finally
  1453. {$IFDEF LinkDynamically}
  1454. ReleasePostgres3;
  1455. {$ENDIF}
  1456. end;
  1457. end;
  1458. { TPQConnectionDef }
  1459. class function TPQConnectionDef.TypeName: String;
  1460. begin
  1461. Result:='PostgreSQL';
  1462. end;
  1463. class function TPQConnectionDef.ConnectionClass: TSQLConnectionClass;
  1464. begin
  1465. Result:=TPQConnection;
  1466. end;
  1467. class function TPQConnectionDef.Description: String;
  1468. begin
  1469. Result:='Connect to a PostgreSQL database directly via the client library';
  1470. end;
  1471. class function TPQConnectionDef.DefaultLibraryName: String;
  1472. begin
  1473. {$IfDef LinkDynamically}
  1474. Result:=pqlib;
  1475. {$else}
  1476. Result:='';
  1477. {$endif}
  1478. end;
  1479. class function TPQConnectionDef.LoadFunction: TLibraryLoadFunction;
  1480. begin
  1481. {$IfDef LinkDynamically}
  1482. Result:=@InitialisePostgres3;
  1483. {$else}
  1484. Result:=Nil;
  1485. {$endif}
  1486. end;
  1487. class function TPQConnectionDef.UnLoadFunction: TLibraryUnLoadFunction;
  1488. begin
  1489. {$IfDef LinkDynamically}
  1490. Result:=@ReleasePostgres3;
  1491. {$else}
  1492. Result:=Nil;
  1493. {$endif}
  1494. end;
  1495. class function TPQConnectionDef.LoadedLibraryName: string;
  1496. begin
  1497. {$IfDef LinkDynamically}
  1498. Result:=Postgres3LoadedLibrary;
  1499. {$else}
  1500. Result:='';
  1501. {$endif}
  1502. end;
  1503. initialization
  1504. RegisterConnection(TPQConnectionDef);
  1505. finalization
  1506. UnRegisterConnection(TPQConnectionDef);
  1507. end.