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: 47
Committed: Mon Jan 9 15:31:51 2017 UTC (7 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 36793 byte(s)
Log Message:
Committing updates for Release R2-0-1

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