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