ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/fbintf/client/2.5/FB25Statement.pas
Revision: 45
Committed: Tue Dec 6 10:33:46 2016 UTC (7 years, 3 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/2.5/FB25Statement.pas
File size: 35161 byte(s)
Log Message:
Committing updates for Release R2-0-0

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