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: 68
Committed: Tue Oct 17 10:07:58 2017 UTC (6 years, 5 months ago) by tony
Content type: text/x-pascal
File size: 37044 byte(s)
Log Message:
IBX: Editor Positioning tidy up
FBINTF: Trap uninitialised SQL parameters on SQL Exec. Avoids Unknown SQL Type errors.
Consistent setting of Modified (SQLParam).

File Contents

# Content
1 (*
2 * Firebird Interface (fbintf). The fbintf components provide a set of
3 * Pascal language bindings for the Firebird API. Although predominantly
4 * a new development they include source code taken from IBX and may be
5 * considered a derived product. This software thus also includes the copyright
6 * notice and license conditions from IBX.
7 *
8 * Except for those parts dervied from IBX, contents of this file are subject
9 * to the Initial Developer's Public License Version 1.0 (the "License"); you
10 * may not use this file except in compliance with the License. You may obtain a
11 * copy of the License here:
12 *
13 * http://www.firebirdsql.org/index.php?op=doc&id=idpl
14 *
15 * Software distributed under the License is distributed on an "AS
16 * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
17 * implied. See the License for the specific language governing rights
18 * and limitations under the License.
19 *
20 * The Initial Developer of the Original Code is Tony Whyman.
21 *
22 * The Original Code is (C) 2016 Tony Whyman, MWA Software
23 * (http://www.mwasoftware.co.uk).
24 *
25 * All Rights Reserved.
26 *
27 * Contributor(s): ______________________________________.
28 *
29 *)
30 {************************************************************************}
31 { }
32 { Borland Delphi Visual Component Library }
33 { InterBase Express core components }
34 { }
35 { Copyright (c) 1998-2000 Inprise Corporation }
36 { }
37 { InterBase Express is based in part on the product }
38 { Free IB Components, written by Gregory H. Deatz for }
39 { Hoagland, Longo, Moran, Dunst & Doukas Company. }
40 { Free IB Components is used under license. }
41 { }
42 { The contents of this file are subject to the InterBase }
43 { Public License Version 1.0 (the "License"); you may not }
44 { use this file except in compliance with the License. You }
45 { may obtain a copy of the License at http://www.Inprise.com/IPL.html }
46 { Software distributed under the License is distributed on }
47 { an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
48 { express or implied. See the License for the specific language }
49 { governing rights and limitations under the License. }
50 { The Original Code was created by InterBase Software Corporation }
51 { and its successors. }
52 { Portions created by Inprise Corporation are Copyright (C) Inprise }
53 { Corporation. All Rights Reserved. }
54 { Contributor(s): Jeff Overcash }
55 { }
56 { IBX For Lazarus (Firebird Express) }
57 { Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
58 { Portions created by MWA Software are copyright McCallum Whyman }
59 { Associates Ltd 2011 - 2015 }
60 { }
61 {************************************************************************}
62 unit FB25Statement;
63 {$IFDEF MSWINDOWS}
64 {$DEFINE WINDOWS}
65 {$ENDIF}
66
67 {$IFDEF FPC}
68 {$mode delphi}
69 {$codepage UTF8}
70 {$interfaces COM}
71 {$ENDIF}
72
73 {This unit is hacked from IBSQL and contains the code for managing an XSQLDA and
74 SQLVars, along with statement preparation, execution and cursor management.
75 Most of the SQLVar code has been moved to unit FBSQLData. Client access is
76 provided through interface rather than direct access to the XSQLDA and XSQLVar
77 objects.}
78
79 {
80 Note on reference counted interfaces.
81 ------------------------------------
82
83 TFB25Statement manages both an input and an output SQLDA through the TIBXINPUTSQLDA
84 and TIBXOUTPUTSQLDA objects. As pure objects, these are explicitly destroyed
85 when the statement is destroyed.
86
87 However, IResultSet is an interface and is returned when a cursor is opened and
88 has a reference for the TIBXOUTPUTSQLDA. The user may discard their reference
89 to the IStatement while still using the IResultSet. This would be a problem if t
90 he underlying TFB25Statement object and its TIBXOUTPUTSQLDA is destroyed while
91 still leaving the TIBXResultSet object in place. Calls to (e.g.) FetchNext would fail.
92
93 To avoid this problem, TResultsSet objects have a reference to the IStatement
94 interface of the TFB25Statement object. Thus, as long as these "copies" exist,
95 the owning statement is not destroyed even if the user discards their reference
96 to the statement. Note: the TFB25Statement does not have a reference to the TIBXResultSet
97 interface. This way circular references are avoided.
98
99 To avoid an IResultSet interface being kept too long and no longer synchronised
100 with the query, each statement includes a prepare sequence number, incremented
101 each time the query is prepared. When the IResultSet interface is created, it
102 noted the current prepare sequence number. Whe an IResult interface is accessed
103 it checks this number against the statement's current prepare sequence number.
104 If not the same, an error is raised.
105
106 A similar strategy is used for the IMetaData, IResults and ISQLParams interfaces.
107 }
108
109 interface
110
111 uses
112 Classes, SysUtils, IB, FBClientAPI, FB25ClientAPI, FB25Transaction, FB25Attachment,
113 IBHeader, IBExternals, FBSQLData, FBOutputBlock, FBStatement, FBActivityMonitor;
114
115 type
116 TFB25Statement = class;
117 TIBXSQLDA = class;
118
119 { TIBXSQLVAR }
120
121 TIBXSQLVAR = class(TSQLVarData)
122 private
123 FStatement: TFB25Statement;
124 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 function GetAliasName: AnsiString; override;
135 function GetFieldName: AnsiString; override;
136 function GetOwnerName: AnsiString; override;
137 function GetRelationName: AnsiString; override;
138 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 function GetSQLData: PByte; override;
144 function GetDataLength: cardinal; override;
145 procedure SetIsNull(Value: Boolean); override;
146 procedure SetIsNullable(Value: Boolean); override;
147 procedure SetSQLData(AValue: PByte; len: cardinal); override;
148 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 var data: PByte); override;
218 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 function GetCursorName: AnsiString;
233 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 FCursor: AnsiString; { Cursor name...}
247 FCursorSeqNo: integer;
248 procedure GetPerfCounters(var counters: TPerfStatistics);
249 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 sql: AnsiString; aSQLDialect: integer);
260 constructor CreateWithParameterNames(Attachment: TFB25Attachment;
261 Transaction: ITransaction; sql: AnsiString; aSQLDialect: integer; GenerateParamNames: boolean);
262 destructor Destroy; override;
263 function FetchNext: boolean;
264
265 public
266 {IStatement}
267 function GetSQLParams: ISQLParams; override;
268 function GetMetaData: IMetaData; override;
269 function GetPlan: AnsiString;
270 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 uses IBUtils, FBMessages, FBBlob, FB25Blob, variants, IBErrorCodes, FBArray, FB25Array
281 {$IFDEF UNIX}, BaseUnix {$ENDIF};
282
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 function TIBXSQLVAR.GetAliasName: AnsiString;
300 begin
301 result := strpas(FXSQLVAR^.aliasname);
302 end;
303
304 function TIBXSQLVAR.GetFieldName: AnsiString;
305 begin
306 result := strpas(FXSQLVAR^.sqlname);
307 end;
308
309 function TIBXSQLVAR.GetOwnerName: AnsiString;
310 begin
311 result := strpas(FXSQLVAR^.ownname);
312 end;
313
314 function TIBXSQLVAR.GetRelationName: AnsiString;
315 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 result := FXSQLVAR^.sqlscale and $FF;
339
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 with Statement.GetAttachment do
350 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 function TIBXSQLVAR.GetSQLData: PByte;
364 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 (FBlobMetaData as TFBBlobMetaData).SetCharSetID(GetCharSetID);
395 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 IsNullable := true;
478 FNullIndicator := -1;
479 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 Changed;
506 end;
507
508 procedure TIBXSQLVAR.SetSQLData(AValue: PByte; len: cardinal);
509 begin
510 if FOwnsSQLData then
511 FreeMem(FXSQLVAR^.sqldata);
512 FXSQLVAR^.sqldata := AValue;
513 FXSQLVAR^.sqllen := len;
514 FOwnsSQLData := false;
515 Changed;
516 end;
517
518 procedure TIBXSQLVAR.SetScale(aValue: integer);
519 begin
520 FXSQLVAR^.sqlscale := aValue;
521 Changed;
522 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 Changed;
533 end;
534
535 procedure TIBXSQLVAR.SetSQLType(aValue: cardinal);
536 begin
537 FXSQLVAR^.sqltype := aValue or (FXSQLVAR^.sqltype and 1);
538 Changed;
539 end;
540
541 procedure TIBXSQLVAR.SetCharSetID(aValue: cardinal);
542 begin
543 if aValue <> GetCharSetID then
544 begin
545 case SQLType of
546 SQL_VARYING, SQL_TEXT:
547 FXSQLVAR^.sqlsubtype := (aValue and $FF) or (FXSQLVAR^.sqlsubtype and not $FF);
548
549 SQL_BLOB,
550 SQL_ARRAY:
551 IBError(ibxeInvalidDataConversion,[nil]);
552 end;
553 Changed;
554 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 function TResultSet.GetCursorName: AnsiString;
605 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 var data: PByte);
690 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 p := Pointer(PAnsiChar(p) + sizeof(FXSQLDA^.sqlvar));
811 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 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 counters[psRealTime] := TimeStampToMSecs(DateTimeToTimeStamp(Now));
865
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 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 PAnsiChar(FProcessedSQL), FSQLDialect, nil), True);
927 end
928 else
929 Call(isc_dsql_prepare(StatusVector, @(TRHandle), @FHandle, 0,
930 PAnsiChar(FSQL), FSQLDialect, nil), True);
931 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 if FCollectStatistics then
1013 GetPerfCounters(FBeforeStats);
1014
1015 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 end;
1044 finally
1045 if aTransaction <> FTransactionIntf then
1046 RemoveMonitor(aTransaction as TFB25Transaction);
1047 end;
1048 FExecTransactionIntf := aTransaction;
1049 Inc(FChangeSeqNo);
1050 end;
1051
1052 function TFB25Statement.InternalOpenCursor(aTransaction: ITransaction
1053 ): IResultSet;
1054 var TRHandle: TISC_TR_HANDLE;
1055 GUID : TGUID;
1056 begin
1057 if FSQLStatementType <> SQLSelect then
1058 IBError(ibxeIsASelectStatement,[]);
1059
1060 CheckTransaction(aTransaction);
1061 if not FPrepared then
1062 InternalPrepare;
1063 CheckHandle;
1064 if aTransaction <> FTransactionIntf then
1065 AddMonitor(aTransaction as TFB25Transaction);
1066 if (FSQLParams.FTransactionSeqNo < (FTransactionIntf as TFB25transaction).TransactionSeqNo) then
1067 IBError(ibxeInterfaceOutofDate,[nil]);
1068
1069 with Firebird25ClientAPI do
1070 begin
1071 if FCollectStatistics then
1072 GetPerfCounters(FBeforeStats);
1073
1074 TRHandle := (aTransaction as TFB25Transaction).Handle;
1075 Call(isc_dsql_execute2(StatusVector,
1076 @(TRHandle),
1077 @FHandle,
1078 SQLDialect,
1079 FSQLParams.AsXSQLDA,
1080 nil), True);
1081 if FCursor = '' then
1082 begin
1083 CreateGuid(GUID);
1084 FCursor := GUIDToString(GUID);
1085 Call(
1086 isc_dsql_set_cursor_name(StatusVector, @FHandle, PAnsiChar(FCursor), 0),
1087 True);
1088 end;
1089
1090 if FCollectStatistics then
1091 begin
1092 GetPerfCounters(FAfterStats);
1093 FStatisticsAvailable := true;
1094 end;
1095 end;
1096 Inc(FCursorSeqNo);
1097 FSingleResults := false;
1098 FOpen := True;
1099 FExecTransactionIntf := aTransaction;
1100 FBOF := true;
1101 FEOF := false;
1102 FSQLRecord.FTransaction := aTransaction as TFB25Transaction;
1103 FSQLRecord.FTransactionSeqNo := FSQLRecord.FTransaction.TransactionSeqNo;
1104 Result := TResultSet.Create(FSQLRecord);
1105 Inc(FChangeSeqNo);
1106 end;
1107
1108 procedure TFB25Statement.FreeHandle;
1109 var
1110 isc_res: ISC_STATUS;
1111 begin
1112 Close;
1113 ReleaseInterfaces;
1114 try
1115 if FHandle <> nil then
1116 with Firebird25ClientAPI do
1117 begin
1118 isc_res :=
1119 Call(isc_dsql_free_statement(StatusVector, @FHandle, DSQL_drop), False);
1120 if (StatusVector^ = 1) and (isc_res > 0) and (isc_res <> isc_bad_stmt_handle) then
1121 IBDataBaseError;
1122 end;
1123 finally
1124 FHandle := nil;
1125 FCursor := '';
1126 FPrepared := false;
1127 end;
1128 end;
1129
1130 procedure TFB25Statement.InternalClose(Force: boolean);
1131 var
1132 isc_res: ISC_STATUS;
1133 begin
1134 if (FHandle <> nil) and (SQLStatementType = SQLSelect) and FOpen then
1135 try
1136 with Firebird25ClientAPI do
1137 begin
1138 isc_res := Call(
1139 isc_dsql_free_statement(StatusVector, @FHandle, DSQL_close),
1140 False);
1141 if not Force and (StatusVector^ = 1) and (isc_res > 0) and
1142 not getStatus.CheckStatusVector(
1143 [isc_bad_stmt_handle, isc_dsql_cursor_close_err]) then
1144 IBDatabaseError;
1145 end;
1146 finally
1147 if (FSQLRecord.FTransaction <> nil) and (FSQLRecord.FTransaction <> (FTransactionIntf as TFB25Transaction)) then
1148 RemoveMonitor(FSQLRecord.FTransaction);
1149 FOpen := False;
1150 FExecTransactionIntf := nil;
1151 FSQLRecord.FTransaction := nil;
1152 Inc(FChangeSeqNo);
1153 end;
1154 end;
1155
1156 constructor TFB25Statement.Create(Attachment: TFB25Attachment;
1157 Transaction: ITransaction; sql: AnsiString; aSQLDialect: integer);
1158 begin
1159 inherited Create(Attachment,Transaction,sql,aSQLDialect);
1160 FDBHandle := Attachment.Handle;
1161 FSQLParams := TIBXINPUTSQLDA.Create(self);
1162 FSQLRecord := TIBXOUTPUTSQLDA.Create(self);
1163 InternalPrepare;
1164 end;
1165
1166 constructor TFB25Statement.CreateWithParameterNames(Attachment: TFB25Attachment;
1167 Transaction: ITransaction; sql: AnsiString; aSQLDialect: integer;
1168 GenerateParamNames: boolean);
1169 begin
1170 inherited CreateWithParameterNames(Attachment,Transaction,sql,aSQLDialect,GenerateParamNames);
1171 FDBHandle := Attachment.Handle;
1172 FSQLParams := TIBXINPUTSQLDA.Create(self);
1173 FSQLRecord := TIBXOUTPUTSQLDA.Create(self);
1174 InternalPrepare;
1175 end;
1176
1177 destructor TFB25Statement.Destroy;
1178 begin
1179 inherited Destroy;
1180 if assigned(FSQLParams) then FSQLParams.Free;
1181 if assigned(FSQLRecord) then FSQLRecord.Free;
1182 end;
1183
1184 function TFB25Statement.FetchNext: boolean;
1185 var
1186 fetch_res: ISC_STATUS;
1187 begin
1188 result := false;
1189 if not FOpen then
1190 IBError(ibxeSQLClosed, [nil]);
1191 if FEOF then
1192 IBError(ibxeEOF,[nil]);
1193
1194 with Firebird25ClientAPI do
1195 begin
1196 { Go to the next record... }
1197 fetch_res :=
1198 Call(isc_dsql_fetch(StatusVector, @FHandle, SQLDialect, FSQLRecord.AsXSQLDA), False);
1199 if (fetch_res = 100) or (getStatus.CheckStatusVector([isc_dsql_cursor_err])) then
1200 begin
1201 FBOF := false;
1202 FEOF := true;
1203 Exit; {End of File}
1204 end
1205 else
1206 if (fetch_res > 0) then
1207 begin
1208 try
1209 IBDataBaseError;
1210 except
1211 Close;
1212 raise;
1213 end;
1214 end
1215 else
1216 begin
1217 FBOF := false;
1218 result := true;
1219 end;
1220 end;
1221 FSQLRecord.RowChange;
1222 if FEOF then
1223 Inc(FChangeSeqNo);
1224 end;
1225
1226 function TFB25Statement.GetSQLParams: ISQLParams;
1227 begin
1228 CheckHandle;
1229 if not HasInterface(0) then
1230 AddInterface(0,TSQLParams.Create(FSQLParams));
1231 Result := TSQLParams(GetInterface(0));
1232 end;
1233
1234 function TFB25Statement.GetMetaData: IMetaData;
1235 begin
1236 CheckHandle;
1237 if not HasInterface(1) then
1238 AddInterface(1, TMetaData.Create(FSQLRecord));
1239 Result := TMetaData(GetInterface(1));
1240 end;
1241
1242 function TFB25Statement.GetPlan: AnsiString;
1243 var
1244 RB: ISQLInfoResults;
1245 begin
1246 if (not (FSQLStatementType in [SQLSelect, SQLSelectForUpdate,
1247 {TODO: SQLExecProcedure, }
1248 SQLUpdate, SQLDelete])) then
1249 result := ''
1250 else
1251 begin
1252 RB := TSQLInfoResultsBuffer.Create(4*4096);
1253 GetDsqlInfo(isc_info_sql_get_plan,RB);
1254 if RB.Count > 0 then
1255 Result := RB[0].GetAsString;
1256 end;
1257 end;
1258
1259 function TFB25Statement.CreateBlob(column: TColumnMetaData): IBlob;
1260 begin
1261 if assigned(column) and (column.SQLType <> SQL_Blob) then
1262 IBError(ibxeNotABlob,[nil]);
1263 Result := TFB25Blob.Create(GetAttachment as TFB25Attachment,FExecTransactionIntf as TFB25Transaction,
1264 column.GetBlobMetaData,nil);
1265 end;
1266
1267 function TFB25Statement.CreateArray(column: TColumnMetaData): IArray;
1268 begin
1269 if assigned(column) and (column.SQLType <> SQL_ARRAY) then
1270 IBError(ibxeNotAnArray,[nil]);
1271 Result := TFB25Array.Create(GetAttachment as TFB25Attachment,FExecTransactionIntf as TFB25Transaction,
1272 column.GetArrayMetaData);
1273 end;
1274
1275 procedure TFB25Statement.SetRetainInterfaces(aValue: boolean);
1276 begin
1277 inherited SetRetainInterfaces(aValue);
1278 if HasInterface(1) then
1279 TMetaData(GetInterface(1)).RetainInterfaces := aValue;
1280 if HasInterface(0) then
1281 TSQLParams(GetInterface(0)).RetainInterfaces := aValue;
1282 end;
1283
1284 function TFB25Statement.IsPrepared: boolean;
1285 begin
1286 Result := FHandle <> nil;
1287 end;
1288
1289 end.
1290