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: 315
Committed: Thu Feb 25 11:56:36 2021 UTC (3 years, 1 month ago) by tony
Content type: text/x-pascal
File size: 38412 byte(s)
Log Message:
Updated for IBX 4 release

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