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: 111
Committed: Thu Jan 18 14:37:53 2018 UTC (6 years, 2 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/2.5/FB25Statement.pas
File size: 37183 byte(s)
Log Message:
Fixes Merged

File Contents

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