ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/fbintf/client/2.5/FB25Statement.pas
Revision: 309
Committed: Tue Jul 21 08:00:42 2020 UTC (3 years, 8 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/2.5/FB25Statement.pas
File size: 38438 byte(s)
Log Message:
Fixes Merged

File Contents

# Content
1 (*
2 * Firebird Interface (fbintf). The fbintf components provide a set of
3 * Pascal language bindings for the Firebird API. Although predominantly
4 * a new development they include source code taken from IBX and may be
5 * considered a derived product. This software thus also includes the copyright
6 * notice and license conditions from IBX.
7 *
8 * Except for those parts dervied from IBX, contents of this file are subject
9 * to the Initial Developer's Public License Version 1.0 (the "License"); you
10 * may not use this file except in compliance with the License. You may obtain a
11 * copy of the License here:
12 *
13 * http://www.firebirdsql.org/index.php?op=doc&id=idpl
14 *
15 * Software distributed under the License is distributed on an "AS
16 * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
17 * implied. See the License for the specific language governing rights
18 * and limitations under the License.
19 *
20 * The Initial Developer of the Original Code is Tony Whyman.
21 *
22 * The Original Code is (C) 2016 Tony Whyman, MWA Software
23 * (http://www.mwasoftware.co.uk).
24 *
25 * All Rights Reserved.
26 *
27 * Contributor(s): ______________________________________.
28 *
29 *)
30 {************************************************************************}
31 { }
32 { Borland Delphi Visual Component Library }
33 { InterBase Express core components }
34 { }
35 { Copyright (c) 1998-2000 Inprise Corporation }
36 { }
37 { InterBase Express is based in part on the product }
38 { Free IB Components, written by Gregory H. Deatz for }
39 { Hoagland, Longo, Moran, Dunst & Doukas Company. }
40 { Free IB Components is used under license. }
41 { }
42 { The contents of this file are subject to the InterBase }
43 { Public License Version 1.0 (the "License"); you may not }
44 { use this file except in compliance with the License. You }
45 { may obtain a copy of the License at http://www.Inprise.com/IPL.html }
46 { Software distributed under the License is distributed on }
47 { an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
48 { express or implied. See the License for the specific language }
49 { governing rights and limitations under the License. }
50 { The Original Code was created by InterBase Software Corporation }
51 { and its successors. }
52 { Portions created by Inprise Corporation are Copyright (C) Inprise }
53 { Corporation. All Rights Reserved. }
54 { Contributor(s): Jeff Overcash }
55 { }
56 { IBX For Lazarus (Firebird Express) }
57 { Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
58 { Portions created by MWA Software are copyright McCallum Whyman }
59 { Associates Ltd 2011 - 2015 }
60 { }
61 {************************************************************************}
62 unit FB25Statement;
63 {$IFDEF MSWINDOWS}
64 {$DEFINE WINDOWS}
65 {$ENDIF}
66
67 {$IFDEF FPC}
68 {$mode delphi}
69 {$codepage UTF8}
70 {$interfaces COM}
71 {$ENDIF}
72
73 {This unit is hacked from IBSQL and contains the code for managing an XSQLDA and
74 SQLVars, along with statement preparation, execution and cursor management.
75 Most of the SQLVar code has been moved to unit FBSQLData. Client access is
76 provided through interface rather than direct access to the XSQLDA and XSQLVar
77 objects.}
78
79 {
80 Note on reference counted interfaces.
81 ------------------------------------
82
83 TFB25Statement manages both an input and an output SQLDA through the TIBXINPUTSQLDA
84 and TIBXOUTPUTSQLDA objects. As pure objects, these are explicitly destroyed
85 when the statement is destroyed.
86
87 However, IResultSet is an interface and is returned when a cursor is opened and
88 has a reference for the TIBXOUTPUTSQLDA. The user may discard their reference
89 to the IStatement while still using the IResultSet. This would be a problem if t
90 he underlying TFB25Statement object and its TIBXOUTPUTSQLDA is destroyed while
91 still leaving the TIBXResultSet object in place. Calls to (e.g.) FetchNext would fail.
92
93 To avoid this problem, TResultsSet objects have a reference to the IStatement
94 interface of the TFB25Statement object. Thus, as long as these "copies" exist,
95 the owning statement is not destroyed even if the user discards their reference
96 to the statement. Note: the TFB25Statement does not have a reference to the TIBXResultSet
97 interface. This way circular references are avoided.
98
99 To avoid an IResultSet interface being kept too long and no longer synchronised
100 with the query, each statement includes a prepare sequence number, incremented
101 each time the query is prepared. When the IResultSet interface is created, it
102 noted the current prepare sequence number. Whe an IResult interface is accessed
103 it checks this number against the statement's current prepare sequence number.
104 If not the same, an error is raised.
105
106 A similar strategy is used for the IMetaData, IResults and ISQLParams interfaces.
107 }
108
109 interface
110
111 uses
112 Classes, SysUtils, IB, FBClientAPI, FB25ClientAPI, FB25Transaction, FB25Attachment,
113 IBHeader, IBExternals, FBSQLData, FBOutputBlock, FBStatement, FBActivityMonitor;
114
115 type
116 TFB25Statement = class;
117 TIBXSQLDA = class;
118
119 { TIBXSQLVAR }
120
121 TIBXSQLVAR = class(TSQLVarData)
122 private
123 FStatement: TFB25Statement;
124 FFirebird25ClientAPI: TFB25ClientAPI;
125 FBlob: IBlob; {Cache references}
126 FArray: IArray;
127 FNullIndicator: short;
128 FOwnsSQLData: boolean;
129 FBlobMetaData: IBlobMetaData;
130 FArrayMetaData: IArrayMetaData;
131 FXSQLVAR: PXSQLVAR; { Points to the PXSQLVAR in the owner object }
132 protected
133 function GetSQLType: cardinal; override;
134 function GetSubtype: integer; override;
135 function GetAliasName: AnsiString; override;
136 function GetFieldName: AnsiString; override;
137 function GetOwnerName: AnsiString; override;
138 function GetRelationName: AnsiString; override;
139 function GetScale: integer; override;
140 function GetCharSetID: cardinal; override;
141 function GetCodePage: TSystemCodePage; override;
142 function GetCharSetWidth: integer; override;
143 function GetIsNull: Boolean; override;
144 function GetIsNullable: boolean; override;
145 function GetSQLData: PByte; override;
146 function GetDataLength: cardinal; override;
147 procedure SetIsNull(Value: Boolean); override;
148 procedure SetIsNullable(Value: Boolean); override;
149 procedure SetSQLData(AValue: PByte; len: cardinal); override;
150 procedure SetScale(aValue: integer); override;
151 procedure SetDataLength(len: cardinal); override;
152 procedure SetSQLType(aValue: cardinal); override;
153 procedure SetCharSetID(aValue: cardinal); override;
154 public
155 constructor Create(aParent: TIBXSQLDA; aIndex: integer);
156 procedure FreeSQLData;
157 procedure RowChange; override;
158 function GetAsArray(Array_ID: TISC_QUAD): IArray; override;
159 function GetAsBlob(Blob_ID: TISC_QUAD; BPB: IBPB): IBlob; override;
160 function GetArrayMetaData: IArrayMetaData; override;
161 function GetBlobMetaData: IBlobMetaData; override;
162 function CreateBlob: IBlob; override;
163 procedure Initialize; override;
164
165 property Statement: TFB25Statement read FStatement;
166 end;
167
168 TIBXINPUTSQLDA = class;
169
170 { TIBXSQLDA }
171
172 TIBXSQLDA = class(TSQLDataArea)
173 private
174 FCount: Integer; {Columns in use - may be less than inherited columns}
175 FSize: Integer; {Number of TIBXSQLVARs in column list}
176 FXSQLDA: PXSQLDA;
177 FTransactionSeqNo: integer;
178 function GetRecordSize: Integer;
179 function GetXSQLDA: PXSQLDA;
180 protected
181 FStatement: TFB25Statement;
182 FFirebird25ClientAPI: TFB25ClientAPI;
183 function GetTransactionSeqNo: integer; override;
184 procedure FreeXSQLDA;
185 function GetStatement: IStatement; override;
186 function GetPrepareSeqNo: integer; override;
187 procedure SetCount(Value: Integer); override;
188 public
189 constructor Create(aStatement: TFB25Statement);
190 destructor Destroy; override;
191 function CheckStatementStatus(Request: TStatementStatus): boolean; override;
192 function ColumnsInUseCount: integer; override;
193 function GetTransaction: TFB25Transaction; virtual;
194 procedure Initialize; override;
195 function StateChanged(var ChangeSeqNo: integer): boolean; override;
196 property AsXSQLDA: PXSQLDA read GetXSQLDA;
197 property Count: Integer read FCount write SetCount;
198 property RecordSize: Integer read GetRecordSize;
199 property Statement: TFB25Statement read FStatement;
200 end;
201
202 { TIBXINPUTSQLDA }
203
204 TIBXINPUTSQLDA = class(TIBXSQLDA)
205 public
206 procedure Bind;
207 function IsInputDataArea: boolean; override;
208 end;
209
210
211 { TIBXOUTPUTSQLDA }
212
213 TIBXOUTPUTSQLDA = class(TIBXSQLDA)
214 private
215 FTransaction: TFB25Transaction; {transaction used to execute the statement}
216 public
217 procedure Bind;
218 function GetTransaction: TFB25Transaction; override;
219 procedure GetData(index: integer; var aIsNull: boolean; var len: short;
220 var data: PByte); override;
221 function IsInputDataArea: boolean; override;
222 end;
223
224 { TResultSet }
225
226 TResultSet = class(TResults,IResultSet)
227 private
228 FResults: TIBXOUTPUTSQLDA;
229 FCursorSeqNo: integer;
230 public
231 constructor Create(aResults: TIBXOUTPUTSQLDA);
232 destructor Destroy; override;
233 {IResultSet}
234 function FetchNext: boolean;
235 function GetCursorName: AnsiString;
236 function GetTransaction: ITransaction; override;
237 function IsEof: boolean;
238 procedure Close;
239 end;
240
241 { TFB25Statement }
242
243 TFB25Statement = class(TFBStatement,IStatement)
244 private
245 FDBHandle: TISC_DB_HANDLE;
246 FHandle: TISC_STMT_HANDLE;
247 FFirebird25ClientAPI: TFB25ClientAPI;
248 FSQLParams: TIBXINPUTSQLDA;
249 FSQLRecord: TIBXOUTPUTSQLDA;
250 FCursor: AnsiString; { Cursor name...}
251 FCursorSeqNo: integer;
252 procedure GetPerfCounters(var counters: TPerfStatistics);
253 protected
254 procedure CheckHandle; override;
255 procedure GetDsqlInfo(info_request: byte; buffer: ISQLInfoResults); override;
256 procedure InternalPrepare; override;
257 function InternalExecute(aTransaction: ITransaction): IResults; override;
258 function InternalOpenCursor(aTransaction: ITransaction): IResultSet; override;
259 procedure ProcessSQL(sql: AnsiString; GenerateParamNames: boolean; var processedSQL: AnsiString); override;
260 procedure FreeHandle; override;
261 procedure InternalClose(Force: boolean); override;
262 public
263 constructor Create(Attachment: TFB25Attachment; Transaction: ITransaction;
264 sql: AnsiString; aSQLDialect: integer);
265 constructor CreateWithParameterNames(Attachment: TFB25Attachment;
266 Transaction: ITransaction; sql: AnsiString; aSQLDialect: integer; GenerateParamNames: boolean;
267 CaseSensitiveParams: boolean=false);
268 destructor Destroy; override;
269 function FetchNext: boolean;
270
271 public
272 {IStatement}
273 function GetSQLParams: ISQLParams; override;
274 function GetMetaData: IMetaData; override;
275 function GetPlan: AnsiString;
276 function IsPrepared: boolean;
277 function CreateBlob(column: TColumnMetaData): IBlob; override;
278 function CreateArray(column: TColumnMetaData): IArray; override;
279 procedure SetRetainInterfaces(aValue: boolean); override;
280 property Handle: TISC_STMT_HANDLE read FHandle;
281
282 end;
283
284 implementation
285
286 uses IBUtils, FBMessages, FBBlob, FB25Blob, variants, IBErrorCodes, FBArray, FB25Array
287 {$IFDEF UNIX}, BaseUnix {$ENDIF};
288
289
290 { TIBXSQLVAR }
291
292 function TIBXSQLVAR.GetSQLType: cardinal;
293 begin
294 result := FXSQLVAR^.sqltype and (not 1);
295 end;
296
297 function TIBXSQLVAR.GetSubtype: integer;
298 begin
299 if GetSQLType = SQL_BLOB then
300 result := FXSQLVAR^.sqlsubtype
301 else
302 result := 0;
303 end;
304
305 function TIBXSQLVAR.GetAliasName: AnsiString;
306 begin
307 result := strpas(FXSQLVAR^.aliasname);
308 end;
309
310 function TIBXSQLVAR.GetFieldName: AnsiString;
311 begin
312 result := strpas(FXSQLVAR^.sqlname);
313 end;
314
315 function TIBXSQLVAR.GetOwnerName: AnsiString;
316 begin
317 result := strpas(FXSQLVAR^.ownname);
318 end;
319
320 function TIBXSQLVAR.GetRelationName: AnsiString;
321 begin
322 result := strpas(FXSQLVAR^.relname);
323 end;
324
325 function TIBXSQLVAR.GetScale: integer;
326 begin
327 if GetSQLType = SQL_BLOB then
328 result := 0
329 else
330 result := FXSQLVAR^.sqlscale;
331 end;
332
333 function TIBXSQLVAR.GetCharSetID: cardinal;
334 begin
335 result := 0;
336 case SQLType of
337 SQL_VARYING, SQL_TEXT:
338 {see http://firebirdsql.org/rlsnotesh/rlsnotes210.html}
339 result := FXSQLVAR^.sqlsubtype and $FF;
340
341 SQL_BLOB:
342 if (SQLSubType = 1) then
343 {see http://firebirdsql.org/rlsnotesh/rlsnotes210.html}
344 result := FXSQLVAR^.sqlscale and $FF;
345
346 SQL_ARRAY:
347 if (GetRelationName <> '') and (GetFieldName <> '') then
348 result := GetArrayMetaData.GetCharSetID;
349 end;
350 end;
351
352 function TIBXSQLVAR.GetCodePage: TSystemCodePage;
353 begin
354 result := CP_NONE;
355 with Statement.GetAttachment do
356 CharSetID2CodePage(GetCharSetID,result);
357 end;
358
359 function TIBXSQLVAR.GetCharSetWidth: integer;
360 begin
361 result := 1;
362 with Statement.GetAttachment DO
363 CharSetWidth(GetCharSetID,result);
364 end;
365
366 function TIBXSQLVAR.GetIsNull: Boolean;
367 begin
368 result := IsNullable and (FNullIndicator = -1);
369 end;
370
371 function TIBXSQLVAR.GetIsNullable: boolean;
372 begin
373 result := (FXSQLVAR^.sqltype and 1 = 1);
374 end;
375
376 function TIBXSQLVAR.GetSQLData: PByte;
377 begin
378 Result := FXSQLVAR^.sqldata;
379 end;
380
381 function TIBXSQLVAR.GetDataLength: cardinal;
382 begin
383 Result := FXSQLVAR^.sqllen;
384 end;
385
386 function TIBXSQLVAR.GetArrayMetaData: IArrayMetaData;
387 begin
388 if GetSQLType <> SQL_ARRAY then
389 IBError(ibxeInvalidDataConversion,[nil]);
390
391 if FArrayMetaData = nil then
392 FArrayMetaData := TFB25ArrayMetaData.Create(FStatement.GetAttachment as TFB25Attachment,
393 FStatement.GetTransaction as TFB25Transaction,
394 GetRelationName,GetFieldName);
395 Result := FArrayMetaData;
396 end;
397
398 function TIBXSQLVAR.GetBlobMetaData: IBlobMetaData;
399 begin
400 if GetSQLType <> SQL_BLOB then
401 IBError(ibxeInvalidDataConversion,[nil]);
402
403 if FBlobMetaData = nil then
404 FBlobMetaData := TFB25BlobMetaData.Create(FStatement.GetAttachment as TFB25Attachment,
405 FStatement.GetTransaction as TFB25Transaction,
406 GetRelationName,GetFieldName,GetSubType);
407 (FBlobMetaData as TFBBlobMetaData).SetCharSetID(GetCharSetID);
408 Result := FBlobMetaData;
409 end;
410
411 function TIBXSQLVAR.GetAsArray(Array_ID: TISC_QUAD): IArray;
412 begin
413 if SQLType <> SQL_ARRAY then
414 IBError(ibxeInvalidDataConversion,[nil]);
415
416 if IsNull then
417 Result := nil
418 else
419 begin
420 if FArray = nil then
421 FArray := TFB25Array.Create(FStatement.GetAttachment as TFB25Attachment,
422 TIBXSQLDA(Parent).GetTransaction,
423 GetArrayMetaData,Array_ID);
424 Result := FArray;
425 end;
426 end;
427
428 function TIBXSQLVAR.GetAsBlob(Blob_ID: TISC_QUAD; BPB: IBPB): IBlob;
429 begin
430 if FBlob <> nil then
431 Result := FBlob
432 else
433 begin
434 if SQLType <> SQL_BLOB then
435 IBError(ibxeInvalidDataConversion, [nil]);
436 if IsNull then
437 Result := nil
438 else
439 Result := TFB25Blob.Create(FStatement.GetAttachment as TFB25Attachment,
440 TIBXSQLDA(Parent).GetTransaction,
441 GetBlobMetaData,
442 Blob_ID,BPB);
443 FBlob := Result;
444 end;
445 end;
446
447 function TIBXSQLVAR.CreateBlob: IBlob;
448 begin
449 Result := TFB25Blob.Create(FStatement.GetAttachment as TFB25Attachment,
450 FStatement.GetTransaction as TFB25Transaction,GetSubType,GetCharSetID,nil);
451 end;
452
453 procedure TIBXSQLVAR.Initialize;
454 begin
455 inherited Initialize;
456 FOwnsSQLData := true;
457 with FFirebird25ClientAPI, FXSQLVar^ do
458 begin
459 case sqltype and (not 1) of
460 SQL_TEXT, SQL_TYPE_DATE, SQL_TYPE_TIME, SQL_TIMESTAMP,
461 SQL_BLOB, SQL_ARRAY, SQL_QUAD, SQL_SHORT, SQL_BOOLEAN,
462 SQL_LONG, SQL_INT64, SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: begin
463 if (sqllen = 0) then
464 { Make sure you get a valid pointer anyway
465 select '' from foo }
466 IBAlloc(sqldata, 0, 1)
467 else
468 IBAlloc(sqldata, 0, sqllen)
469 end;
470 SQL_VARYING: begin
471 IBAlloc(sqldata, 0, sqllen + 2);
472 end;
473 else
474 IBError(ibxeUnknownSQLDataType, [sqltype and (not 1)])
475 end;
476 if (sqltype and 1 = 1) then
477 begin
478 sqlInd := @FNullIndicator;
479 FNullIndicator := -1;
480 end
481 else
482 sqlInd := nil;
483 end;
484 end;
485
486 procedure TIBXSQLVAR.SetIsNull(Value: Boolean);
487 begin
488 if Value then
489 begin
490 IsNullable := true;
491 FNullIndicator := -1;
492 Changed;
493 end
494 else
495 if ((not Value) and IsNullable) then
496 begin
497 FNullIndicator := 0;
498 Changed;
499 end;
500 end;
501
502 procedure TIBXSQLVAR.SetIsNullable(Value: Boolean);
503 begin
504 if (Value <> IsNullable) then
505 begin
506 if Value then
507 begin
508 FXSQLVAR^.sqltype := FXSQLVAR^.sqltype or 1;
509 FNullIndicator := 0;
510 FXSQLVAR^.sqlInd := @FNullIndicator;
511 end
512 else
513 begin
514 FXSQLVAR^.sqltype := FXSQLVAR^.sqltype and (not 1);
515 FXSQLVAR^.sqlind := nil;
516 end;
517 end;
518 Changed;
519 end;
520
521 procedure TIBXSQLVAR.SetSQLData(AValue: PByte; len: cardinal);
522 begin
523 if FOwnsSQLData then
524 FreeMem(FXSQLVAR^.sqldata);
525 FXSQLVAR^.sqldata := AValue;
526 FXSQLVAR^.sqllen := len;
527 FOwnsSQLData := false;
528 Changed;
529 end;
530
531 procedure TIBXSQLVAR.SetScale(aValue: integer);
532 begin
533 FXSQLVAR^.sqlscale := aValue;
534 Changed;
535 end;
536
537 procedure TIBXSQLVAR.SetDataLength(len: cardinal);
538 begin
539 if not FOwnsSQLData then
540 FXSQLVAR^.sqldata := nil;
541 FXSQLVAR^.sqllen := len;
542 with FFirebird25ClientAPI do
543 IBAlloc(FXSQLVAR^.sqldata, 0, FXSQLVAR^.sqllen);
544 FOwnsSQLData := true;
545 Changed;
546 end;
547
548 procedure TIBXSQLVAR.SetSQLType(aValue: cardinal);
549 begin
550 FXSQLVAR^.sqltype := aValue or (FXSQLVAR^.sqltype and 1);
551 Changed;
552 end;
553
554 procedure TIBXSQLVAR.SetCharSetID(aValue: cardinal);
555 begin
556 if aValue <> GetCharSetID then
557 begin
558 case SQLType of
559 SQL_VARYING, SQL_TEXT:
560 FXSQLVAR^.sqlsubtype := (aValue and $FF) or (FXSQLVAR^.sqlsubtype and not $FF);
561
562 SQL_BLOB,
563 SQL_ARRAY:
564 IBError(ibxeInvalidDataConversion,[nil]);
565 end;
566 Changed;
567 end;
568 end;
569
570 constructor TIBXSQLVAR.Create(aParent: TIBXSQLDA; aIndex: integer);
571 begin
572 inherited Create(aParent,aIndex);
573 FStatement := aParent.Statement;
574 FFirebird25ClientAPI := aParent.FFirebird25ClientAPI;
575 end;
576
577 procedure TIBXSQLVAR.FreeSQLData;
578 begin
579 if FOwnsSQLData then
580 FreeMem(FXSQLVAR^.sqldata);
581 FXSQLVAR^.sqldata := nil;
582 FOwnsSQLData := true;
583 end;
584
585 procedure TIBXSQLVAR.RowChange;
586 begin
587 inherited RowChange;
588 FBlob := nil;
589 FArray := nil;
590 end;
591
592
593 { TResultSet }
594
595 constructor TResultSet.Create(aResults: TIBXOUTPUTSQLDA);
596 begin
597 inherited Create(aResults);
598 FResults := aResults;
599 FCursorSeqNo := aResults.FStatement.FCursorSeqNo;
600 end;
601
602 destructor TResultSet.Destroy;
603 begin
604 Close;
605 inherited Destroy;
606 end;
607
608 function TResultSet.FetchNext: boolean;
609 var i: integer;
610 begin
611 CheckActive;
612 Result := FResults.FStatement.FetchNext;
613 if Result then
614 for i := 0 to getCount - 1 do
615 FResults.Column[i].RowChange;
616 end;
617
618 function TResultSet.GetCursorName: AnsiString;
619 begin
620 Result := FResults.FStatement.FCursor;
621 end;
622
623 function TResultSet.GetTransaction: ITransaction;
624 begin
625 Result := FResults.GetTransaction;
626 end;
627
628 function TResultSet.IsEof: boolean;
629 begin
630 Result := FResults.FStatement.FEof;
631 end;
632
633 procedure TResultSet.Close;
634 begin
635 if FCursorSeqNo = FResults.FStatement.FCursorSeqNo then
636 FResults.FStatement.Close;
637 end;
638
639 { TIBXINPUTSQLDA }
640
641 procedure TIBXINPUTSQLDA.Bind;
642 begin
643 if Count = 0 then
644 Count := 1;
645 with FFirebird25ClientAPI do
646 begin
647 if (FXSQLDA <> nil) then
648 if isc_dsql_describe_bind(StatusVector, @(FStatement.Handle), FStatement.SQLDialect,
649 FXSQLDA) > 0 then
650 IBDataBaseError;
651
652 if FXSQLDA^.sqld > FXSQLDA^.sqln then
653 begin
654 Count := FXSQLDA^.sqld;
655 if isc_dsql_describe_bind(StatusVector, @(FStatement.Handle), FStatement.SQLDialect,
656 FXSQLDA) > 0 then
657 IBDataBaseError;
658 end
659 else
660 if FXSQLDA^.sqld = 0 then
661 Count := 0;
662 end;
663 Initialize;
664 end;
665
666 function TIBXINPUTSQLDA.IsInputDataArea: boolean;
667 begin
668 Result := true;
669 end;
670
671 { TIBXOUTPUTSQLDA }
672
673 procedure TIBXOUTPUTSQLDA.Bind;
674 begin
675 { Allocate an initial output descriptor (with one column) }
676 Count := 1;
677 with FFirebird25ClientAPI do
678 begin
679 { Using isc_dsql_describe, get the right size for the columns... }
680 if isc_dsql_describe(StatusVector, @(FStatement.Handle), FStatement.SQLDialect, FXSQLDA) > 0 then
681 IBDataBaseError;
682
683 if FXSQLDA^.sqld > FXSQLDA^.sqln then
684 begin
685 Count := FXSQLDA^.sqld;
686 if isc_dsql_describe(StatusVector, @(FStatement.Handle), FStatement.SQLDialect, FXSQLDA) > 0 then
687 IBDataBaseError;
688 end
689 else
690 if FXSQLDA^.sqld = 0 then
691 Count := 0;
692 end;
693 Initialize;
694 SetUniqueRelationName;
695 end;
696
697 function TIBXOUTPUTSQLDA.GetTransaction: TFB25Transaction;
698 begin
699 Result := FTransaction;
700 end;
701
702 procedure TIBXOUTPUTSQLDA.GetData(index: integer; var aIsNull:boolean; var len: short;
703 var data: PByte);
704 begin
705 with TIBXSQLVAR(Column[index]), FXSQLVAR^ do
706 begin
707 aIsNull := (sqltype and 1 = 1) and (FNullIndicator = -1);
708 data := sqldata;
709 len := sqllen;
710 if not IsNull and ((sqltype and (not 1)) = SQL_VARYING) then
711 begin
712 with FFirebird25ClientAPI do
713 len := DecodeInteger(data,2);
714 Inc(data,2);
715 end;
716 end;
717 end;
718
719 function TIBXOUTPUTSQLDA.IsInputDataArea: boolean;
720 begin
721 Result := false;
722 end;
723
724 { TIBXSQLDA }
725 constructor TIBXSQLDA.Create(aStatement: TFB25Statement);
726 begin
727 inherited Create;
728 FStatement := aStatement;
729 FFirebird25ClientAPI := aStatement.FFirebird25ClientAPI;
730 FSize := 0;
731 // writeln('Creating ',ClassName);
732 end;
733
734 destructor TIBXSQLDA.Destroy;
735 begin
736 FreeXSQLDA;
737 // writeln('Destroying ',ClassName);
738 inherited Destroy;
739 end;
740
741 function TIBXSQLDA.CheckStatementStatus(Request: TStatementStatus): boolean;
742 begin
743 Result := false;
744 case Request of
745 ssPrepared:
746 Result := FStatement.IsPrepared;
747
748 ssExecuteResults:
749 Result :=FStatement.FSingleResults;
750
751 ssCursorOpen:
752 Result := FStatement.FOpen;
753
754 ssBOF:
755 Result := FStatement.FBOF;
756
757 ssEOF:
758 Result := FStatement.FEOF;
759 end;
760 end;
761
762 function TIBXSQLDA.ColumnsInUseCount: integer;
763 begin
764 Result := FCount;
765 end;
766
767 function TIBXSQLDA.GetRecordSize: Integer;
768 begin
769 result := SizeOf(TIBXSQLDA) + XSQLDA_LENGTH(FSize);
770 end;
771
772 function TIBXSQLDA.GetXSQLDA: PXSQLDA;
773 begin
774 result := FXSQLDA;
775 end;
776
777 function TIBXSQLDA.GetTransactionSeqNo: integer;
778 begin
779 Result := FTransactionSeqNo;
780 end;
781
782 procedure TIBXSQLDA.Initialize;
783 begin
784 if FXSQLDA <> nil then
785 inherited Initialize;
786 end;
787
788 function TIBXSQLDA.StateChanged(var ChangeSeqNo: integer): boolean;
789 begin
790 Result := FStatement.ChangeSeqNo <> ChangeSeqNo;
791 if Result then
792 ChangeSeqNo := FStatement.ChangeSeqNo;
793 end;
794
795 function TIBXSQLDA.GetTransaction: TFB25Transaction;
796 begin
797 Result := FStatement.GetTransaction as TFB25Transaction;
798 end;
799
800 procedure TIBXSQLDA.SetCount(Value: Integer);
801 var
802 i, OldSize: Integer;
803 p : PXSQLVAR;
804 begin
805 FCount := Value;
806 if FCount = 0 then
807 FUniqueRelationName := ''
808 else
809 begin
810 if FSize > 0 then
811 OldSize := XSQLDA_LENGTH(FSize)
812 else
813 OldSize := 0;
814 if Count > FSize then
815 begin
816 FFirebird25ClientAPI.IBAlloc(FXSQLDA, OldSize, XSQLDA_LENGTH(Count));
817 SetLength(FColumnList, FCount);
818 FXSQLDA^.version := SQLDA_VERSION1;
819 p := @FXSQLDA^.sqlvar[0];
820 for i := 0 to Count - 1 do
821 begin
822 if i >= FSize then
823 FColumnList[i] := TIBXSQLVAR.Create(self,i);
824 TIBXSQLVAR(Column[i]).FXSQLVAR := p;
825 p := Pointer(PAnsiChar(p) + sizeof(FXSQLDA^.sqlvar));
826 end;
827 FSize := inherited Count;
828 end;
829 if FSize > 0 then
830 begin
831 FXSQLDA^.sqln := Value;
832 FXSQLDA^.sqld := Value;
833 end;
834 end;
835 end;
836
837 procedure TIBXSQLDA.FreeXSQLDA;
838 var i: integer;
839 begin
840 if FXSQLDA <> nil then
841 begin
842 // writeln('SQLDA Cleanup');
843 for i := 0 to Count - 1 do
844 TIBXSQLVAR(Column[i]).FreeSQLData;
845 FreeMem(FXSQLDA);
846 FXSQLDA := nil;
847 end;
848 for i := 0 to FSize - 1 do
849 TIBXSQLVAR(Column[i]).Free;
850 SetLength(FColumnList,0);
851 FSize := 0;
852 end;
853
854 function TIBXSQLDA.GetStatement: IStatement;
855 begin
856 Result := FStatement;
857 end;
858
859 function TIBXSQLDA.GetPrepareSeqNo: integer;
860 begin
861 Result := FStatement.FPrepareSeqNo;
862 end;
863
864 { TFB25Statement }
865
866 procedure TFB25Statement.GetPerfCounters(var counters: TPerfStatistics);
867 var DBInfo: IDBInformation;
868 i: integer;
869 {$IFDEF UNIX}
870 times: tms;
871 {$ENDIF}
872 begin
873 {$IFDEF UNIX}
874 FpTimes(times);
875 counters[psUserTime] := times.tms_utime;
876 {$ELSE}
877 counters[psUserTime] := 0;
878 {$ENDIF}
879 counters[psRealTime] := TimeStampToMSecs(DateTimeToTimeStamp(Now));
880
881 DBInfo := GetAttachment.GetDBInformation([isc_info_reads,isc_info_writes,
882 isc_info_fetches, isc_info_num_buffers, isc_info_current_memory,
883 isc_info_max_memory]);
884 if DBInfo <> nil then
885 begin
886 for i := 0 to DBInfo.Count - 1 do
887 with DBInfo[i] do
888 case getItemType of
889 isc_info_reads:
890 counters[psReads] := AsInteger;
891 isc_info_writes:
892 counters[psWrites] := AsInteger;
893 isc_info_fetches:
894 counters[psFetches] := AsInteger;
895 isc_info_num_buffers:
896 counters[psBuffers] := AsInteger;
897 isc_info_current_memory:
898 counters[psCurrentMemory] := AsInteger;
899 isc_info_max_memory:
900 counters[psMaxMemory] := AsInteger;
901 end;
902 end;
903 end;
904
905 procedure TFB25Statement.CheckHandle;
906 begin
907 if FHandle = nil then
908 IBError(ibxeInvalidStatementHandle,[nil]);
909 end;
910
911 procedure TFB25Statement.GetDsqlInfo(info_request: byte; buffer: ISQLInfoResults
912 );
913 begin
914 with FFirebird25ClientAPI, buffer as TSQLInfoResultsBuffer do
915 if isc_dsql_sql_info(StatusVector, @(FHandle), 1, @info_request,
916 GetBufSize, Buffer) > 0 then
917 IBDatabaseError;
918 end;
919
920 procedure TFB25Statement.InternalPrepare;
921 var
922 RB: ISQLInfoResults;
923 TRHandle: TISC_TR_HANDLE;
924 begin
925 if FPrepared then
926 Exit;
927 if (FSQL = '') then
928 IBError(ibxeEmptyQuery, [nil]);
929 try
930 CheckTransaction(FTransactionIntf);
931 with FFirebird25ClientAPI do
932 begin
933 Call(isc_dsql_alloc_statement2(StatusVector, @(FDBHandle),
934 @FHandle), True);
935 TRHandle := (FTransactionIntf as TFB25Transaction).Handle;
936 if FHasParamNames then
937 begin
938 if FProcessedSQL = '' then
939 ProcessSQL(FSQL,FGenerateParamNames,FProcessedSQL);
940 Call(isc_dsql_prepare(StatusVector, @(TRHandle), @FHandle, 0,
941 PAnsiChar(FProcessedSQL), FSQLDialect, nil), True);
942 end
943 else
944 Call(isc_dsql_prepare(StatusVector, @(TRHandle), @FHandle, 0,
945 PAnsiChar(FSQL), FSQLDialect, nil), True);
946 end;
947 { After preparing the statement, query the stmt type and possibly
948 create a FSQLRecord "holder" }
949 { Get the type of the statement }
950 RB := GetDsqlInfo(isc_info_sql_stmt_type);
951 if RB.Count > 0 then
952 FSQLStatementType := TIBSQLStatementTypes(RB[0].GetAsInteger)
953 else
954 FSQLStatementType := SQLUnknown;
955
956 case FSQLStatementType of
957 SQLGetSegment,
958 SQLPutSegment,
959 SQLStartTransaction: begin
960 FreeHandle;
961 IBError(ibxeNotPermitted, [nil]);
962 end;
963 SQLCommit,
964 SQLRollback,
965 SQLDDL, SQLSetGenerator,
966 SQLInsert, SQLUpdate, SQLDelete, SQLSelect, SQLSelectForUpdate,
967 SQLExecProcedure:
968 begin
969 {set up input sqlda}
970 FSQLParams.Bind;
971
972 {setup output sqlda}
973 if FSQLStatementType in [SQLSelect, SQLSelectForUpdate,
974 SQLExecProcedure] then
975 FSQLRecord.Bind;
976 end;
977 end;
978 except
979 on E: Exception do begin
980 if (FHandle <> nil) then
981 FreeHandle;
982 if E is EIBInterBaseError then
983 raise EIBInterBaseError.Create(EIBInterBaseError(E).SQLCode,
984 EIBInterBaseError(E).IBErrorCode,
985 EIBInterBaseError(E).Message +
986 sSQLErrorSeparator + FSQL)
987 else
988 raise;
989 end;
990 end;
991 FPrepared := true;
992 FSingleResults := false;
993 if RetainInterfaces then
994 begin
995 SetRetainInterfaces(false);
996 SetRetainInterfaces(true);
997 end;
998 Inc(FPrepareSeqNo);
999 Inc(FChangeSeqNo);
1000 with FTransactionIntf as TFB25Transaction do
1001 begin
1002 FSQLParams.FTransactionSeqNo := TransactionSeqNo;
1003 FSQLRecord.FTransactionSeqNo := TransactionSeqNo;
1004 end;
1005 end;
1006
1007 function TFB25Statement.InternalExecute(aTransaction: ITransaction): IResults;
1008 var TRHandle: TISC_TR_HANDLE;
1009 begin
1010 Result := nil;
1011 FBOF := false;
1012 FEOF := false;
1013 FSingleResults := false;
1014 CheckTransaction(aTransaction);
1015 if not FPrepared then
1016 InternalPrepare;
1017 CheckHandle;
1018 if aTransaction <> FTransactionIntf then
1019 AddMonitor(aTransaction as TFB25Transaction);
1020 if (FSQLParams.FTransactionSeqNo < (FTransactionIntf as TFB25transaction).TransactionSeqNo) then
1021 IBError(ibxeInterfaceOutofDate,[nil]);
1022
1023 try
1024 TRHandle := (aTransaction as TFB25Transaction).Handle;
1025 with FFirebird25ClientAPI do
1026 begin
1027 if FCollectStatistics then
1028 GetPerfCounters(FBeforeStats);
1029
1030 case FSQLStatementType of
1031 SQLSelect:
1032 IBError(ibxeIsAExecuteProcedure,[]);
1033
1034 SQLExecProcedure:
1035 begin
1036 Call(isc_dsql_execute2(StatusVector,
1037 @(TRHandle),
1038 @FHandle,
1039 SQLDialect,
1040 FSQLParams.AsXSQLDA,
1041 FSQLRecord.AsXSQLDA), True);
1042 Result := TResults.Create(FSQLRecord);
1043 FSingleResults := true;
1044 end
1045 else
1046 Call(isc_dsql_execute(StatusVector,
1047 @(TRHandle),
1048 @FHandle,
1049 SQLDialect,
1050 FSQLParams.AsXSQLDA), True);
1051
1052 end;
1053 if FCollectStatistics then
1054 begin
1055 GetPerfCounters(FAfterStats);
1056 FStatisticsAvailable := true;
1057 end;
1058 end;
1059 finally
1060 if aTransaction <> FTransactionIntf then
1061 RemoveMonitor(aTransaction as TFB25Transaction);
1062 end;
1063 FExecTransactionIntf := aTransaction;
1064 FSQLRecord.FTransaction := aTransaction as TFB25Transaction;
1065 FSQLRecord.FTransactionSeqNo := FSQLRecord.FTransaction.TransactionSeqNo;
1066 Inc(FChangeSeqNo);
1067 end;
1068
1069 function TFB25Statement.InternalOpenCursor(aTransaction: ITransaction
1070 ): IResultSet;
1071 var TRHandle: TISC_TR_HANDLE;
1072 GUID : TGUID;
1073 begin
1074 if FSQLStatementType <> SQLSelect then
1075 IBError(ibxeIsASelectStatement,[]);
1076
1077 CheckTransaction(aTransaction);
1078 if not FPrepared then
1079 InternalPrepare;
1080 CheckHandle;
1081 if aTransaction <> FTransactionIntf then
1082 AddMonitor(aTransaction as TFB25Transaction);
1083 if (FSQLParams.FTransactionSeqNo < (FTransactionIntf as TFB25transaction).TransactionSeqNo) then
1084 IBError(ibxeInterfaceOutofDate,[nil]);
1085
1086 with FFirebird25ClientAPI do
1087 begin
1088 if FCollectStatistics then
1089 GetPerfCounters(FBeforeStats);
1090
1091 TRHandle := (aTransaction as TFB25Transaction).Handle;
1092 Call(isc_dsql_execute2(StatusVector,
1093 @(TRHandle),
1094 @FHandle,
1095 SQLDialect,
1096 FSQLParams.AsXSQLDA,
1097 nil), True);
1098 if FCursor = '' then
1099 begin
1100 CreateGuid(GUID);
1101 FCursor := GUIDToString(GUID);
1102 Call(
1103 isc_dsql_set_cursor_name(StatusVector, @FHandle, PAnsiChar(FCursor), 0),
1104 True);
1105 end;
1106
1107 if FCollectStatistics then
1108 begin
1109 GetPerfCounters(FAfterStats);
1110 FStatisticsAvailable := true;
1111 end;
1112 end;
1113 Inc(FCursorSeqNo);
1114 FSingleResults := false;
1115 FOpen := True;
1116 FExecTransactionIntf := aTransaction;
1117 FBOF := true;
1118 FEOF := false;
1119 FSQLRecord.FTransaction := aTransaction as TFB25Transaction;
1120 FSQLRecord.FTransactionSeqNo := FSQLRecord.FTransaction.TransactionSeqNo;
1121 Result := TResultSet.Create(FSQLRecord);
1122 Inc(FChangeSeqNo);
1123 end;
1124
1125 procedure TFB25Statement.ProcessSQL(sql: AnsiString; GenerateParamNames: boolean;
1126 var processedSQL: AnsiString);
1127 begin
1128 FSQLParams.PreprocessSQL(sql,GenerateParamNames, processedSQL);
1129 end;
1130
1131 procedure TFB25Statement.FreeHandle;
1132 var
1133 isc_res: ISC_STATUS;
1134 begin
1135 Close;
1136 ReleaseInterfaces;
1137 try
1138 if FHandle <> nil then
1139 with FFirebird25ClientAPI do
1140 begin
1141 isc_res :=
1142 Call(isc_dsql_free_statement(StatusVector, @FHandle, DSQL_drop), False);
1143 if (StatusVector^ = 1) and (isc_res > 0) and (isc_res <> isc_bad_stmt_handle) then
1144 IBDataBaseError;
1145 end;
1146 finally
1147 FHandle := nil;
1148 FCursor := '';
1149 FPrepared := false;
1150 end;
1151 end;
1152
1153 procedure TFB25Statement.InternalClose(Force: boolean);
1154 var
1155 isc_res: ISC_STATUS;
1156 begin
1157 if (FHandle <> nil) and (SQLStatementType = SQLSelect) and FOpen then
1158 try
1159 with FFirebird25ClientAPI do
1160 begin
1161 isc_res := Call(
1162 isc_dsql_free_statement(StatusVector, @FHandle, DSQL_close),
1163 False);
1164 if not Force and (StatusVector^ = 1) and (isc_res > 0) and
1165 not getStatus.CheckStatusVector(
1166 [isc_bad_stmt_handle, isc_dsql_cursor_close_err]) then
1167 IBDatabaseError;
1168 end;
1169 finally
1170 if (FSQLRecord.FTransaction <> nil) and (FSQLRecord.FTransaction <> (FTransactionIntf as TFB25Transaction)) then
1171 RemoveMonitor(FSQLRecord.FTransaction);
1172 FOpen := False;
1173 FExecTransactionIntf := nil;
1174 FSQLRecord.FTransaction := nil;
1175 Inc(FChangeSeqNo);
1176 end;
1177 end;
1178
1179 constructor TFB25Statement.Create(Attachment: TFB25Attachment;
1180 Transaction: ITransaction; sql: AnsiString; aSQLDialect: integer);
1181 begin
1182 inherited Create(Attachment,Transaction,sql,aSQLDialect);
1183 FDBHandle := Attachment.Handle;
1184 FFirebird25ClientAPI := Attachment.Firebird25ClientAPI;
1185 OnDatabaseError := FFirebird25ClientAPI.IBDataBaseError;
1186 FSQLParams := TIBXINPUTSQLDA.Create(self);
1187 FSQLRecord := TIBXOUTPUTSQLDA.Create(self);
1188 InternalPrepare;
1189 end;
1190
1191 constructor TFB25Statement.CreateWithParameterNames(
1192 Attachment: TFB25Attachment; Transaction: ITransaction; sql: AnsiString;
1193 aSQLDialect: integer; GenerateParamNames: boolean;
1194 CaseSensitiveParams: boolean);
1195 begin
1196 inherited CreateWithParameterNames(Attachment,Transaction,sql,aSQLDialect,GenerateParamNames);
1197 FDBHandle := Attachment.Handle;
1198 FFirebird25ClientAPI := Attachment.Firebird25ClientAPI;
1199 OnDatabaseError := FFirebird25ClientAPI.IBDataBaseError;
1200 FSQLParams := TIBXINPUTSQLDA.Create(self);
1201 FSQLParams.CaseSensitiveParams := CaseSensitiveParams;
1202 FSQLRecord := TIBXOUTPUTSQLDA.Create(self);
1203 InternalPrepare;
1204 end;
1205
1206 destructor TFB25Statement.Destroy;
1207 begin
1208 inherited Destroy;
1209 if assigned(FSQLParams) then FSQLParams.Free;
1210 if assigned(FSQLRecord) then FSQLRecord.Free;
1211 end;
1212
1213 function TFB25Statement.FetchNext: boolean;
1214 var
1215 fetch_res: ISC_STATUS;
1216 begin
1217 result := false;
1218 if not FOpen then
1219 IBError(ibxeSQLClosed, [nil]);
1220 if FEOF then
1221 IBError(ibxeEOF,[nil]);
1222
1223 with FFirebird25ClientAPI do
1224 begin
1225 { Go to the next record... }
1226 fetch_res :=
1227 Call(isc_dsql_fetch(StatusVector, @FHandle, SQLDialect, FSQLRecord.AsXSQLDA), False);
1228 if (fetch_res = 100) or (getStatus.CheckStatusVector([isc_dsql_cursor_err])) then
1229 begin
1230 FBOF := false;
1231 FEOF := true;
1232 Exit; {End of File}
1233 end
1234 else
1235 if (fetch_res > 0) then
1236 begin
1237 try
1238 IBDataBaseError;
1239 except
1240 Close;
1241 raise;
1242 end;
1243 end
1244 else
1245 begin
1246 FBOF := false;
1247 result := true;
1248 end;
1249 if FCollectStatistics then
1250 begin
1251 GetPerfCounters(FAfterStats);
1252 FStatisticsAvailable := true;
1253 end;
1254 end;
1255 FSQLRecord.RowChange;
1256 if FEOF then
1257 Inc(FChangeSeqNo);
1258 end;
1259
1260 function TFB25Statement.GetSQLParams: ISQLParams;
1261 begin
1262 CheckHandle;
1263 if not HasInterface(0) then
1264 AddInterface(0,TSQLParams.Create(FSQLParams));
1265 Result := TSQLParams(GetInterface(0));
1266 end;
1267
1268 function TFB25Statement.GetMetaData: IMetaData;
1269 begin
1270 CheckHandle;
1271 if not HasInterface(1) then
1272 AddInterface(1, TMetaData.Create(FSQLRecord));
1273 Result := TMetaData(GetInterface(1));
1274 end;
1275
1276 function TFB25Statement.GetPlan: AnsiString;
1277 var
1278 RB: ISQLInfoResults;
1279 begin
1280 if (not (FSQLStatementType in [SQLSelect, SQLSelectForUpdate,
1281 {TODO: SQLExecProcedure, }
1282 SQLUpdate, SQLDelete])) then
1283 result := ''
1284 else
1285 begin
1286 RB := TSQLInfoResultsBuffer.Create(FFirebird25ClientAPI,4*4096);
1287 GetDsqlInfo(isc_info_sql_get_plan,RB);
1288 if RB.Count > 0 then
1289 Result := RB[0].GetAsString;
1290 end;
1291 end;
1292
1293 function TFB25Statement.CreateBlob(column: TColumnMetaData): IBlob;
1294 begin
1295 if assigned(column) and (column.SQLType <> SQL_Blob) then
1296 IBError(ibxeNotABlob,[nil]);
1297 Result := TFB25Blob.Create(GetAttachment as TFB25Attachment,FExecTransactionIntf as TFB25Transaction,
1298 column.GetBlobMetaData,nil);
1299 end;
1300
1301 function TFB25Statement.CreateArray(column: TColumnMetaData): IArray;
1302 begin
1303 if assigned(column) and (column.SQLType <> SQL_ARRAY) then
1304 IBError(ibxeNotAnArray,[nil]);
1305 Result := TFB25Array.Create(GetAttachment as TFB25Attachment,FExecTransactionIntf as TFB25Transaction,
1306 column.GetArrayMetaData);
1307 end;
1308
1309 procedure TFB25Statement.SetRetainInterfaces(aValue: boolean);
1310 begin
1311 inherited SetRetainInterfaces(aValue);
1312 if HasInterface(1) then
1313 TMetaData(GetInterface(1)).RetainInterfaces := aValue;
1314 if HasInterface(0) then
1315 TSQLParams(GetInterface(0)).RetainInterfaces := aValue;
1316 end;
1317
1318 function TFB25Statement.IsPrepared: boolean;
1319 begin
1320 Result := FHandle <> nil;
1321 end;
1322
1323 end.
1324