ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/2.5/FB25Statement.pas
Revision: 263
Committed: Thu Dec 6 15:55:01 2018 UTC (5 years, 3 months ago) by tony
Content type: text/x-pascal
File size: 38111 byte(s)
Log Message:
Release 2.3.2 committed

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 GetIsNull: Boolean; override;
143 function GetIsNullable: boolean; override;
144 function GetSQLData: PByte; override;
145 function GetDataLength: cardinal; override;
146 procedure SetIsNull(Value: Boolean); override;
147 procedure SetIsNullable(Value: Boolean); override;
148 procedure SetSQLData(AValue: PByte; len: cardinal); override;
149 procedure SetScale(aValue: integer); override;
150 procedure SetDataLength(len: cardinal); override;
151 procedure SetSQLType(aValue: cardinal); override;
152 procedure SetCharSetID(aValue: cardinal); override;
153 public
154 constructor Create(aParent: TIBXSQLDA; aIndex: integer);
155 procedure FreeSQLData;
156 procedure RowChange; override;
157 function GetAsArray(Array_ID: TISC_QUAD): IArray; override;
158 function GetAsBlob(Blob_ID: TISC_QUAD; BPB: IBPB): IBlob; override;
159 function GetArrayMetaData: IArrayMetaData; override;
160 function GetBlobMetaData: IBlobMetaData; override;
161 function CreateBlob: IBlob; override;
162 procedure Initialize; override;
163
164 property Statement: TFB25Statement read FStatement;
165 end;
166
167 TIBXINPUTSQLDA = class;
168
169 { TIBXSQLDA }
170
171 TIBXSQLDA = class(TSQLDataArea)
172 private
173 FCount: Integer; {Columns in use - may be less than inherited columns}
174 FSize: Integer; {Number of TIBXSQLVARs in column list}
175 FXSQLDA: PXSQLDA;
176 FTransactionSeqNo: integer;
177 function GetRecordSize: Integer;
178 function GetXSQLDA: PXSQLDA;
179 protected
180 FStatement: TFB25Statement;
181 FFirebird25ClientAPI: TFB25ClientAPI;
182 function GetTransactionSeqNo: integer; override;
183 procedure FreeXSQLDA;
184 function GetStatement: IStatement; override;
185 function GetPrepareSeqNo: integer; override;
186 procedure SetCount(Value: Integer); override;
187 public
188 constructor Create(aStatement: TFB25Statement);
189 destructor Destroy; override;
190 function CheckStatementStatus(Request: TStatementStatus): boolean; override;
191 function ColumnsInUseCount: integer; override;
192 function GetTransaction: TFB25Transaction; virtual;
193 procedure Initialize; override;
194 function StateChanged(var ChangeSeqNo: integer): boolean; override;
195 property AsXSQLDA: PXSQLDA read GetXSQLDA;
196 property Count: Integer read FCount write SetCount;
197 property RecordSize: Integer read GetRecordSize;
198 property Statement: TFB25Statement read FStatement;
199 end;
200
201 { TIBXINPUTSQLDA }
202
203 TIBXINPUTSQLDA = class(TIBXSQLDA)
204 public
205 procedure Bind;
206 function IsInputDataArea: boolean; override;
207 end;
208
209
210 { TIBXOUTPUTSQLDA }
211
212 TIBXOUTPUTSQLDA = class(TIBXSQLDA)
213 private
214 FTransaction: TFB25Transaction; {transaction used to execute the statement}
215 public
216 procedure Bind;
217 function GetTransaction: TFB25Transaction; override;
218 procedure GetData(index: integer; var aIsNull: boolean; var len: short;
219 var data: PByte); override;
220 function IsInputDataArea: boolean; override;
221 end;
222
223 { TResultSet }
224
225 TResultSet = class(TResults,IResultSet)
226 private
227 FResults: TIBXOUTPUTSQLDA;
228 FCursorSeqNo: integer;
229 public
230 constructor Create(aResults: TIBXOUTPUTSQLDA);
231 destructor Destroy; override;
232 {IResultSet}
233 function FetchNext: boolean;
234 function GetCursorName: AnsiString;
235 function GetTransaction: ITransaction; override;
236 function IsEof: boolean;
237 procedure Close;
238 end;
239
240 { TFB25Statement }
241
242 TFB25Statement = class(TFBStatement,IStatement)
243 private
244 FDBHandle: TISC_DB_HANDLE;
245 FHandle: TISC_STMT_HANDLE;
246 FFirebird25ClientAPI: TFB25ClientAPI;
247 FSQLParams: TIBXINPUTSQLDA;
248 FSQLRecord: TIBXOUTPUTSQLDA;
249 FCursor: AnsiString; { Cursor name...}
250 FCursorSeqNo: integer;
251 procedure GetPerfCounters(var counters: TPerfStatistics);
252 protected
253 procedure CheckHandle; override;
254 procedure GetDsqlInfo(info_request: byte; buffer: ISQLInfoResults); override;
255 procedure InternalPrepare; override;
256 function InternalExecute(aTransaction: ITransaction): IResults; override;
257 function InternalOpenCursor(aTransaction: ITransaction): IResultSet; override;
258 procedure ProcessSQL(sql: AnsiString; GenerateParamNames: boolean; var processedSQL: AnsiString); override;
259 procedure FreeHandle; override;
260 procedure InternalClose(Force: boolean); override;
261 public
262 constructor Create(Attachment: TFB25Attachment; Transaction: ITransaction;
263 sql: AnsiString; aSQLDialect: integer);
264 constructor CreateWithParameterNames(Attachment: TFB25Attachment;
265 Transaction: ITransaction; sql: AnsiString; aSQLDialect: integer; GenerateParamNames: boolean);
266 destructor Destroy; override;
267 function FetchNext: boolean;
268
269 public
270 {IStatement}
271 function GetSQLParams: ISQLParams; override;
272 function GetMetaData: IMetaData; override;
273 function GetPlan: AnsiString;
274 function IsPrepared: boolean;
275 function CreateBlob(column: TColumnMetaData): IBlob; override;
276 function CreateArray(column: TColumnMetaData): IArray; override;
277 procedure SetRetainInterfaces(aValue: boolean); override;
278 property Handle: TISC_STMT_HANDLE read FHandle;
279
280 end;
281
282 implementation
283
284 uses IBUtils, FBMessages, FBBlob, FB25Blob, variants, IBErrorCodes, FBArray, FB25Array
285 {$IFDEF UNIX}, BaseUnix {$ENDIF};
286
287
288 { TIBXSQLVAR }
289
290 function TIBXSQLVAR.GetSQLType: cardinal;
291 begin
292 result := FXSQLVAR^.sqltype and (not 1);
293 end;
294
295 function TIBXSQLVAR.GetSubtype: integer;
296 begin
297 if GetSQLType = SQL_BLOB then
298 result := FXSQLVAR^.sqlsubtype
299 else
300 result := 0;
301 end;
302
303 function TIBXSQLVAR.GetAliasName: AnsiString;
304 begin
305 result := strpas(FXSQLVAR^.aliasname);
306 end;
307
308 function TIBXSQLVAR.GetFieldName: AnsiString;
309 begin
310 result := strpas(FXSQLVAR^.sqlname);
311 end;
312
313 function TIBXSQLVAR.GetOwnerName: AnsiString;
314 begin
315 result := strpas(FXSQLVAR^.ownname);
316 end;
317
318 function TIBXSQLVAR.GetRelationName: AnsiString;
319 begin
320 result := strpas(FXSQLVAR^.relname);
321 end;
322
323 function TIBXSQLVAR.GetScale: integer;
324 begin
325 if GetSQLType = SQL_BLOB then
326 result := 0
327 else
328 result := FXSQLVAR^.sqlscale;
329 end;
330
331 function TIBXSQLVAR.GetCharSetID: cardinal;
332 begin
333 result := 0;
334 case SQLType of
335 SQL_VARYING, SQL_TEXT:
336 {see http://firebirdsql.org/rlsnotesh/rlsnotes210.html}
337 result := FXSQLVAR^.sqlsubtype and $FF;
338
339 SQL_BLOB:
340 if (SQLSubType = 1) then
341 {see http://firebirdsql.org/rlsnotesh/rlsnotes210.html}
342 result := FXSQLVAR^.sqlscale and $FF;
343
344 SQL_ARRAY:
345 if (GetRelationName <> '') and (GetFieldName <> '') then
346 result := GetArrayMetaData.GetCharSetID;
347 end;
348 end;
349
350 function TIBXSQLVAR.GetCodePage: TSystemCodePage;
351 begin
352 result := CP_NONE;
353 with Statement.GetAttachment do
354 CharSetID2CodePage(GetCharSetID,result);
355 end;
356
357 function TIBXSQLVAR.GetIsNull: Boolean;
358 begin
359 result := IsNullable and (FNullIndicator = -1);
360 end;
361
362 function TIBXSQLVAR.GetIsNullable: boolean;
363 begin
364 result := (FXSQLVAR^.sqltype and 1 = 1);
365 end;
366
367 function TIBXSQLVAR.GetSQLData: PByte;
368 begin
369 Result := FXSQLVAR^.sqldata;
370 end;
371
372 function TIBXSQLVAR.GetDataLength: cardinal;
373 begin
374 Result := FXSQLVAR^.sqllen;
375 end;
376
377 function TIBXSQLVAR.GetArrayMetaData: IArrayMetaData;
378 begin
379 if GetSQLType <> SQL_ARRAY then
380 IBError(ibxeInvalidDataConversion,[nil]);
381
382 if FArrayMetaData = nil then
383 FArrayMetaData := TFB25ArrayMetaData.Create(FStatement.GetAttachment as TFB25Attachment,
384 FStatement.GetTransaction as TFB25Transaction,
385 GetRelationName,GetFieldName);
386 Result := FArrayMetaData;
387 end;
388
389 function TIBXSQLVAR.GetBlobMetaData: IBlobMetaData;
390 begin
391 if GetSQLType <> SQL_BLOB then
392 IBError(ibxeInvalidDataConversion,[nil]);
393
394 if FBlobMetaData = nil then
395 FBlobMetaData := TFB25BlobMetaData.Create(FStatement.GetAttachment as TFB25Attachment,
396 FStatement.GetTransaction as TFB25Transaction,
397 GetRelationName,GetFieldName,GetSubType);
398 (FBlobMetaData as TFBBlobMetaData).SetCharSetID(GetCharSetID);
399 Result := FBlobMetaData;
400 end;
401
402 function TIBXSQLVAR.GetAsArray(Array_ID: TISC_QUAD): IArray;
403 begin
404 if SQLType <> SQL_ARRAY then
405 IBError(ibxeInvalidDataConversion,[nil]);
406
407 if IsNull then
408 Result := nil
409 else
410 begin
411 if FArray = nil then
412 FArray := TFB25Array.Create(FStatement.GetAttachment as TFB25Attachment,
413 TIBXSQLDA(Parent).GetTransaction,
414 GetArrayMetaData,Array_ID);
415 Result := FArray;
416 end;
417 end;
418
419 function TIBXSQLVAR.GetAsBlob(Blob_ID: TISC_QUAD; BPB: IBPB): IBlob;
420 begin
421 if FBlob <> nil then
422 Result := FBlob
423 else
424 begin
425 if SQLType <> SQL_BLOB then
426 IBError(ibxeInvalidDataConversion, [nil]);
427 if IsNull then
428 Result := nil
429 else
430 Result := TFB25Blob.Create(FStatement.GetAttachment as TFB25Attachment,
431 TIBXSQLDA(Parent).GetTransaction,
432 GetBlobMetaData,
433 Blob_ID,BPB);
434 FBlob := Result;
435 end;
436 end;
437
438 function TIBXSQLVAR.CreateBlob: IBlob;
439 begin
440 Result := TFB25Blob.Create(FStatement.GetAttachment as TFB25Attachment,
441 FStatement.GetTransaction as TFB25Transaction,GetSubType,GetCharSetID,nil);
442 end;
443
444 procedure TIBXSQLVAR.Initialize;
445 begin
446 inherited Initialize;
447 FOwnsSQLData := true;
448 with FFirebird25ClientAPI, FXSQLVar^ do
449 begin
450 case sqltype and (not 1) of
451 SQL_TEXT, SQL_TYPE_DATE, SQL_TYPE_TIME, SQL_TIMESTAMP,
452 SQL_BLOB, SQL_ARRAY, SQL_QUAD, SQL_SHORT, SQL_BOOLEAN,
453 SQL_LONG, SQL_INT64, SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: begin
454 if (sqllen = 0) then
455 { Make sure you get a valid pointer anyway
456 select '' from foo }
457 IBAlloc(sqldata, 0, 1)
458 else
459 IBAlloc(sqldata, 0, sqllen)
460 end;
461 SQL_VARYING: begin
462 IBAlloc(sqldata, 0, sqllen + 2);
463 end;
464 else
465 IBError(ibxeUnknownSQLDataType, [sqltype and (not 1)])
466 end;
467 if (sqltype and 1 = 1) then
468 begin
469 sqlInd := @FNullIndicator;
470 FNullIndicator := -1;
471 end
472 else
473 sqlInd := nil;
474 end;
475 end;
476
477 procedure TIBXSQLVAR.SetIsNull(Value: Boolean);
478 begin
479 if Value then
480 begin
481 IsNullable := true;
482 FNullIndicator := -1;
483 Changed;
484 end
485 else
486 if ((not Value) and IsNullable) then
487 begin
488 FNullIndicator := 0;
489 Changed;
490 end;
491 end;
492
493 procedure TIBXSQLVAR.SetIsNullable(Value: Boolean);
494 begin
495 if (Value <> IsNullable) then
496 begin
497 if Value then
498 begin
499 FXSQLVAR^.sqltype := FXSQLVAR^.sqltype or 1;
500 FNullIndicator := 0;
501 FXSQLVAR^.sqlInd := @FNullIndicator;
502 end
503 else
504 begin
505 FXSQLVAR^.sqltype := FXSQLVAR^.sqltype and (not 1);
506 FXSQLVAR^.sqlind := nil;
507 end;
508 end;
509 Changed;
510 end;
511
512 procedure TIBXSQLVAR.SetSQLData(AValue: PByte; len: cardinal);
513 begin
514 if FOwnsSQLData then
515 FreeMem(FXSQLVAR^.sqldata);
516 FXSQLVAR^.sqldata := AValue;
517 FXSQLVAR^.sqllen := len;
518 FOwnsSQLData := false;
519 Changed;
520 end;
521
522 procedure TIBXSQLVAR.SetScale(aValue: integer);
523 begin
524 FXSQLVAR^.sqlscale := aValue;
525 Changed;
526 end;
527
528 procedure TIBXSQLVAR.SetDataLength(len: cardinal);
529 begin
530 if not FOwnsSQLData then
531 FXSQLVAR^.sqldata := nil;
532 FXSQLVAR^.sqllen := len;
533 with FFirebird25ClientAPI do
534 IBAlloc(FXSQLVAR^.sqldata, 0, FXSQLVAR^.sqllen);
535 FOwnsSQLData := true;
536 Changed;
537 end;
538
539 procedure TIBXSQLVAR.SetSQLType(aValue: cardinal);
540 begin
541 FXSQLVAR^.sqltype := aValue or (FXSQLVAR^.sqltype and 1);
542 Changed;
543 end;
544
545 procedure TIBXSQLVAR.SetCharSetID(aValue: cardinal);
546 begin
547 if aValue <> GetCharSetID then
548 begin
549 case SQLType of
550 SQL_VARYING, SQL_TEXT:
551 FXSQLVAR^.sqlsubtype := (aValue and $FF) or (FXSQLVAR^.sqlsubtype and not $FF);
552
553 SQL_BLOB,
554 SQL_ARRAY:
555 IBError(ibxeInvalidDataConversion,[nil]);
556 end;
557 Changed;
558 end;
559 end;
560
561 constructor TIBXSQLVAR.Create(aParent: TIBXSQLDA; aIndex: integer);
562 begin
563 inherited Create(aParent,aIndex);
564 FStatement := aParent.Statement;
565 FFirebird25ClientAPI := aParent.FFirebird25ClientAPI;
566 end;
567
568 procedure TIBXSQLVAR.FreeSQLData;
569 begin
570 if FOwnsSQLData then
571 FreeMem(FXSQLVAR^.sqldata);
572 FXSQLVAR^.sqldata := nil;
573 FOwnsSQLData := true;
574 end;
575
576 procedure TIBXSQLVAR.RowChange;
577 begin
578 inherited RowChange;
579 FBlob := nil;
580 FArray := nil;
581 end;
582
583
584 { TResultSet }
585
586 constructor TResultSet.Create(aResults: TIBXOUTPUTSQLDA);
587 begin
588 inherited Create(aResults);
589 FResults := aResults;
590 FCursorSeqNo := aResults.FStatement.FCursorSeqNo;
591 end;
592
593 destructor TResultSet.Destroy;
594 begin
595 Close;
596 inherited Destroy;
597 end;
598
599 function TResultSet.FetchNext: boolean;
600 var i: integer;
601 begin
602 CheckActive;
603 Result := FResults.FStatement.FetchNext;
604 if Result then
605 for i := 0 to getCount - 1 do
606 FResults.Column[i].RowChange;
607 end;
608
609 function TResultSet.GetCursorName: AnsiString;
610 begin
611 Result := FResults.FStatement.FCursor;
612 end;
613
614 function TResultSet.GetTransaction: ITransaction;
615 begin
616 Result := FResults.GetTransaction;
617 end;
618
619 function TResultSet.IsEof: boolean;
620 begin
621 Result := FResults.FStatement.FEof;
622 end;
623
624 procedure TResultSet.Close;
625 begin
626 if FCursorSeqNo = FResults.FStatement.FCursorSeqNo then
627 FResults.FStatement.Close;
628 end;
629
630 { TIBXINPUTSQLDA }
631
632 procedure TIBXINPUTSQLDA.Bind;
633 begin
634 if Count = 0 then
635 Count := 1;
636 with FFirebird25ClientAPI do
637 begin
638 if (FXSQLDA <> nil) then
639 if isc_dsql_describe_bind(StatusVector, @(FStatement.Handle), FStatement.SQLDialect,
640 FXSQLDA) > 0 then
641 IBDataBaseError;
642
643 if FXSQLDA^.sqld > FXSQLDA^.sqln then
644 begin
645 Count := FXSQLDA^.sqld;
646 if isc_dsql_describe_bind(StatusVector, @(FStatement.Handle), FStatement.SQLDialect,
647 FXSQLDA) > 0 then
648 IBDataBaseError;
649 end
650 else
651 if FXSQLDA^.sqld = 0 then
652 Count := 0;
653 end;
654 Initialize;
655 end;
656
657 function TIBXINPUTSQLDA.IsInputDataArea: boolean;
658 begin
659 Result := true;
660 end;
661
662 { TIBXOUTPUTSQLDA }
663
664 procedure TIBXOUTPUTSQLDA.Bind;
665 begin
666 { Allocate an initial output descriptor (with one column) }
667 Count := 1;
668 with FFirebird25ClientAPI do
669 begin
670 { Using isc_dsql_describe, get the right size for the columns... }
671 if isc_dsql_describe(StatusVector, @(FStatement.Handle), FStatement.SQLDialect, FXSQLDA) > 0 then
672 IBDataBaseError;
673
674 if FXSQLDA^.sqld > FXSQLDA^.sqln then
675 begin
676 Count := FXSQLDA^.sqld;
677 if isc_dsql_describe(StatusVector, @(FStatement.Handle), FStatement.SQLDialect, FXSQLDA) > 0 then
678 IBDataBaseError;
679 end
680 else
681 if FXSQLDA^.sqld = 0 then
682 Count := 0;
683 end;
684 Initialize;
685 SetUniqueRelationName;
686 end;
687
688 function TIBXOUTPUTSQLDA.GetTransaction: TFB25Transaction;
689 begin
690 Result := FTransaction;
691 end;
692
693 procedure TIBXOUTPUTSQLDA.GetData(index: integer; var aIsNull:boolean; var len: short;
694 var data: PByte);
695 begin
696 with TIBXSQLVAR(Column[index]), FXSQLVAR^ do
697 begin
698 aIsNull := (sqltype and 1 = 1) and (FNullIndicator = -1);
699 data := sqldata;
700 len := sqllen;
701 if not IsNull and ((sqltype and (not 1)) = SQL_VARYING) then
702 begin
703 with FFirebird25ClientAPI do
704 len := DecodeInteger(data,2);
705 Inc(data,2);
706 end;
707 end;
708 end;
709
710 function TIBXOUTPUTSQLDA.IsInputDataArea: boolean;
711 begin
712 Result := false;
713 end;
714
715 { TIBXSQLDA }
716 constructor TIBXSQLDA.Create(aStatement: TFB25Statement);
717 begin
718 inherited Create;
719 FStatement := aStatement;
720 FFirebird25ClientAPI := aStatement.FFirebird25ClientAPI;
721 FSize := 0;
722 // writeln('Creating ',ClassName);
723 end;
724
725 destructor TIBXSQLDA.Destroy;
726 begin
727 FreeXSQLDA;
728 // writeln('Destroying ',ClassName);
729 inherited Destroy;
730 end;
731
732 function TIBXSQLDA.CheckStatementStatus(Request: TStatementStatus): boolean;
733 begin
734 Result := false;
735 case Request of
736 ssPrepared:
737 Result := FStatement.IsPrepared;
738
739 ssExecuteResults:
740 Result :=FStatement.FSingleResults;
741
742 ssCursorOpen:
743 Result := FStatement.FOpen;
744
745 ssBOF:
746 Result := FStatement.FBOF;
747
748 ssEOF:
749 Result := FStatement.FEOF;
750 end;
751 end;
752
753 function TIBXSQLDA.ColumnsInUseCount: integer;
754 begin
755 Result := FCount;
756 end;
757
758 function TIBXSQLDA.GetRecordSize: Integer;
759 begin
760 result := SizeOf(TIBXSQLDA) + XSQLDA_LENGTH(FSize);
761 end;
762
763 function TIBXSQLDA.GetXSQLDA: PXSQLDA;
764 begin
765 result := FXSQLDA;
766 end;
767
768 function TIBXSQLDA.GetTransactionSeqNo: integer;
769 begin
770 Result := FTransactionSeqNo;
771 end;
772
773 procedure TIBXSQLDA.Initialize;
774 begin
775 if FXSQLDA <> nil then
776 inherited Initialize;
777 end;
778
779 function TIBXSQLDA.StateChanged(var ChangeSeqNo: integer): boolean;
780 begin
781 Result := FStatement.ChangeSeqNo <> ChangeSeqNo;
782 if Result then
783 ChangeSeqNo := FStatement.ChangeSeqNo;
784 end;
785
786 function TIBXSQLDA.GetTransaction: TFB25Transaction;
787 begin
788 Result := FStatement.GetTransaction as TFB25Transaction;
789 end;
790
791 procedure TIBXSQLDA.SetCount(Value: Integer);
792 var
793 i, OldSize: Integer;
794 p : PXSQLVAR;
795 begin
796 FCount := Value;
797 if FCount = 0 then
798 FUniqueRelationName := ''
799 else
800 begin
801 if FSize > 0 then
802 OldSize := XSQLDA_LENGTH(FSize)
803 else
804 OldSize := 0;
805 if Count > FSize then
806 begin
807 FFirebird25ClientAPI.IBAlloc(FXSQLDA, OldSize, XSQLDA_LENGTH(Count));
808 SetLength(FColumnList, FCount);
809 FXSQLDA^.version := SQLDA_VERSION1;
810 p := @FXSQLDA^.sqlvar[0];
811 for i := 0 to Count - 1 do
812 begin
813 if i >= FSize then
814 FColumnList[i] := TIBXSQLVAR.Create(self,i);
815 TIBXSQLVAR(Column[i]).FXSQLVAR := p;
816 p := Pointer(PAnsiChar(p) + sizeof(FXSQLDA^.sqlvar));
817 end;
818 FSize := inherited Count;
819 end;
820 if FSize > 0 then
821 begin
822 FXSQLDA^.sqln := Value;
823 FXSQLDA^.sqld := Value;
824 end;
825 end;
826 end;
827
828 procedure TIBXSQLDA.FreeXSQLDA;
829 var i: integer;
830 begin
831 if FXSQLDA <> nil then
832 begin
833 // writeln('SQLDA Cleanup');
834 for i := 0 to Count - 1 do
835 TIBXSQLVAR(Column[i]).FreeSQLData;
836 FreeMem(FXSQLDA);
837 FXSQLDA := nil;
838 end;
839 for i := 0 to FSize - 1 do
840 TIBXSQLVAR(Column[i]).Free;
841 SetLength(FColumnList,0);
842 FSize := 0;
843 end;
844
845 function TIBXSQLDA.GetStatement: IStatement;
846 begin
847 Result := FStatement;
848 end;
849
850 function TIBXSQLDA.GetPrepareSeqNo: integer;
851 begin
852 Result := FStatement.FPrepareSeqNo;
853 end;
854
855 { TFB25Statement }
856
857 procedure TFB25Statement.GetPerfCounters(var counters: TPerfStatistics);
858 var DBInfo: IDBInformation;
859 i: integer;
860 {$IFDEF UNIX}
861 times: tms;
862 {$ENDIF}
863 begin
864 {$IFDEF UNIX}
865 FpTimes(times);
866 counters[psUserTime] := times.tms_utime;
867 {$ELSE}
868 counters[psUserTime] := 0;
869 {$ENDIF}
870 counters[psRealTime] := TimeStampToMSecs(DateTimeToTimeStamp(Now));
871
872 DBInfo := GetAttachment.GetDBInformation([isc_info_reads,isc_info_writes,
873 isc_info_fetches, isc_info_num_buffers, isc_info_current_memory,
874 isc_info_max_memory]);
875 if DBInfo <> nil then
876 begin
877 for i := 0 to DBInfo.Count - 1 do
878 with DBInfo[i] do
879 case getItemType of
880 isc_info_reads:
881 counters[psReads] := AsInteger;
882 isc_info_writes:
883 counters[psWrites] := AsInteger;
884 isc_info_fetches:
885 counters[psFetches] := AsInteger;
886 isc_info_num_buffers:
887 counters[psBuffers] := AsInteger;
888 isc_info_current_memory:
889 counters[psCurrentMemory] := AsInteger;
890 isc_info_max_memory:
891 counters[psMaxMemory] := AsInteger;
892 end;
893 end;
894 end;
895
896 procedure TFB25Statement.CheckHandle;
897 begin
898 if FHandle = nil then
899 IBError(ibxeInvalidStatementHandle,[nil]);
900 end;
901
902 procedure TFB25Statement.GetDsqlInfo(info_request: byte; buffer: ISQLInfoResults
903 );
904 begin
905 with FFirebird25ClientAPI, buffer as TSQLInfoResultsBuffer do
906 if isc_dsql_sql_info(StatusVector, @(FHandle), 1, @info_request,
907 GetBufSize, Buffer) > 0 then
908 IBDatabaseError;
909 end;
910
911 procedure TFB25Statement.InternalPrepare;
912 var
913 RB: ISQLInfoResults;
914 TRHandle: TISC_TR_HANDLE;
915 begin
916 if FPrepared then
917 Exit;
918 if (FSQL = '') then
919 IBError(ibxeEmptyQuery, [nil]);
920 try
921 CheckTransaction(FTransactionIntf);
922 with FFirebird25ClientAPI do
923 begin
924 Call(isc_dsql_alloc_statement2(StatusVector, @(FDBHandle),
925 @FHandle), True);
926 TRHandle := (FTransactionIntf as TFB25Transaction).Handle;
927 if FHasParamNames then
928 begin
929 if FProcessedSQL = '' then
930 ProcessSQL(FSQL,FGenerateParamNames,FProcessedSQL);
931 Call(isc_dsql_prepare(StatusVector, @(TRHandle), @FHandle, 0,
932 PAnsiChar(FProcessedSQL), FSQLDialect, nil), True);
933 end
934 else
935 Call(isc_dsql_prepare(StatusVector, @(TRHandle), @FHandle, 0,
936 PAnsiChar(FSQL), FSQLDialect, nil), True);
937 end;
938 { After preparing the statement, query the stmt type and possibly
939 create a FSQLRecord "holder" }
940 { Get the type of the statement }
941 RB := GetDsqlInfo(isc_info_sql_stmt_type);
942 if RB.Count > 0 then
943 FSQLStatementType := TIBSQLStatementTypes(RB[0].GetAsInteger)
944 else
945 FSQLStatementType := SQLUnknown;
946
947 case FSQLStatementType of
948 SQLGetSegment,
949 SQLPutSegment,
950 SQLStartTransaction: begin
951 FreeHandle;
952 IBError(ibxeNotPermitted, [nil]);
953 end;
954 SQLCommit,
955 SQLRollback,
956 SQLDDL, SQLSetGenerator,
957 SQLInsert, SQLUpdate, SQLDelete, SQLSelect, SQLSelectForUpdate,
958 SQLExecProcedure:
959 begin
960 {set up input sqlda}
961 FSQLParams.Bind;
962
963 {setup output sqlda}
964 if FSQLStatementType in [SQLSelect, SQLSelectForUpdate,
965 SQLExecProcedure] then
966 FSQLRecord.Bind;
967 end;
968 end;
969 except
970 on E: Exception do begin
971 if (FHandle <> nil) then
972 FreeHandle;
973 if E is EIBInterBaseError then
974 raise EIBInterBaseError.Create(EIBInterBaseError(E).SQLCode,
975 EIBInterBaseError(E).IBErrorCode,
976 EIBInterBaseError(E).Message +
977 sSQLErrorSeparator + FSQL)
978 else
979 raise;
980 end;
981 end;
982 FPrepared := true;
983 FSingleResults := false;
984 if RetainInterfaces then
985 begin
986 SetRetainInterfaces(false);
987 SetRetainInterfaces(true);
988 end;
989 Inc(FPrepareSeqNo);
990 Inc(FChangeSeqNo);
991 with FTransactionIntf as TFB25Transaction do
992 begin
993 FSQLParams.FTransactionSeqNo := TransactionSeqNo;
994 FSQLRecord.FTransactionSeqNo := TransactionSeqNo;
995 end;
996 end;
997
998 function TFB25Statement.InternalExecute(aTransaction: ITransaction): IResults;
999 var TRHandle: TISC_TR_HANDLE;
1000 begin
1001 Result := nil;
1002 FBOF := false;
1003 FEOF := false;
1004 FSingleResults := false;
1005 CheckTransaction(aTransaction);
1006 if not FPrepared then
1007 InternalPrepare;
1008 CheckHandle;
1009 if aTransaction <> FTransactionIntf then
1010 AddMonitor(aTransaction as TFB25Transaction);
1011 if (FSQLParams.FTransactionSeqNo < (FTransactionIntf as TFB25transaction).TransactionSeqNo) then
1012 IBError(ibxeInterfaceOutofDate,[nil]);
1013
1014 try
1015 TRHandle := (aTransaction as TFB25Transaction).Handle;
1016 with FFirebird25ClientAPI do
1017 begin
1018 if FCollectStatistics then
1019 GetPerfCounters(FBeforeStats);
1020
1021 case FSQLStatementType of
1022 SQLSelect:
1023 IBError(ibxeIsAExecuteProcedure,[]);
1024
1025 SQLExecProcedure:
1026 begin
1027 Call(isc_dsql_execute2(StatusVector,
1028 @(TRHandle),
1029 @FHandle,
1030 SQLDialect,
1031 FSQLParams.AsXSQLDA,
1032 FSQLRecord.AsXSQLDA), True);
1033 Result := TResults.Create(FSQLRecord);
1034 FSingleResults := true;
1035 end
1036 else
1037 Call(isc_dsql_execute(StatusVector,
1038 @(TRHandle),
1039 @FHandle,
1040 SQLDialect,
1041 FSQLParams.AsXSQLDA), True);
1042
1043 end;
1044 if FCollectStatistics then
1045 begin
1046 GetPerfCounters(FAfterStats);
1047 FStatisticsAvailable := true;
1048 end;
1049 end;
1050 finally
1051 if aTransaction <> FTransactionIntf then
1052 RemoveMonitor(aTransaction as TFB25Transaction);
1053 end;
1054 FExecTransactionIntf := aTransaction;
1055 FSQLRecord.FTransaction := aTransaction as TFB25Transaction;
1056 FSQLRecord.FTransactionSeqNo := FSQLRecord.FTransaction.TransactionSeqNo;
1057 Inc(FChangeSeqNo);
1058 end;
1059
1060 function TFB25Statement.InternalOpenCursor(aTransaction: ITransaction
1061 ): IResultSet;
1062 var TRHandle: TISC_TR_HANDLE;
1063 GUID : TGUID;
1064 begin
1065 if FSQLStatementType <> SQLSelect then
1066 IBError(ibxeIsASelectStatement,[]);
1067
1068 CheckTransaction(aTransaction);
1069 if not FPrepared then
1070 InternalPrepare;
1071 CheckHandle;
1072 if aTransaction <> FTransactionIntf then
1073 AddMonitor(aTransaction as TFB25Transaction);
1074 if (FSQLParams.FTransactionSeqNo < (FTransactionIntf as TFB25transaction).TransactionSeqNo) then
1075 IBError(ibxeInterfaceOutofDate,[nil]);
1076
1077 with FFirebird25ClientAPI do
1078 begin
1079 if FCollectStatistics then
1080 GetPerfCounters(FBeforeStats);
1081
1082 TRHandle := (aTransaction as TFB25Transaction).Handle;
1083 Call(isc_dsql_execute2(StatusVector,
1084 @(TRHandle),
1085 @FHandle,
1086 SQLDialect,
1087 FSQLParams.AsXSQLDA,
1088 nil), True);
1089 if FCursor = '' then
1090 begin
1091 CreateGuid(GUID);
1092 FCursor := GUIDToString(GUID);
1093 Call(
1094 isc_dsql_set_cursor_name(StatusVector, @FHandle, PAnsiChar(FCursor), 0),
1095 True);
1096 end;
1097
1098 if FCollectStatistics then
1099 begin
1100 GetPerfCounters(FAfterStats);
1101 FStatisticsAvailable := true;
1102 end;
1103 end;
1104 Inc(FCursorSeqNo);
1105 FSingleResults := false;
1106 FOpen := True;
1107 FExecTransactionIntf := aTransaction;
1108 FBOF := true;
1109 FEOF := false;
1110 FSQLRecord.FTransaction := aTransaction as TFB25Transaction;
1111 FSQLRecord.FTransactionSeqNo := FSQLRecord.FTransaction.TransactionSeqNo;
1112 Result := TResultSet.Create(FSQLRecord);
1113 Inc(FChangeSeqNo);
1114 end;
1115
1116 procedure TFB25Statement.ProcessSQL(sql: AnsiString; GenerateParamNames: boolean;
1117 var processedSQL: AnsiString);
1118 begin
1119 FSQLParams.PreprocessSQL(sql,GenerateParamNames, processedSQL);
1120 end;
1121
1122 procedure TFB25Statement.FreeHandle;
1123 var
1124 isc_res: ISC_STATUS;
1125 begin
1126 Close;
1127 ReleaseInterfaces;
1128 try
1129 if FHandle <> nil then
1130 with FFirebird25ClientAPI do
1131 begin
1132 isc_res :=
1133 Call(isc_dsql_free_statement(StatusVector, @FHandle, DSQL_drop), False);
1134 if (StatusVector^ = 1) and (isc_res > 0) and (isc_res <> isc_bad_stmt_handle) then
1135 IBDataBaseError;
1136 end;
1137 finally
1138 FHandle := nil;
1139 FCursor := '';
1140 FPrepared := false;
1141 end;
1142 end;
1143
1144 procedure TFB25Statement.InternalClose(Force: boolean);
1145 var
1146 isc_res: ISC_STATUS;
1147 begin
1148 if (FHandle <> nil) and (SQLStatementType = SQLSelect) and FOpen then
1149 try
1150 with FFirebird25ClientAPI do
1151 begin
1152 isc_res := Call(
1153 isc_dsql_free_statement(StatusVector, @FHandle, DSQL_close),
1154 False);
1155 if not Force and (StatusVector^ = 1) and (isc_res > 0) and
1156 not getStatus.CheckStatusVector(
1157 [isc_bad_stmt_handle, isc_dsql_cursor_close_err]) then
1158 IBDatabaseError;
1159 end;
1160 finally
1161 if (FSQLRecord.FTransaction <> nil) and (FSQLRecord.FTransaction <> (FTransactionIntf as TFB25Transaction)) then
1162 RemoveMonitor(FSQLRecord.FTransaction);
1163 FOpen := False;
1164 FExecTransactionIntf := nil;
1165 FSQLRecord.FTransaction := nil;
1166 Inc(FChangeSeqNo);
1167 end;
1168 end;
1169
1170 constructor TFB25Statement.Create(Attachment: TFB25Attachment;
1171 Transaction: ITransaction; sql: AnsiString; aSQLDialect: integer);
1172 begin
1173 inherited Create(Attachment,Transaction,sql,aSQLDialect);
1174 FDBHandle := Attachment.Handle;
1175 FFirebird25ClientAPI := Attachment.Firebird25ClientAPI;
1176 OnDatabaseError := FFirebird25ClientAPI.IBDataBaseError;
1177 FSQLParams := TIBXINPUTSQLDA.Create(self);
1178 FSQLRecord := TIBXOUTPUTSQLDA.Create(self);
1179 InternalPrepare;
1180 end;
1181
1182 constructor TFB25Statement.CreateWithParameterNames(Attachment: TFB25Attachment;
1183 Transaction: ITransaction; sql: AnsiString; aSQLDialect: integer;
1184 GenerateParamNames: boolean);
1185 begin
1186 inherited CreateWithParameterNames(Attachment,Transaction,sql,aSQLDialect,GenerateParamNames);
1187 FDBHandle := Attachment.Handle;
1188 FFirebird25ClientAPI := Attachment.Firebird25ClientAPI;
1189 OnDatabaseError := FFirebird25ClientAPI.IBDataBaseError;
1190 FSQLParams := TIBXINPUTSQLDA.Create(self);
1191 FSQLRecord := TIBXOUTPUTSQLDA.Create(self);
1192 InternalPrepare;
1193 end;
1194
1195 destructor TFB25Statement.Destroy;
1196 begin
1197 inherited Destroy;
1198 if assigned(FSQLParams) then FSQLParams.Free;
1199 if assigned(FSQLRecord) then FSQLRecord.Free;
1200 end;
1201
1202 function TFB25Statement.FetchNext: boolean;
1203 var
1204 fetch_res: ISC_STATUS;
1205 begin
1206 result := false;
1207 if not FOpen then
1208 IBError(ibxeSQLClosed, [nil]);
1209 if FEOF then
1210 IBError(ibxeEOF,[nil]);
1211
1212 with FFirebird25ClientAPI do
1213 begin
1214 { Go to the next record... }
1215 fetch_res :=
1216 Call(isc_dsql_fetch(StatusVector, @FHandle, SQLDialect, FSQLRecord.AsXSQLDA), False);
1217 if (fetch_res = 100) or (getStatus.CheckStatusVector([isc_dsql_cursor_err])) then
1218 begin
1219 FBOF := false;
1220 FEOF := true;
1221 Exit; {End of File}
1222 end
1223 else
1224 if (fetch_res > 0) then
1225 begin
1226 try
1227 IBDataBaseError;
1228 except
1229 Close;
1230 raise;
1231 end;
1232 end
1233 else
1234 begin
1235 FBOF := false;
1236 result := true;
1237 end;
1238 if FCollectStatistics then
1239 begin
1240 GetPerfCounters(FAfterStats);
1241 FStatisticsAvailable := true;
1242 end;
1243 end;
1244 FSQLRecord.RowChange;
1245 if FEOF then
1246 Inc(FChangeSeqNo);
1247 end;
1248
1249 function TFB25Statement.GetSQLParams: ISQLParams;
1250 begin
1251 CheckHandle;
1252 if not HasInterface(0) then
1253 AddInterface(0,TSQLParams.Create(FSQLParams));
1254 Result := TSQLParams(GetInterface(0));
1255 end;
1256
1257 function TFB25Statement.GetMetaData: IMetaData;
1258 begin
1259 CheckHandle;
1260 if not HasInterface(1) then
1261 AddInterface(1, TMetaData.Create(FSQLRecord));
1262 Result := TMetaData(GetInterface(1));
1263 end;
1264
1265 function TFB25Statement.GetPlan: AnsiString;
1266 var
1267 RB: ISQLInfoResults;
1268 begin
1269 if (not (FSQLStatementType in [SQLSelect, SQLSelectForUpdate,
1270 {TODO: SQLExecProcedure, }
1271 SQLUpdate, SQLDelete])) then
1272 result := ''
1273 else
1274 begin
1275 RB := TSQLInfoResultsBuffer.Create(FFirebird25ClientAPI,4*4096);
1276 GetDsqlInfo(isc_info_sql_get_plan,RB);
1277 if RB.Count > 0 then
1278 Result := RB[0].GetAsString;
1279 end;
1280 end;
1281
1282 function TFB25Statement.CreateBlob(column: TColumnMetaData): IBlob;
1283 begin
1284 if assigned(column) and (column.SQLType <> SQL_Blob) then
1285 IBError(ibxeNotABlob,[nil]);
1286 Result := TFB25Blob.Create(GetAttachment as TFB25Attachment,FExecTransactionIntf as TFB25Transaction,
1287 column.GetBlobMetaData,nil);
1288 end;
1289
1290 function TFB25Statement.CreateArray(column: TColumnMetaData): IArray;
1291 begin
1292 if assigned(column) and (column.SQLType <> SQL_ARRAY) then
1293 IBError(ibxeNotAnArray,[nil]);
1294 Result := TFB25Array.Create(GetAttachment as TFB25Attachment,FExecTransactionIntf as TFB25Transaction,
1295 column.GetArrayMetaData);
1296 end;
1297
1298 procedure TFB25Statement.SetRetainInterfaces(aValue: boolean);
1299 begin
1300 inherited SetRetainInterfaces(aValue);
1301 if HasInterface(1) then
1302 TMetaData(GetInterface(1)).RetainInterfaces := aValue;
1303 if HasInterface(0) then
1304 TSQLParams(GetInterface(0)).RetainInterfaces := aValue;
1305 end;
1306
1307 function TFB25Statement.IsPrepared: boolean;
1308 begin
1309 Result := FHandle <> nil;
1310 end;
1311
1312 end.
1313