ibconnection.pp 30 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994
  1. unit IBConnection;
  2. {$mode objfpc}{$H+}
  3. {$Define LinkDynamically}
  4. interface
  5. uses
  6. Classes, SysUtils, sqldb, db, math, dbconst,
  7. {$IfDef LinkDynamically}
  8. ibase60dyn;
  9. {$Else}
  10. ibase60;
  11. {$EndIf}
  12. type
  13. TIBCursor = Class(TSQLCursor)
  14. protected
  15. Status : array [0..19] of ISC_STATUS;
  16. Statement : pointer;
  17. SQLDA : PXSQLDA;
  18. in_SQLDA : PXSQLDA;
  19. ParamBinding : array of integer;
  20. end;
  21. TIBTrans = Class(TSQLHandle)
  22. protected
  23. TransactionHandle : pointer;
  24. TPB : string; // Transaction parameter buffer
  25. Status : array [0..19] of ISC_STATUS;
  26. end;
  27. TIBConnection = class (TSQLConnection)
  28. private
  29. FSQLDatabaseHandle : pointer;
  30. FStatus : array [0..19] of ISC_STATUS;
  31. FDialect : integer;
  32. procedure SetDBDialect;
  33. procedure AllocSQLDA(var aSQLDA : PXSQLDA;Count : integer);
  34. procedure TranslateFldType(SQLType, SQLLen, SQLScale : integer; var LensSet : boolean;
  35. var TrType : TFieldType; var TrLen : word);
  36. // conversion methods
  37. procedure GetDateTime(CurrBuff, Buffer : pointer; AType : integer);
  38. procedure SetDateTime(CurrBuff: pointer; PTime : TDateTime; AType : integer);
  39. procedure GetFloat(CurrBuff, Buffer : pointer; Field : TFieldDef);
  40. procedure CheckError(ProcName : string; Status : array of ISC_STATUS);
  41. function getMaxBlobSize(blobHandle : TIsc_Blob_Handle) : longInt;
  42. procedure SetParameters(cursor : TSQLCursor;AParams : TParams);
  43. procedure FreeSQLDABuffer(var aSQLDA : PXSQLDA);
  44. protected
  45. procedure DoInternalConnect; override;
  46. procedure DoInternalDisconnect; override;
  47. function GetHandle : pointer; override;
  48. Function AllocateCursorHandle : TSQLCursor; override;
  49. Procedure DeAllocateCursorHandle(var cursor : TSQLCursor); override;
  50. Function AllocateTransactionHandle : TSQLHandle; override;
  51. procedure PrepareStatement(cursor: TSQLCursor;ATransaction : TSQLTransaction;buf : string; AParams : TParams); override;
  52. procedure UnPrepareStatement(cursor : TSQLCursor); override;
  53. procedure FreeFldBuffers(cursor : TSQLCursor); override;
  54. procedure Execute(cursor: TSQLCursor;atransaction:tSQLtransaction; AParams : TParams); override;
  55. procedure AddFieldDefs(cursor: TSQLCursor;FieldDefs : TfieldDefs); override;
  56. function Fetch(cursor : TSQLCursor) : boolean; override;
  57. function LoadField(cursor : TSQLCursor;FieldDef : TfieldDef;buffer : pointer) : boolean; override;
  58. function GetTransactionHandle(trans : TSQLHandle): pointer; override;
  59. function Commit(trans : TSQLHandle) : boolean; override;
  60. function RollBack(trans : TSQLHandle) : boolean; override;
  61. function StartdbTransaction(trans : TSQLHandle; AParams : string) : boolean; override;
  62. procedure CommitRetaining(trans : TSQLHandle); override;
  63. procedure RollBackRetaining(trans : TSQLHandle); override;
  64. procedure UpdateIndexDefs(var IndexDefs : TIndexDefs;TableName : string); override;
  65. function GetSchemaInfoSQL(SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string; override;
  66. function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
  67. public
  68. constructor Create(AOwner : TComponent); override;
  69. published
  70. property Dialect : integer read FDialect write FDialect;
  71. property DatabaseName;
  72. property KeepConnection;
  73. property LoginPrompt;
  74. property Params;
  75. property OnLogin;
  76. end;
  77. implementation
  78. uses strutils;
  79. type
  80. TTm = packed record
  81. tm_sec : longint;
  82. tm_min : longint;
  83. tm_hour : longint;
  84. tm_mday : longint;
  85. tm_mon : longint;
  86. tm_year : longint;
  87. tm_wday : longint;
  88. tm_yday : longint;
  89. tm_isdst : longint;
  90. __tm_gmtoff : longint;
  91. __tm_zone : Pchar;
  92. end;
  93. procedure TIBConnection.CheckError(ProcName : string; Status : array of ISC_STATUS);
  94. var
  95. buf : array [0..1024] of char;
  96. p : pointer;
  97. Msg : string;
  98. begin
  99. if ((Status[0] = 1) and (Status[1] <> 0)) then
  100. begin
  101. p := @Status;
  102. msg := '';
  103. while isc_interprete(Buf, @p) > 0 do
  104. Msg := Msg + LineEnding +' -' + StrPas(Buf);
  105. DatabaseError(ProcName + ': ' + Msg,self);
  106. end;
  107. end;
  108. constructor TIBConnection.Create(AOwner : TComponent);
  109. begin
  110. inherited;
  111. FConnOptions := FConnOptions + [sqSupportParams];
  112. end;
  113. function TIBConnection.GetTransactionHandle(trans : TSQLHandle): pointer;
  114. begin
  115. Result := (trans as TIBtrans).TransactionHandle;
  116. end;
  117. function TIBConnection.Commit(trans : TSQLHandle) : boolean;
  118. begin
  119. result := false;
  120. with (trans as TIBTrans) do
  121. if isc_commit_transaction(@Status, @TransactionHandle) <> 0 then
  122. CheckError('Commit', Status)
  123. else result := true;
  124. end;
  125. function TIBConnection.RollBack(trans : TSQLHandle) : boolean;
  126. begin
  127. result := false;
  128. if isc_rollback_transaction(@TIBTrans(trans).Status, @TIBTrans(trans).TransactionHandle) <> 0 then
  129. CheckError('Rollback', TIBTrans(trans).Status)
  130. else result := true;
  131. end;
  132. function TIBConnection.StartDBTransaction(trans : TSQLHandle;AParams : String) : boolean;
  133. var
  134. DBHandle : pointer;
  135. tr : TIBTrans;
  136. i : integer;
  137. s : string;
  138. begin
  139. result := false;
  140. DBHandle := GetHandle;
  141. tr := trans as TIBtrans;
  142. with tr do
  143. begin
  144. TPB := chr(isc_tpb_version3);
  145. i := 1;
  146. s := ExtractSubStr(AParams,i,stdWordDelims);
  147. while s <> '' do
  148. begin
  149. if s='isc_tpb_write' then TPB := TPB + chr(isc_tpb_write)
  150. else if s='isc_tpb_read' then TPB := TPB + chr(isc_tpb_read)
  151. else if s='isc_tpb_consistency' then TPB := TPB + chr(isc_tpb_consistency)
  152. else if s='isc_tpb_concurrency' then TPB := TPB + chr(isc_tpb_concurrency)
  153. else if s='isc_tpb_read_committed' then TPB := TPB + chr(isc_tpb_read_committed)
  154. else if s='isc_tpb_rec_version' then TPB := TPB + chr(isc_tpb_rec_version)
  155. else if s='isc_tpb_no_rec_version' then TPB := TPB + chr(isc_tpb_no_rec_version)
  156. else if s='isc_tpb_wait' then TPB := TPB + chr(isc_tpb_wait)
  157. else if s='isc_tpb_nowait' then TPB := TPB + chr(isc_tpb_nowait)
  158. else if s='isc_tpb_shared' then TPB := TPB + chr(isc_tpb_shared)
  159. else if s='isc_tpb_protected' then TPB := TPB + chr(isc_tpb_protected)
  160. else if s='isc_tpb_exclusive' then TPB := TPB + chr(isc_tpb_exclusive)
  161. else if s='isc_tpb_lock_read' then TPB := TPB + chr(isc_tpb_lock_read)
  162. else if s='isc_tpb_lock_write' then TPB := TPB + chr(isc_tpb_lock_write)
  163. else if s='isc_tpb_verb_time' then TPB := TPB + chr(isc_tpb_verb_time)
  164. else if s='isc_tpb_commit_time' then TPB := TPB + chr(isc_tpb_commit_time)
  165. else if s='isc_tpb_ignore_limbo' then TPB := TPB + chr(isc_tpb_ignore_limbo)
  166. else if s='isc_tpb_autocommit' then TPB := TPB + chr(isc_tpb_autocommit)
  167. else if s='isc_tpb_restart_requests' then TPB := TPB + chr(isc_tpb_restart_requests)
  168. else if s='isc_tpb_no_auto_undo' then TPB := TPB + chr(isc_tpb_no_auto_undo);
  169. s := ExtractSubStr(AParams,i,stdWordDelims);
  170. end;
  171. TransactionHandle := nil;
  172. if isc_start_transaction(@Status, @TransactionHandle, 1,
  173. [@DBHandle, Length(TPB), @TPB[1]]) <> 0 then
  174. CheckError('StartTransaction',Status)
  175. else Result := True;
  176. end;
  177. end;
  178. procedure TIBConnection.CommitRetaining(trans : TSQLHandle);
  179. begin
  180. with trans as TIBtrans do
  181. if isc_commit_retaining(@Status, @TransactionHandle) <> 0 then
  182. CheckError('CommitRetaining', Status);
  183. end;
  184. procedure TIBConnection.RollBackRetaining(trans : TSQLHandle);
  185. begin
  186. with trans as TIBtrans do
  187. if isc_rollback_retaining(@Status, @TransactionHandle) <> 0 then
  188. CheckError('RollBackRetaining', Status);
  189. end;
  190. procedure TIBConnection.DoInternalConnect;
  191. var
  192. DPB : string;
  193. ADatabaseName : String;
  194. begin
  195. {$IfDef LinkDynamically}
  196. InitialiseIBase60;
  197. {$EndIf}
  198. inherited dointernalconnect;
  199. DPB := chr(isc_dpb_version1);
  200. if (UserName <> '') then
  201. begin
  202. DPB := DPB + chr(isc_dpb_user_name) + chr(Length(UserName)) + UserName;
  203. if (Password <> '') then
  204. DPB := DPB + chr(isc_dpb_password) + chr(Length(Password)) + Password;
  205. end;
  206. if (Role <> '') then
  207. DPB := DPB + chr(isc_dpb_sql_role_name) + chr(Length(Role)) + Role;
  208. if Length(CharSet) > 0 then
  209. DPB := DPB + Chr(isc_dpb_lc_ctype) + Chr(Length(CharSet)) + CharSet;
  210. FSQLDatabaseHandle := nil;
  211. if HostName <> '' then ADatabaseName := HostName+':'+DatabaseName
  212. else ADatabaseName := DatabaseName;
  213. if isc_attach_database(@FStatus, Length(ADatabaseName), @ADatabaseName[1], @FSQLDatabaseHandle,
  214. Length(DPB), @DPB[1]) <> 0 then
  215. CheckError('DoInternalConnect', FStatus);
  216. SetDBDialect;
  217. end;
  218. procedure TIBConnection.DoInternalDisconnect;
  219. begin
  220. if not Connected then
  221. begin
  222. FSQLDatabaseHandle := nil;
  223. Exit;
  224. end;
  225. isc_detach_database(@FStatus[0], @FSQLDatabaseHandle);
  226. CheckError('Close', FStatus);
  227. {$IfDef LinkDynamically}
  228. ReleaseIBase60;
  229. {$EndIf}
  230. end;
  231. procedure TIBConnection.SetDBDialect;
  232. var
  233. x : integer;
  234. Len : integer;
  235. Buffer : string;
  236. ResBuf : array [0..39] of byte;
  237. begin
  238. Buffer := Chr(isc_info_db_sql_dialect) + Chr(isc_info_end);
  239. if isc_database_info(@FStatus, @FSQLDatabaseHandle, Length(Buffer),
  240. @Buffer[1], SizeOf(ResBuf), @ResBuf) <> 0 then
  241. CheckError('SetDBDialect', FStatus);
  242. x := 0;
  243. while x < 40 do
  244. case ResBuf[x] of
  245. isc_info_db_sql_dialect :
  246. begin
  247. Inc(x);
  248. Len := isc_vax_integer(@ResBuf[x], 2);
  249. Inc(x, 2);
  250. FDialect := isc_vax_integer(@ResBuf[x], Len);
  251. Inc(x, Len);
  252. end;
  253. isc_info_end : Break;
  254. end;
  255. end;
  256. procedure TIBConnection.AllocSQLDA(var aSQLDA : PXSQLDA;Count : integer);
  257. var x : shortint;
  258. begin
  259. FreeSQLDABuffer(aSQLDA);
  260. if count > -1 then
  261. begin
  262. reAllocMem(aSQLDA, XSQLDA_Length(Count));
  263. { Zero out the memory block to avoid problems with exceptions within the
  264. constructor of this class. }
  265. FillChar(aSQLDA^, XSQLDA_Length(Count), 0);
  266. aSQLDA^.Version := sqlda_version1;
  267. aSQLDA^.SQLN := Count;
  268. end
  269. else
  270. reAllocMem(aSQLDA,0);
  271. end;
  272. procedure TIBConnection.TranslateFldType(SQLType, SQLLen, SQLScale : integer; var LensSet : boolean;
  273. var TrType : TFieldType; var TrLen : word);
  274. begin
  275. LensSet := False;
  276. if (SQLScale >= -4) and (SQLScale <= -1) then //in [-4..-1] then
  277. begin
  278. LensSet := True;
  279. TrLen := SQLLen;
  280. TrType := ftBCD
  281. end
  282. else case (SQLType and not 1) of
  283. SQL_VARYING :
  284. begin
  285. LensSet := True;
  286. TrType := ftString;
  287. TrLen := SQLLen;
  288. end;
  289. SQL_TEXT :
  290. begin
  291. LensSet := True;
  292. TrType := ftString;
  293. TrLen := SQLLen;
  294. end;
  295. SQL_TYPE_DATE :
  296. TrType := ftDate{Time};
  297. SQL_TYPE_TIME :
  298. TrType := ftDateTime;
  299. SQL_TIMESTAMP :
  300. TrType := ftDateTime;
  301. SQL_ARRAY :
  302. begin
  303. TrType := ftArray;
  304. LensSet := true;
  305. TrLen := SQLLen;
  306. end;
  307. SQL_BLOB :
  308. begin
  309. TrType := ftBlob;
  310. LensSet := True;
  311. TrLen := SQLLen;
  312. end;
  313. SQL_SHORT :
  314. TrType := ftInteger;
  315. SQL_LONG :
  316. begin
  317. LensSet := True;
  318. TrLen := 0;
  319. TrType := ftInteger;
  320. end;
  321. SQL_INT64 :
  322. TrType := ftLargeInt;
  323. SQL_DOUBLE :
  324. begin
  325. LensSet := True;
  326. TrLen := SQLLen;
  327. TrType := ftFloat;
  328. end;
  329. SQL_FLOAT :
  330. begin
  331. LensSet := True;
  332. TrLen := SQLLen;
  333. TrType := ftFloat;
  334. end
  335. else
  336. begin
  337. LensSet := True;
  338. TrLen := 0;
  339. TrType := ftUnknown;
  340. end;
  341. end;
  342. end;
  343. Function TIBConnection.AllocateCursorHandle : TSQLCursor;
  344. var curs : TIBCursor;
  345. begin
  346. curs := TIBCursor.create;
  347. curs.sqlda := nil;
  348. curs.statement := nil;
  349. curs.FPrepared := False;
  350. AllocSQLDA(curs.SQLDA,0);
  351. AllocSQLDA(curs.in_SQLDA,0);
  352. result := curs;
  353. end;
  354. procedure TIBConnection.DeAllocateCursorHandle(var cursor : TSQLCursor);
  355. begin
  356. if assigned(cursor) then with cursor as TIBCursor do
  357. begin
  358. AllocSQLDA(SQLDA,-1);
  359. AllocSQLDA(in_SQLDA,-1);
  360. end;
  361. FreeAndNil(cursor);
  362. end;
  363. Function TIBConnection.AllocateTransactionHandle : TSQLHandle;
  364. begin
  365. result := TIBTrans.create;
  366. end;
  367. procedure TIBConnection.PrepareStatement(cursor: TSQLCursor;ATransaction : TSQLTransaction;buf : string; AParams : TParams);
  368. var dh : pointer;
  369. tr : pointer;
  370. p : pchar;
  371. x : shortint;
  372. i : integer;
  373. begin
  374. with cursor as TIBcursor do
  375. begin
  376. dh := GetHandle;
  377. if isc_dsql_allocate_statement(@Status, @dh, @Statement) <> 0 then
  378. CheckError('PrepareStatement', Status);
  379. tr := aTransaction.Handle;
  380. if assigned(AParams) and (AParams.count > 0) then
  381. buf := AParams.ParseSQL(buf,false,psInterbase,paramBinding);
  382. if isc_dsql_prepare(@Status, @tr, @Statement, 0, @Buf[1], Dialect, nil) <> 0 then
  383. CheckError('PrepareStatement', Status);
  384. FPrepared := True;
  385. if assigned(AParams) and (AParams.count > 0) then
  386. begin
  387. AllocSQLDA(in_SQLDA,Length(ParamBinding));
  388. if isc_dsql_describe_bind(@Status, @Statement, 1, in_SQLDA) <> 0 then
  389. CheckError('PrepareStatement', Status);
  390. if in_SQLDA^.SQLD > in_SQLDA^.SQLN then
  391. DatabaseError(SParameterCountIncorrect,self);
  392. {$R-}
  393. for x := 0 to in_SQLDA^.SQLD - 1 do with in_SQLDA^.SQLVar[x] do
  394. begin
  395. if ((SQLType and not 1) = SQL_VARYING) then
  396. SQLData := AllocMem(in_SQLDA^.SQLVar[x].SQLLen+2)
  397. else
  398. SQLData := AllocMem(in_SQLDA^.SQLVar[x].SQLLen);
  399. if (sqltype and 1) = 1 then New(SQLInd);
  400. end;
  401. {$R+}
  402. end;
  403. if FStatementType = stselect then
  404. begin
  405. FPrepared := False;
  406. if isc_dsql_describe(@Status, @Statement, 1, SQLDA) <> 0 then
  407. CheckError('PrepareSelect', Status);
  408. if SQLDA^.SQLD > SQLDA^.SQLN then
  409. begin
  410. AllocSQLDA(SQLDA,SQLDA^.SQLD);
  411. if isc_dsql_describe(@Status, @Statement, 1, SQLDA) <> 0 then
  412. CheckError('PrepareSelect', Status);
  413. end;
  414. {$R-}
  415. for x := 0 to SQLDA^.SQLD - 1 do with SQLDA^.SQLVar[x] do
  416. begin
  417. if ((SQLType and not 1) = SQL_VARYING) then
  418. SQLData := AllocMem(SQLDA^.SQLVar[x].SQLLen+2)
  419. else
  420. SQLData := AllocMem(SQLDA^.SQLVar[x].SQLLen);
  421. if (SQLType and 1) = 1 then New(SQLInd);
  422. end;
  423. {$R+}
  424. end;
  425. end;
  426. end;
  427. procedure TIBConnection.UnPrepareStatement(cursor : TSQLCursor);
  428. begin
  429. with cursor as TIBcursor do
  430. begin
  431. if isc_dsql_free_statement(@Status, @Statement, DSQL_Drop) <> 0 then
  432. CheckError('FreeStatement', Status);
  433. Statement := nil;
  434. FPrepared := False;
  435. end;
  436. end;
  437. procedure TIBConnection.FreeSQLDABuffer(var aSQLDA : PXSQLDA);
  438. var x : shortint;
  439. begin
  440. {$R-}
  441. if assigned(aSQLDA) then
  442. for x := 0 to aSQLDA^.SQLN - 1 do
  443. begin
  444. reAllocMem(aSQLDA^.SQLVar[x].SQLData,0);
  445. if assigned(aSQLDA^.SQLVar[x].sqlind) then
  446. begin
  447. Dispose(aSQLDA^.SQLVar[x].sqlind);
  448. aSQLDA^.SQLVar[x].sqlind := nil;
  449. end
  450. end;
  451. {$R+}
  452. end;
  453. procedure TIBConnection.FreeFldBuffers(cursor : TSQLCursor);
  454. begin
  455. with cursor as TIBCursor do
  456. begin
  457. FreeSQLDABuffer(SQLDA);
  458. FreeSQLDABuffer(in_SQLDA);
  459. end;
  460. end;
  461. procedure TIBConnection.Execute(cursor: TSQLCursor;atransaction:tSQLtransaction; AParams : TParams);
  462. var tr : pointer;
  463. begin
  464. tr := aTransaction.Handle;
  465. if Assigned(APArams) and (AParams.count > 0) then SetParameters(cursor, AParams);
  466. with cursor as TIBCursor do
  467. if isc_dsql_execute2(@Status, @tr, @Statement, 1, in_SQLDA, nil) <> 0 then
  468. CheckError('Execute', Status);
  469. end;
  470. procedure TIBConnection.AddFieldDefs(cursor: TSQLCursor;FieldDefs : TfieldDefs);
  471. var
  472. x : integer;
  473. lenset : boolean;
  474. TransLen : word;
  475. TransType : TFieldType;
  476. FD : TFieldDef;
  477. begin
  478. {$R-}
  479. with cursor as TIBCursor do
  480. begin
  481. for x := 0 to SQLDA^.SQLD - 1 do
  482. begin
  483. TranslateFldType(SQLDA^.SQLVar[x].SQLType, SQLDA^.SQLVar[x].SQLLen, SQLDA^.SQLVar[x].SQLScale,
  484. lenset, TransType, TransLen);
  485. FD := TFieldDef.Create(FieldDefs, SQLDA^.SQLVar[x].AliasName, TransType,
  486. TransLen, False, (x + 1));
  487. if TransType = ftBCD then FD.precision := SQLDA^.SQLVar[x].SQLLen;
  488. FD.DisplayName := SQLDA^.SQLVar[x].AliasName;
  489. end;
  490. end;
  491. {$R+}
  492. end;
  493. function TIBConnection.GetHandle: pointer;
  494. begin
  495. Result := FSQLDatabaseHandle;
  496. end;
  497. function TIBConnection.Fetch(cursor : TSQLCursor) : boolean;
  498. var
  499. retcode : integer;
  500. begin
  501. with cursor as TIBCursor do
  502. begin
  503. retcode := isc_dsql_fetch(@Status, @Statement, 1, SQLDA);
  504. if (retcode <> 0) and (retcode <> 100) then
  505. CheckError('Fetch', Status);
  506. end;
  507. Result := (retcode <> 100);
  508. end;
  509. procedure TIBConnection.SetParameters(cursor : TSQLCursor;AParams : TParams);
  510. var ParNr,SQLVarNr : integer;
  511. s : string;
  512. i : integer;
  513. currbuff : pchar;
  514. w : word;
  515. begin
  516. {$R-}
  517. with cursor as TIBCursor do for SQLVarNr := 0 to High(ParamBinding){AParams.count-1} do
  518. begin
  519. ParNr := ParamBinding[SQLVarNr];
  520. if AParams[ParNr].IsNull then
  521. in_sqlda^.SQLvar[SQLVarNr].SQLInd^ := -1
  522. else
  523. begin
  524. if assigned(in_sqlda^.SQLvar[SQLVarNr].SQLInd) then in_sqlda^.SQLvar[SQLVarNr].SQLInd^ := 0;
  525. case AParams[ParNr].DataType of
  526. ftInteger :
  527. begin
  528. i := AParams[ParNr].AsInteger;
  529. {$R-}
  530. Move(i, in_sqlda^.SQLvar[SQLVarNr].SQLData^, in_SQLDA^.SQLVar[SQLVarNr].SQLLen);
  531. {$R+}
  532. end;
  533. ftString :
  534. begin
  535. {$R-}
  536. s := AParams[ParNr].AsString;
  537. w := length(s);
  538. if ((in_sqlda^.SQLvar[SQLVarNr].SQLType and not 1) = SQL_VARYING) then
  539. begin
  540. in_sqlda^.SQLvar[SQLVarNr].SQLLen := w;
  541. ReAllocMem(in_sqlda^.SQLvar[SQLVarNr].SQLData,in_SQLDA^.SQLVar[SQLVarNr].SQLLen+2);
  542. CurrBuff := in_sqlda^.SQLvar[SQLVarNr].SQLData;
  543. move(w,CurrBuff^,sizeof(w));
  544. inc(CurrBuff,2);
  545. end
  546. else
  547. CurrBuff := in_sqlda^.SQLvar[SQLVarNr].SQLData;
  548. Move(s[1], CurrBuff^, length(s));
  549. {$R+}
  550. end;
  551. ftDate, ftTime, ftDateTime:
  552. {$R-}
  553. SetDateTime(in_sqlda^.SQLvar[SQLVarNr].SQLData, AParams[ParNr].AsDateTime, in_SQLDA^.SQLVar[SQLVarNr].SQLType);
  554. {$R+}
  555. else
  556. begin
  557. DatabaseError('This kind of parameter in not (yet) supported.',self);
  558. end;
  559. end {case}
  560. end;
  561. end;
  562. {$R+}
  563. end;
  564. function TIBConnection.LoadField(cursor : TSQLCursor;FieldDef : TfieldDef;buffer : pointer) : boolean;
  565. var
  566. x : integer;
  567. VarcharLen : word;
  568. CurrBuff : pchar;
  569. b : longint;
  570. li : largeint;
  571. c : currency;
  572. begin
  573. with cursor as TIBCursor do
  574. begin
  575. {$R-}
  576. for x := 0 to SQLDA^.SQLD - 1 do
  577. if SQLDA^.SQLVar[x].AliasName = FieldDef.Name then break;
  578. if SQLDA^.SQLVar[x].AliasName <> FieldDef.Name then
  579. DatabaseErrorFmt(SFieldNotFound,[FieldDef.Name],self);
  580. if assigned(SQLDA^.SQLVar[x].SQLInd) and (SQLDA^.SQLVar[x].SQLInd^ = -1) then
  581. result := false
  582. else
  583. begin
  584. with SQLDA^.SQLVar[x] do
  585. if ((SQLType and not 1) = SQL_VARYING) then
  586. begin
  587. Move(SQLData^, VarcharLen, 2);
  588. CurrBuff := SQLData + 2;
  589. end
  590. else
  591. begin
  592. CurrBuff := SQLData;
  593. VarCharLen := SQLDA^.SQLVar[x].SQLLen;
  594. end;
  595. Result := true;
  596. case FieldDef.DataType of
  597. ftBCD :
  598. begin
  599. c := 0;
  600. Move(CurrBuff^, c, SQLDA^.SQLVar[x].SQLLen);
  601. c := c*intpower(10,4+SQLDA^.SQLVar[x].SQLScale);
  602. Move(c, buffer^ , sizeof(c));
  603. end;
  604. ftInteger :
  605. begin
  606. b := 0;
  607. Move(b, Buffer^, sizeof(longint));
  608. Move(CurrBuff^, Buffer^, SQLDA^.SQLVar[x].SQLLen);
  609. end;
  610. ftLargeint :
  611. begin
  612. li := 0;
  613. Move(CurrBuff^, li, SQLDA^.SQLVar[x].SQLLen);
  614. if SQLDA^.SQLVar[x].SQLScale > 0 then
  615. li := li * trunc(intpower(10, SQLDA^.SQLVar[x].SQLScale))
  616. else if SQLDA^.SQLVar[x].SQLScale < 0 then
  617. li := li div trunc(intpower(10, -SQLDA^.SQLVar[x].SQLScale));
  618. Move(li, Buffer^, SQLDA^.SQLVar[x].SQLLen);
  619. end;
  620. ftDate, ftTime, ftDateTime:
  621. GetDateTime(CurrBuff, Buffer, SQLDA^.SQLVar[x].SQLType);
  622. ftString :
  623. begin
  624. Move(CurrBuff^, Buffer^, SQLDA^.SQLVar[x].SQLLen);
  625. PChar(Buffer + VarCharLen)^ := #0;
  626. end;
  627. ftFloat :
  628. GetFloat(CurrBuff, Buffer, FieldDef);
  629. ftBlob : begin // load the BlobIb in field's buffer
  630. li := 0;
  631. Move(li, Buffer^, sizeof(largeint));
  632. Move(CurrBuff^, Buffer^, SQLDA^.SQLVar[x].SQLLen);
  633. end
  634. else result := false;
  635. end;
  636. end;
  637. {$R+}
  638. end;
  639. end;
  640. procedure TIBConnection.GetDateTime(CurrBuff, Buffer : pointer; AType : integer);
  641. var
  642. CTime : TTm; // C struct time
  643. STime : TSystemTime; // System time
  644. PTime : TDateTime; // Pascal time
  645. begin
  646. case (AType and not 1) of
  647. SQL_TYPE_DATE :
  648. isc_decode_sql_date(PISC_DATE(CurrBuff), @CTime);
  649. SQL_TYPE_TIME :
  650. isc_decode_sql_time(PISC_TIME(CurrBuff), @CTime);
  651. SQL_TIMESTAMP :
  652. isc_decode_timestamp(PISC_TIMESTAMP(CurrBuff), @CTime);
  653. end;
  654. STime.Year := CTime.tm_year + 1900;
  655. STime.Month := CTime.tm_mon + 1;
  656. STime.Day := CTime.tm_mday;
  657. STime.Hour := CTime.tm_hour;
  658. STime.Minute := CTime.tm_min;
  659. STime.Second := CTime.tm_sec;
  660. STime.Millisecond := 0;
  661. PTime := SystemTimeToDateTime(STime);
  662. Move(PTime, Buffer^, SizeOf(PTime));
  663. end;
  664. procedure TIBConnection.SetDateTime(CurrBuff: pointer; PTime : TDateTime; AType : integer);
  665. var
  666. CTime : TTm; // C struct time
  667. STime : TSystemTime; // System time
  668. begin
  669. DateTimeToSystemTime(PTime,STime);
  670. CTime.tm_year := STime.Year - 1900;
  671. CTime.tm_mon := STime.Month -1;
  672. CTime.tm_mday := STime.Day;
  673. CTime.tm_hour := STime.Hour;
  674. CTime.tm_min := STime.Minute;
  675. CTime.tm_sec := STime.Second;
  676. case (AType and not 1) of
  677. SQL_TYPE_DATE :
  678. isc_encode_sql_date(@CTime, PISC_DATE(CurrBuff));
  679. SQL_TYPE_TIME :
  680. isc_encode_sql_time(@CTime, PISC_TIME(CurrBuff));
  681. SQL_TIMESTAMP :
  682. isc_encode_timestamp(@CTime, PISC_TIMESTAMP(CurrBuff));
  683. end;
  684. end;
  685. function TIBConnection.GetSchemaInfoSQL(SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string;
  686. var s : string;
  687. begin
  688. case SchemaType of
  689. stTables : s := 'select '+
  690. 'rdb$relation_id as recno, '+
  691. '''' + DatabaseName + ''' as catalog_name, '+
  692. ''''' as schema_name, '+
  693. 'rdb$relation_name as table_name, '+
  694. '0 as table_type '+
  695. 'from '+
  696. 'rdb$relations '+
  697. 'where '+
  698. '(rdb$system_flag = 0 or rdb$system_flag is null) ' + // and rdb$view_blr is null
  699. 'order by rdb$relation_name';
  700. stSysTables : s := 'select '+
  701. 'rdb$relation_id as recno, '+
  702. '''' + DatabaseName + ''' as catalog_name, '+
  703. ''''' as schema_name, '+
  704. 'rdb$relation_name as table_name, '+
  705. '0 as table_type '+
  706. 'from '+
  707. 'rdb$relations '+
  708. 'where '+
  709. '(rdb$system_flag > 0) ' + // and rdb$view_blr is null
  710. 'order by rdb$relation_name';
  711. stProcedures : s := 'select '+
  712. 'rdb$procedure_id as recno, '+
  713. '''' + DatabaseName + ''' as catalog_name, '+
  714. ''''' as schema_name, '+
  715. 'rdb$procedure_name as proc_name, '+
  716. '0 as proc_type, '+
  717. 'rdb$procedure_inputs as in_params, '+
  718. 'rdb$procedure_outputs as out_params '+
  719. 'from '+
  720. 'rdb$procedures '+
  721. 'WHERE '+
  722. '(rdb$system_flag = 0 or rdb$system_flag is null)';
  723. stColumns : s := 'select '+
  724. 'rdb$field_id as recno, '+
  725. '''' + DatabaseName + ''' as catalog_name, '+
  726. ''''' as schema_name, '+
  727. 'rdb$relation_name as table_name, '+
  728. 'rdb$field_name as column_name, '+
  729. 'rdb$field_position as column_position, '+
  730. '0 as column_type, '+
  731. '0 as column_datatype, '+
  732. ''''' as column_typename, '+
  733. '0 as column_subtype, '+
  734. '0 as column_precision, '+
  735. '0 as column_scale, '+
  736. '0 as column_length, '+
  737. '0 as column_nullable '+
  738. 'from '+
  739. 'rdb$relation_fields '+
  740. 'WHERE '+
  741. '(rdb$system_flag = 0 or rdb$system_flag is null) and (rdb$relation_name = ''' + Uppercase(SchemaObjectName) + ''') ' +
  742. 'order by rdb$field_name';
  743. else
  744. DatabaseError(SMetadataUnavailable)
  745. end; {case}
  746. result := s;
  747. end;
  748. procedure TIBConnection.UpdateIndexDefs(var IndexDefs : TIndexDefs;TableName : string);
  749. var qry : TSQLQuery;
  750. begin
  751. if not assigned(Transaction) then
  752. DatabaseError(SErrConnTransactionnSet);
  753. qry := tsqlquery.Create(nil);
  754. qry.transaction := Transaction;
  755. qry.database := Self;
  756. with qry do
  757. begin
  758. ReadOnly := True;
  759. sql.clear;
  760. sql.add('select '+
  761. 'ind.rdb$index_name, '+
  762. 'ind.rdb$relation_name, '+
  763. 'ind.rdb$unique_flag, '+
  764. 'ind_seg.rdb$field_name, '+
  765. 'rel_con.rdb$constraint_type '+
  766. 'from '+
  767. 'rdb$index_segments ind_seg, '+
  768. 'rdb$indices ind '+
  769. 'left outer join '+
  770. 'rdb$relation_constraints rel_con '+
  771. 'on '+
  772. 'rel_con.rdb$index_name = ind.rdb$index_name '+
  773. 'where '+
  774. '(ind_seg.rdb$index_name = ind.rdb$index_name) and '+
  775. '(ind.rdb$relation_name=''' + UpperCase(TableName) +''') '+
  776. 'order by '+
  777. 'ind.rdb$index_name;');
  778. open;
  779. end;
  780. while not qry.eof do with IndexDefs.AddIndexDef do
  781. begin
  782. Name := trim(qry.fields[0].asstring);
  783. Fields := trim(qry.Fields[3].asstring);
  784. If qry.fields[4].asstring = 'PRIMARY KEY' then options := options + [ixPrimary];
  785. If qry.fields[2].asinteger = 1 then options := options + [ixUnique];
  786. qry.next;
  787. while (name = qry.fields[0].asstring) and (not qry.eof) do
  788. begin
  789. Fields := Fields + ';' + trim(qry.Fields[3].asstring);
  790. qry.next;
  791. end;
  792. end;
  793. qry.close;
  794. qry.free;
  795. end;
  796. procedure TIBConnection.GetFloat(CurrBuff, Buffer : pointer; Field : TFieldDef);
  797. var
  798. Ext : extended;
  799. Dbl : double;
  800. Sin : single;
  801. begin
  802. case Field.Size of
  803. 4 :
  804. begin
  805. Move(CurrBuff^, Sin, 4);
  806. Dbl := Sin;
  807. end;
  808. 8 :
  809. begin
  810. Move(CurrBuff^, Dbl, 8);
  811. end;
  812. 10:
  813. begin
  814. Move(CurrBuff^, Ext, 10);
  815. Dbl := double(Ext);
  816. end;
  817. end;
  818. Move(Dbl, Buffer^, 8);
  819. end;
  820. function TIBConnection.getMaxBlobSize(blobHandle : TIsc_Blob_Handle) : longInt;
  821. var
  822. iscInfoBlobMaxSegment : byte = isc_info_blob_max_segment;
  823. blobInfo : array[0..50] of byte;
  824. begin
  825. if isc_blob_info(@Fstatus, @blobHandle, sizeof(iscInfoBlobMaxSegment), @iscInfoBlobMaxSegment, sizeof(blobInfo) - 2, @blobInfo) <> 0 then
  826. CheckError('isc_blob_info', FStatus);
  827. if blobInfo[0] = isc_info_blob_max_segment then
  828. begin
  829. result := isc_vax_integer(pchar(@blobInfo[3]), isc_vax_integer(pchar(@blobInfo[1]), 2));
  830. end
  831. else
  832. CheckError('isc_blob_info', FStatus);
  833. end;
  834. function TIBConnection.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream;
  835. const
  836. isc_segstr_eof = 335544367; // It's not defined in ibase60 but in ibase40. Would it be better to define in ibase60?
  837. var
  838. mStream : TMemoryStream;
  839. blobHandle : Isc_blob_Handle;
  840. blobSegment : pointer;
  841. blobSegLen : smallint;
  842. maxBlobSize : longInt;
  843. TransactionHandle : pointer;
  844. blobId : ISC_QUAD;
  845. begin
  846. result := nil;
  847. if mode = bmRead then begin
  848. if not field.getData(@blobId) then
  849. exit;
  850. if not assigned(Transaction) then
  851. DatabaseError(SErrConnTransactionnSet);
  852. TransactionHandle := transaction.Handle;
  853. blobHandle := nil;
  854. if isc_open_blob(@FStatus, @FSQLDatabaseHandle, @TransactionHandle, @blobHandle, @blobId) <> 0 then
  855. CheckError('TIBConnection.CreateBlobStream', FStatus);
  856. maxBlobSize := getMaxBlobSize(blobHandle);
  857. blobSegment := AllocMem(maxBlobSize);
  858. mStream := TMemoryStream.create;
  859. while (isc_get_segment(@FStatus, @blobHandle, @blobSegLen, maxBlobSize, blobSegment) = 0) do begin
  860. mStream.writeBuffer(blobSegment^, blobSegLen);
  861. end;
  862. freemem(blobSegment);
  863. mStream.seek(0,soFromBeginning);
  864. if FStatus[1] = isc_segstr_eof then
  865. begin
  866. if isc_close_blob(@FStatus, @blobHandle) <> 0 then
  867. CheckError('TIBConnection.CreateBlobStream isc_close_blob', FStatus);
  868. end
  869. else
  870. CheckError('TIBConnection.CreateBlobStream isc_get_segment', FStatus);
  871. result := mStream;
  872. end;
  873. end;
  874. end.