ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/fbintf/client/3.0/FB30Statement.pas
Revision: 363
Committed: Tue Dec 7 13:30:05 2021 UTC (8 months ago) by tony
File size: 53927 byte(s)
Log Message:
add fbintf
Line File contents
1 (*
2 * Firebird Interface (fbintf). The fbintf components provide a set of
3 * Pascal language bindings for the Firebird API.
4 *
5 * The contents of this file are subject to the Initial Developer's
6 * Public License Version 1.0 (the "License"); you may not use this
7 * file except in compliance with the License. You may obtain a copy
8 * of the License here:
9 *
10 * http://www.firebirdsql.org/index.php?op=doc&id=idpl
11 *
12 * Software distributed under the License is distributed on an "AS
13 * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
14 * implied. See the License for the specific language governing rights
15 * and limitations under the License.
16 *
17 * The Initial Developer of the Original Code is Tony Whyman.
18 *
19 * The Original Code is (C) 2016 Tony Whyman, MWA Software
20 * (http://www.mwasoftware.co.uk).
21 *
22 * All Rights Reserved.
23 *
24 * Contributor(s): ______________________________________.
25 *
26 *)
27 unit FB30Statement;
28 {$IFDEF MSWINDOWS}
29 {$DEFINE WINDOWS}
30 {$ENDIF}
31
32 {$IFDEF FPC}
33 {$mode delphi}
34 {$codepage UTF8}
35 {$interfaces COM}
36 {$ENDIF}
37
38 {This unit is hacked from IBSQL and contains the code for managing an XSQLDA and
39 SQLVars, along with statement preparation, execution and cursor management.
40 Most of the SQLVar code has been moved to unit FBSQLData. Client access is
41 provided through interface rather than direct access to the XSQLDA and XSQLVar
42 objects.}
43
44 {
45 Note on reference counted interfaces.
46 ------------------------------------
47
48 TFB30Statement manages both an input and an output SQLDA through the TIBXINPUTSQLDA
49 and TIBXOUTPUTSQLDA objects. As pure objects, these are explicitly destroyed
50 when the statement is destroyed.
51
52 However, IResultSet is an interface and is returned when a cursor is opened and
53 has a reference for the TIBXOUTPUTSQLDA. The user may discard their reference
54 to the IStatement while still using the IResultSet. This would be a problem if t
55 he underlying TFB30Statement object and its TIBXOUTPUTSQLDA is destroyed while
56 still leaving the TIBXResultSet object in place. Calls to (e.g.) FetchNext would fail.
57
58 To avoid this problem, TResultsSet objects have a reference to the IStatement
59 interface of the TFB30Statement object. Thus, as long as these "copies" exist,
60 the owning statement is not destroyed even if the user discards their reference
61 to the statement. Note: the TFB30Statement does not have a reference to the TIBXResultSet
62 interface. This way circular references are avoided.
63
64 To avoid and IResultSet interface being kept to long and no longer synchronised
65 with the query, each statement includes a prepare sequence number, incremented
66 each time the query is prepared. When the IResultSet interface is created, it
67 noted the current prepare sequence number. Whe an IResult interface is accessed
68 it checks this number against the statement's current prepare sequence number.
69 If not the same, an error is raised.
70
71 A similar strategy is used for the IMetaData, IResults and ISQLParams interfaces.
72 }
73
74 interface
75
76 uses
77 Classes, SysUtils, Firebird, IB, FBStatement, FB30ClientAPI, FB30Transaction,
78 FB30Attachment,IBExternals, FBSQLData, FBOutputBlock, FBActivityMonitor;
79
80 type
81 TFB30Statement = class;
82 TIBXSQLDA = class;
83
84 { TIBXSQLVAR }
85
86 TIBXSQLVAR = class(TSQLVarData)
87 private
88 FStatement: TFB30Statement;
89 FFirebird30ClientAPI: TFB30ClientAPI;
90 FBlob: IBlob; {Cache references}
91 FNullIndicator: short;
92 FOwnsSQLData: boolean;
93 FBlobMetaData: IBlobMetaData;
94 FArrayMetaData: IArrayMetaData;
95
96 {SQL Var Type Data}
97 FSQLType: cardinal;
98 FSQLSubType: integer;
99 FSQLData: PByte; {Address of SQL Data in Message Buffer}
100 FSQLNullIndicator: PShort; {Address of null indicator}
101 FDataLength: integer;
102 FMetadataSize: integer;
103 FNullable: boolean;
104 FScale: integer;
105 FCharSetID: cardinal;
106 FRelationName: AnsiString;
107 FFieldName: AnsiString;
108
109 protected
110 function CanChangeSQLType: boolean;
111 function GetSQLType: cardinal; override;
112 function GetSubtype: integer; override;
113 function GetAliasName: AnsiString; override;
114 function GetFieldName: AnsiString; override;
115 function GetOwnerName: AnsiString; override;
116 function GetRelationName: AnsiString; override;
117 function GetScale: integer; override;
118 function GetCharSetID: cardinal; override;
119 function GetCodePage: TSystemCodePage; override;
120 function GetCharSetWidth: integer; override;
121 function GetIsNull: Boolean; override;
122 function GetIsNullable: boolean; override;
123 function GetSQLData: PByte; override;
124 function GetDataLength: cardinal; override;
125 function GetSize: cardinal; override;
126 function GetAttachment: IAttachment; override;
127 function GetDefaultTextSQLType: cardinal; override;
128 procedure SetIsNull(Value: Boolean); override;
129 procedure SetIsNullable(Value: Boolean); override;
130 procedure SetSQLData(AValue: PByte; len: cardinal); override;
131 procedure SetScale(aValue: integer); override;
132 procedure SetDataLength(len: cardinal); override;
133 procedure SetSQLType(aValue: cardinal); override;
134 procedure SetCharSetID(aValue: cardinal); override;
135 procedure SetMetaSize(aValue: cardinal); override;
136 public
137 constructor Create(aParent: TIBXSQLDA; aIndex: integer);
138 procedure Changed; override;
139 procedure InitColumnMetaData(aMetaData: Firebird.IMessageMetadata);
140 procedure ColumnSQLDataInit;
141 procedure RowChange; override;
142 procedure FreeSQLData;
143 function GetAsArray: IArray; override;
144 function GetAsBlob(Blob_ID: TISC_QUAD; BPB: IBPB): IBlob; override;
145 function GetArrayMetaData: IArrayMetaData; override;
146 function GetBlobMetaData: IBlobMetaData; override;
147 function CreateBlob: IBlob; override;
148 end;
149
150 { TIBXSQLDA }
151
152 TIBXSQLDA = class(TSQLDataArea)
153 private
154 FCount: Integer; {Columns in use - may be less than inherited columns}
155 FSize: Integer; {Number of TIBXSQLVARs in column list}
156 FMetaData: Firebird.IMessageMetadata;
157 FTransactionSeqNo: integer;
158 protected
159 FStatement: TFB30Statement;
160 FFirebird30ClientAPI: TFB30ClientAPI;
161 function GetTransactionSeqNo: integer; override;
162 procedure FreeXSQLDA; virtual;
163 function GetStatement: IStatement; override;
164 function GetPrepareSeqNo: integer; override;
165 procedure SetCount(Value: Integer); override;
166 public
167 constructor Create(aStatement: TFB30Statement);
168 destructor Destroy; override;
169 procedure Changed; virtual;
170 function CheckStatementStatus(Request: TStatementStatus): boolean; override;
171 function ColumnsInUseCount: integer; override;
172 function GetTransaction: TFB30Transaction; virtual;
173 procedure Initialize; override;
174 function StateChanged(var ChangeSeqNo: integer): boolean; override;
175 function CanChangeMetaData: boolean; override;
176 property MetaData: Firebird.IMessageMetadata read FMetaData;
177 property Count: Integer read FCount write SetCount;
178 property Statement: TFB30Statement read FStatement;
179 end;
180
181 { TIBXINPUTSQLDA }
182
183 TIBXINPUTSQLDA = class(TIBXSQLDA)
184 private
185 FMessageBuffer: PByte; {Message Buffer}
186 FMsgLength: integer; {Message Buffer length}
187 FCurMetaData: Firebird.IMessageMetadata;
188 procedure FreeMessageBuffer;
189 procedure FreeCurMetaData;
190 function GetMessageBuffer: PByte;
191 function GetMetaData: Firebird.IMessageMetadata;
192 function GetModified: Boolean;
193 function GetMsgLength: integer;
194 procedure BuildMetadata;
195 procedure PackBuffer;
196 protected
197 procedure FreeXSQLDA; override;
198 public
199 constructor Create(aStatement: TFB30Statement);
200 destructor Destroy; override;
201 procedure Bind(aMetaData: Firebird.IMessageMetadata);
202 procedure Changed; override;
203 procedure ReInitialise;
204 function IsInputDataArea: boolean; override;
205 property MetaData: Firebird.IMessageMetadata read GetMetaData;
206 property MessageBuffer: PByte read GetMessageBuffer;
207 property MsgLength: integer read GetMsgLength;
208 end;
209
210 { TIBXOUTPUTSQLDA }
211
212 TIBXOUTPUTSQLDA = class(TIBXSQLDA)
213 private
214 FTransaction: TFB30Transaction; {transaction used to execute the statement}
215 FMessageBuffer: PByte; {Message Buffer}
216 FMsgLength: integer; {Message Buffer length}
217 protected
218 procedure FreeXSQLDA; override;
219 public
220 procedure Bind(aMetaData: Firebird.IMessageMetadata);
221 procedure GetData(index: integer; var aIsNull: boolean; var len: short;
222 var data: PByte); override;
223 function IsInputDataArea: boolean; override;
224 property MessageBuffer: PByte read FMessageBuffer;
225 property MsgLength: integer read FMsgLength;
226 end;
227
228 { TResultSet }
229
230 TResultSet = class(TResults,IResultSet)
231 private
232 FResults: TIBXOUTPUTSQLDA;
233 FCursorSeqNo: integer;
234 procedure RowChange;
235 public
236 constructor Create(aResults: TIBXOUTPUTSQLDA);
237 destructor Destroy; override;
238 {IResultSet}
239 function FetchNext: boolean; {fetch next record}
240 function FetchPrior: boolean; {fetch previous record}
241 function FetchFirst:boolean; {fetch first record}
242 function FetchLast: boolean; {fetch last record}
243 function FetchAbsolute(position: Integer): boolean; {fetch record by its absolute position in result set}
244 function FetchRelative(offset: Integer): boolean; {fetch record by position relative to current}
245 function GetCursorName: AnsiString;
246 function GetTransaction: ITransaction; override;
247 function IsBof: boolean;
248 function IsEof: boolean;
249 procedure Close;
250 end;
251
252 { TBatchCompletion }
253
254 TBatchCompletion = class(TInterfaceOwner,IBatchCompletion)
255 private
256 FCompletionState: Firebird.IBatchCompletionState;
257 FFirebird30ClientAPI: TFB30ClientAPI;
258 public
259 constructor Create(api: TFB30ClientAPI; cs: IBatchCompletionState);
260 destructor Destroy; override;
261 {IBatchCompletion}
262 function getErrorStatus(var RowNo: integer; var status: IStatus): boolean;
263 function getTotalProcessed: cardinal;
264 function getState(updateNo: cardinal): TBatchCompletionState;
265 function getStatusMessage(updateNo: cardinal): AnsiString;
266 function getUpdated: integer;
267 end;
268
269 TFetchType = (ftNext,ftPrior,ftFirst,ftLast,ftAbsolute,ftRelative);
270
271 { TFB30Statement }
272
273 TFB30Statement = class(TFBStatement,IStatement)
274 private
275 FStatementIntf: Firebird.IStatement;
276 FFirebird30ClientAPI: TFB30ClientAPI;
277 FSQLParams: TIBXINPUTSQLDA;
278 FSQLRecord: TIBXOUTPUTSQLDA;
279 FResultSet: Firebird.IResultSet;
280 FCursorSeqNo: integer;
281 FCursor: AnsiString;
282 FBatch: Firebird.IBatch;
283 FBatchCompletion: IBatchCompletion;
284 FBatchRowCount: integer;
285 FBatchBufferSize: integer;
286 FBatchBufferUsed: integer;
287 protected
288 procedure CheckChangeBatchRowLimit; override;
289 procedure CheckHandle; override;
290 procedure CheckBatchModeAvailable;
291 procedure GetDSQLInfo(info_request: byte; buffer: ISQLInfoResults); override;
292 function GetStatementIntf: IStatement; override;
293 procedure InternalPrepare(CursorName: AnsiString=''); override;
294 function InternalExecute(aTransaction: ITransaction): IResults; override;
295 function InternalOpenCursor(aTransaction: ITransaction; Scrollable: boolean
296 ): IResultSet; override;
297 procedure ProcessSQL(sql: AnsiString; GenerateParamNames: boolean; var processedSQL: AnsiString); override;
298 procedure FreeHandle; override;
299 procedure InternalClose(Force: boolean); override;
300 function SavePerfStats(var Stats: TPerfStatistics): boolean;
301 public
302 constructor Create(Attachment: TFB30Attachment; Transaction: ITransaction;
303 sql: AnsiString; aSQLDialect: integer; CursorName: AnsiString='');
304 constructor CreateWithParameterNames(Attachment: TFB30Attachment; Transaction: ITransaction;
305 sql: AnsiString; aSQLDialect: integer; GenerateParamNames: boolean =false;
306 CaseSensitiveParams: boolean=false; CursorName: AnsiString='');
307 destructor Destroy; override;
308 function Fetch(FetchType: TFetchType; PosOrOffset: integer=0): boolean;
309 property StatementIntf: Firebird.IStatement read FStatementIntf;
310
311 public
312 {IStatement}
313 function GetSQLParams: ISQLParams; override;
314 function GetMetaData: IMetaData; override;
315 function GetPlan: AnsiString;
316 function IsPrepared: boolean;
317 function GetFlags: TStatementFlags; override;
318 function CreateBlob(column: TColumnMetaData): IBlob; override;
319 function CreateArray(column: TColumnMetaData): IArray; override;
320 procedure SetRetainInterfaces(aValue: boolean); override;
321 function IsInBatchMode: boolean; override;
322 function HasBatchMode: boolean; override;
323 procedure AddToBatch; override;
324 function ExecuteBatch(aTransaction: ITransaction
325 ): IBatchCompletion; override;
326 procedure CancelBatch; override;
327 function GetBatchCompletion: IBatchCompletion; override;
328 end;
329
330 implementation
331
332 uses IBUtils, FBMessages, FBBlob, FB30Blob, variants, FBArray, FB30Array;
333
334 const
335 ISQL_COUNTERS = 'CurrentMemory, MaxMemory, RealTime, UserTime, Buffers, Reads, Writes, Fetches';
336
337 { EIBBatchCompletionError }
338
339 { TBatchCompletion }
340
341 constructor TBatchCompletion.Create(api: TFB30ClientAPI;
342 cs: IBatchCompletionState);
343 begin
344 inherited Create;
345 FFirebird30ClientAPI := api;
346 FCompletionState := cs;
347 end;
348
349 destructor TBatchCompletion.Destroy;
350 begin
351 if FCompletionState <> nil then
352 begin
353 FCompletionState.dispose;
354 FCompletionState := nil;
355 end;
356 inherited Destroy;
357 end;
358
359 function TBatchCompletion.getErrorStatus(var RowNo: integer; var status: IStatus
360 ): boolean;
361 var i: integer;
362 upcount: cardinal;
363 state: integer;
364 FBStatus: Firebird.IStatus;
365 begin
366 Result := false;
367 RowNo := -1;
368 FBStatus := nil;
369 with FFirebird30ClientAPI do
370 begin
371 upcount := FCompletionState.getSize(StatusIntf);
372 Check4DataBaseError;
373 for i := 0 to upcount - 1 do
374 begin
375 state := FCompletionState.getState(StatusIntf,i);
376 if state = Firebird.IBatchCompletionState.EXECUTE_FAILED then
377 begin
378 RowNo := i+1;
379 FBStatus := MasterIntf.getStatus;
380 try
381 FCompletionState.getStatus(StatusIntf,FBStatus,i);
382 Check4DataBaseError;
383 except
384 FBStatus.dispose;
385 raise
386 end;
387 status := TFB30StatusObject.Create(FFirebird30ClientAPI,FBStatus,
388 Format(SBatchCompletionError,[RowNo]));
389 status.SetIBDataBaseErrorMessages(GetStatus.GetIBDataBaseErrorMessages);
390 Result := true;
391 break;
392 end;
393 end;
394 end;
395 end;
396
397 function TBatchCompletion.getTotalProcessed: cardinal;
398 begin
399 with FFirebird30ClientAPI do
400 begin
401 Result := FCompletionState.getsize(StatusIntf);
402 Check4DataBaseError;
403 end;
404 end;
405
406 function TBatchCompletion.getState(updateNo: cardinal): TBatchCompletionState;
407 var state: integer;
408 begin
409 with FFirebird30ClientAPI do
410 begin
411 state := FCompletionState.getState(StatusIntf,updateNo);
412 Check4DataBaseError;
413 case state of
414 Firebird.IBatchCompletionState.EXECUTE_FAILED:
415 Result := bcExecuteFailed;
416
417 Firebird.IBatchCompletionState.SUCCESS_NO_INFO:
418 Result := bcSuccessNoInfo;
419
420 else
421 Result := bcNoMoreErrors;
422 end;
423 end;
424 end;
425
426 function TBatchCompletion.getStatusMessage(updateNo: cardinal): AnsiString;
427 var status: Firebird.IStatus;
428 begin
429 with FFirebird30ClientAPI do
430 begin
431 status := MasterIntf.getStatus;
432 FCompletionState.getStatus(StatusIntf,status,updateNo);
433 Check4DataBaseError;
434 Result := FormatFBStatus(status);
435 end;
436 end;
437
438 function TBatchCompletion.getUpdated: integer;
439 var i: integer;
440 upcount: cardinal;
441 state: integer;
442 begin
443 Result := 0;
444 with FFirebird30ClientAPI do
445 begin
446 upcount := FCompletionState.getSize(StatusIntf);
447 Check4DataBaseError;
448 for i := 0 to upcount -1 do
449 begin
450 state := FCompletionState.getState(StatusIntf,i);
451 if state = Firebird.IBatchCompletionState.EXECUTE_FAILED then
452 break;
453 Inc(Result);
454 end;
455 end;
456 end;
457
458 { TIBXSQLVAR }
459
460 procedure TIBXSQLVAR.Changed;
461 begin
462 inherited Changed;
463 TIBXSQLDA(Parent).Changed;
464 end;
465
466 procedure TIBXSQLVAR.InitColumnMetaData(aMetaData: Firebird.IMessageMetadata);
467 begin
468 with FFirebird30ClientAPI do
469 begin
470 FSQLType := aMetaData.getType(StatusIntf,Index);
471 Check4DataBaseError;
472 if FSQLType = SQL_BLOB then
473 begin
474 FSQLSubType := aMetaData.getSubType(StatusIntf,Index);
475 Check4DataBaseError;
476 end
477 else
478 FSQLSubType := 0;
479 FDataLength := aMetaData.getLength(StatusIntf,Index);
480 Check4DataBaseError;
481 FMetadataSize := FDataLength;
482 FRelationName := strpas(aMetaData.getRelation(StatusIntf,Index));
483 Check4DataBaseError;
484 FFieldName := strpas(aMetaData.getField(StatusIntf,Index));
485 Check4DataBaseError;
486 FNullable := aMetaData.isNullable(StatusIntf,Index);
487 Check4DataBaseError;
488 FScale := aMetaData.getScale(StatusIntf,Index);
489 Check4DataBaseError;
490 FCharSetID := aMetaData.getCharSet(StatusIntf,Index) and $FF;
491 Check4DataBaseError;
492 end;
493 end;
494
495 procedure TIBXSQLVAR.ColumnSQLDataInit;
496 begin
497 FreeSQLData;
498 with FFirebird30ClientAPI do
499 begin
500 case SQLType of
501 SQL_TEXT, SQL_TYPE_DATE, SQL_TYPE_TIME, SQL_TIMESTAMP,
502 SQL_BLOB, SQL_ARRAY, SQL_QUAD, SQL_SHORT, SQL_BOOLEAN,
503 SQL_LONG, SQL_INT64, SQL_INT128, SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT,
504 SQL_TIMESTAMP_TZ, SQL_TIME_TZ, SQL_DEC_FIXED, SQL_DEC16, SQL_DEC34,
505 SQL_TIMESTAMP_TZ_EX, SQL_TIME_TZ_EX:
506 begin
507 if (FDataLength = 0) then
508 { Make sure you get a valid pointer anyway
509 select '' from foo }
510 IBAlloc(FSQLData, 0, 1)
511 else
512 IBAlloc(FSQLData, 0, FDataLength)
513 end;
514 SQL_VARYING:
515 IBAlloc(FSQLData, 0, FDataLength + 2);
516 else
517 IBError(ibxeUnknownSQLDataType, [SQLType and (not 1)])
518 end;
519 FOwnsSQLData := true;
520 FNullIndicator := -1;
521 end;
522 end;
523
524 function TIBXSQLVAR.CanChangeSQLType: boolean;
525 begin
526 Result := Parent.CanChangeMetaData;
527 end;
528
529 function TIBXSQLVAR.GetSQLType: cardinal;
530 begin
531 Result := FSQLType;
532 end;
533
534 function TIBXSQLVAR.GetSubtype: integer;
535 begin
536 Result := FSQLSubType;
537 end;
538
539 function TIBXSQLVAR.GetAliasName: AnsiString;
540 begin
541 with FFirebird30ClientAPI do
542 begin
543 result := strpas(TIBXSQLDA(Parent).MetaData.getAlias(StatusIntf,Index));
544 Check4DataBaseError;
545 end;
546 end;
547
548 function TIBXSQLVAR.GetFieldName: AnsiString;
549 begin
550 Result := FFieldName;
551 end;
552
553 function TIBXSQLVAR.GetOwnerName: AnsiString;
554 begin
555 with FFirebird30ClientAPI do
556 begin
557 result := strpas(TIBXSQLDA(Parent).MetaData.getOwner(StatusIntf,Index));
558 Check4DataBaseError;
559 end;
560 end;
561
562 function TIBXSQLVAR.GetRelationName: AnsiString;
563 begin
564 Result := FRelationName;
565 end;
566
567 function TIBXSQLVAR.GetScale: integer;
568 begin
569 Result := FScale;
570 end;
571
572 function TIBXSQLVAR.GetCharSetID: cardinal;
573 begin
574 result := 0; {NONE}
575 case SQLType of
576 SQL_VARYING, SQL_TEXT:
577 result := FCharSetID;
578
579 SQL_BLOB:
580 if (SQLSubType = 1) then
581 result := FCharSetID
582 else
583 result := 1; {OCTETS}
584
585 SQL_ARRAY:
586 if (FRelationName <> '') and (FFieldName <> '') then
587 result := GetArrayMetaData.GetCharSetID
588 else
589 result := FCharSetID;
590 end;
591 end;
592
593 function TIBXSQLVAR.GetCodePage: TSystemCodePage;
594 begin
595 result := CP_NONE;
596 with Statement.GetAttachment do
597 CharSetID2CodePage(GetCharSetID,result);
598 end;
599
600 function TIBXSQLVAR.GetCharSetWidth: integer;
601 begin
602 result := 1;
603 with Statement.GetAttachment DO
604 CharSetWidth(GetCharSetID,result);
605 end;
606
607 function TIBXSQLVAR.GetIsNull: Boolean;
608 begin
609 Result := IsNullable and (FSQLNullIndicator^ = -1);
610 end;
611
612 function TIBXSQLVAR.GetIsNullable: boolean;
613 begin
614 Result := FSQLNullIndicator <> nil;
615 end;
616
617 function TIBXSQLVAR.GetSQLData: PByte;
618 begin
619 Result := FSQLData;
620 end;
621
622 function TIBXSQLVAR.GetDataLength: cardinal;
623 begin
624 Result := FDataLength;
625 end;
626
627 function TIBXSQLVAR.GetSize: cardinal;
628 begin
629 Result := FMetadataSize;
630 end;
631
632 function TIBXSQLVAR.GetAttachment: IAttachment;
633 begin
634 Result := FStatement.GetAttachment;
635 end;
636
637 function TIBXSQLVAR.GetArrayMetaData: IArrayMetaData;
638 begin
639 if GetSQLType <> SQL_ARRAY then
640 IBError(ibxeInvalidDataConversion,[nil]);
641
642 if FArrayMetaData = nil then
643 FArrayMetaData := TFB30ArrayMetaData.Create(FStatement.GetAttachment as TFB30Attachment,
644 FStatement.GetTransaction as TFB30Transaction,
645 GetRelationName,GetFieldName);
646 Result := FArrayMetaData;
647 end;
648
649 function TIBXSQLVAR.GetBlobMetaData: IBlobMetaData;
650 begin
651 if GetSQLType <> SQL_BLOB then
652 IBError(ibxeInvalidDataConversion,[nil]);
653
654 if FBlobMetaData = nil then
655 FBlobMetaData := TFB30BlobMetaData.Create(FStatement.GetAttachment as TFB30Attachment,
656 FStatement.GetTransaction as TFB30Transaction,
657 GetRelationName,GetFieldName,
658 GetSubType);
659 (FBlobMetaData as TFBBlobMetaData).SetCharSetID(GetCharSetID);
660 Result := FBlobMetaData;
661 end;
662
663 procedure TIBXSQLVAR.SetIsNull(Value: Boolean);
664 begin
665 if Value then
666 begin
667 IsNullable := true;
668 FNullIndicator := -1;
669 end
670 else
671 if IsNullable then
672 FNullIndicator := 0;
673 Changed;
674 end;
675
676 procedure TIBXSQLVAR.SetIsNullable(Value: Boolean);
677 begin
678 if Value = IsNullable then Exit;
679 if Value then
680 begin
681 FSQLNullIndicator := @FNullIndicator;
682 FNullIndicator := 0;
683 end
684 else
685 FSQLNullIndicator := nil;
686 Changed;
687 end;
688
689 procedure TIBXSQLVAR.SetSQLData(AValue: PByte; len: cardinal);
690 begin
691 if FOwnsSQLData then
692 FreeMem(FSQLData);
693 FSQLData := AValue;
694 FDataLength := len;
695 FOwnsSQLData := false;
696 Changed;
697 end;
698
699 procedure TIBXSQLVAR.SetScale(aValue: integer);
700 begin
701 FScale := aValue;
702 Changed;
703 end;
704
705 procedure TIBXSQLVAR.SetDataLength(len: cardinal);
706 begin
707 if not FOwnsSQLData then
708 FSQLData := nil;
709 FDataLength := len;
710 with FFirebird30ClientAPI do
711 IBAlloc(FSQLData, 0, FDataLength);
712 FOwnsSQLData := true;
713 Changed;
714 end;
715
716 procedure TIBXSQLVAR.SetSQLType(aValue: cardinal);
717 begin
718 if (FSQLType <> aValue) and not CanChangeSQLType then
719 IBError(ibxeSQLTypeUnchangeable,[TSQLDataItem.GetSQLTypeName(FSQLType),TSQLDataItem.GetSQLTypeName(aValue)]);
720 FSQLType := aValue;
721 Changed;
722 end;
723
724 procedure TIBXSQLVAR.SetCharSetID(aValue: cardinal);
725 begin
726 FCharSetID := aValue;
727 Changed;
728 end;
729
730 procedure TIBXSQLVAR.SetMetaSize(aValue: cardinal);
731 begin
732 if (aValue > FMetaDataSize) and not CanChangeSQLType then
733 IBError(ibxeCannotIncreaseMetadatasize,[FMetaDataSize,aValue]);
734 FMetaDataSize := aValue;
735 end;
736
737 function TIBXSQLVAR.GetDefaultTextSQLType: cardinal;
738 begin
739 Result := SQL_VARYING;
740 end;
741
742 constructor TIBXSQLVAR.Create(aParent: TIBXSQLDA; aIndex: integer);
743 begin
744 inherited Create(aParent,aIndex);
745 FStatement := aParent.Statement;
746 FFirebird30ClientAPI := aParent.FFirebird30ClientAPI;
747 end;
748
749 procedure TIBXSQLVAR.RowChange;
750 begin
751 inherited;
752 FBlob := nil;
753 end;
754
755 procedure TIBXSQLVAR.FreeSQLData;
756 begin
757 if FOwnsSQLData then
758 FreeMem(FSQLData);
759 FSQLData := nil;
760 FOwnsSQLData := true;
761 end;
762
763 function TIBXSQLVAR.GetAsArray: IArray;
764 begin
765 if SQLType <> SQL_ARRAY then
766 IBError(ibxeInvalidDataConversion,[nil]);
767
768 if IsNull then
769 Result := nil
770 else
771 begin
772 if FArrayIntf = nil then
773 FArrayIntf := TFB30Array.Create(FStatement.GetAttachment as TFB30Attachment,
774 TIBXSQLDA(Parent).GetTransaction,
775 GetArrayMetaData,PISC_QUAD(SQLData)^);
776 Result := FArrayIntf;
777 end;
778 end;
779
780 function TIBXSQLVAR.GetAsBlob(Blob_ID: TISC_QUAD; BPB: IBPB): IBlob;
781 begin
782 if FBlob <> nil then
783 Result := FBlob
784 else
785 begin
786 if SQLType <> SQL_BLOB then
787 IBError(ibxeInvalidDataConversion, [nil]);
788 if IsNull then
789 Result := nil
790 else
791 Result := TFB30Blob.Create(FStatement.GetAttachment as TFB30Attachment,
792 TIBXSQLDA(Parent).GetTransaction,
793 GetBlobMetaData,
794 Blob_ID,BPB);
795 FBlob := Result;
796 end;
797 end;
798
799 function TIBXSQLVAR.CreateBlob: IBlob;
800 begin
801 Result := TFB30Blob.Create(FStatement.GetAttachment as TFB30Attachment,
802 FStatement.GetTransaction as TFB30Transaction,
803 GetSubType,GetCharSetID,nil);
804 end;
805
806 { TResultSet }
807
808 procedure TResultSet.RowChange;
809 var i: integer;
810 begin
811 for i := 0 to getCount - 1 do
812 FResults.Column[i].RowChange;
813 end;
814
815 constructor TResultSet.Create(aResults: TIBXOUTPUTSQLDA);
816 begin
817 inherited Create(aResults);
818 FResults := aResults;
819 FCursorSeqNo := aResults.FStatement.FCursorSeqNo;
820 end;
821
822 destructor TResultSet.Destroy;
823 begin
824 Close;
825 inherited Destroy;
826 end;
827
828 function TResultSet.FetchNext: boolean;
829 begin
830 CheckActive;
831 Result := FResults.FStatement.Fetch(ftNext);
832 if Result then
833 RowChange;
834 end;
835
836 function TResultSet.FetchPrior: boolean;
837 begin
838 CheckActive;
839 Result := FResults.FStatement.Fetch(ftPrior);
840 if Result then
841 RowChange;
842 end;
843
844 function TResultSet.FetchFirst: boolean;
845 begin
846 CheckActive;
847 Result := FResults.FStatement.Fetch(ftFirst);
848 if Result then
849 RowChange;
850 end;
851
852 function TResultSet.FetchLast: boolean;
853 begin
854 CheckActive;
855 Result := FResults.FStatement.Fetch(ftLast);
856 if Result then
857 RowChange;
858 end;
859
860 function TResultSet.FetchAbsolute(position: Integer): boolean;
861 begin
862 CheckActive;
863 Result := FResults.FStatement.Fetch(ftAbsolute,position);
864 if Result then
865 RowChange;
866 end;
867
868 function TResultSet.FetchRelative(offset: Integer): boolean;
869 begin
870 CheckActive;
871 Result := FResults.FStatement.Fetch(ftRelative,offset);
872 if Result then
873 RowChange;
874 end;
875
876 function TResultSet.GetCursorName: AnsiString;
877 begin
878 Result := FResults.FStatement.FCursor;
879 end;
880
881 function TResultSet.GetTransaction: ITransaction;
882 begin
883 Result := FResults.FTransaction;
884 end;
885
886 function TResultSet.IsBof: boolean;
887 begin
888 Result := FResults.FStatement.FBof;
889 end;
890
891 function TResultSet.IsEof: boolean;
892 begin
893 Result := FResults.FStatement.FEof;
894 end;
895
896 procedure TResultSet.Close;
897 begin
898 if FCursorSeqNo = FResults.FStatement.FCursorSeqNo then
899 FResults.FStatement.Close;
900 end;
901
902 { TIBXINPUTSQLDA }
903
904 function TIBXINPUTSQLDA.GetModified: Boolean;
905 var
906 i: Integer;
907 begin
908 result := False;
909 for i := 0 to FCount - 1 do
910 if Column[i].Modified then
911 begin
912 result := True;
913 exit;
914 end;
915 end;
916
917 procedure TIBXINPUTSQLDA.FreeMessageBuffer;
918 begin
919 if FMessageBuffer <> nil then
920 begin
921 FreeMem(FMessageBuffer);
922 FMessageBuffer := nil;
923 end;
924 FMsgLength := 0;
925 end;
926
927 procedure TIBXINPUTSQLDA.FreeCurMetaData;
928 begin
929 if FCurMetaData <> nil then
930 begin
931 FCurMetaData.release;
932 FCurMetaData := nil;
933 end;
934 end;
935
936 function TIBXINPUTSQLDA.GetMessageBuffer: PByte;
937 begin
938 PackBuffer;
939 Result := FMessageBuffer;
940 end;
941
942 function TIBXINPUTSQLDA.GetMetaData: Firebird.IMessageMetadata;
943 begin
944 BuildMetadata;
945 Result := FCurMetaData;
946 end;
947
948 function TIBXINPUTSQLDA.GetMsgLength: integer;
949 begin
950 PackBuffer;
951 Result := FMsgLength;
952 end;
953
954 procedure TIBXINPUTSQLDA.BuildMetadata;
955 var Builder: Firebird.IMetadataBuilder;
956 i: integer;
957 begin
958 if (FCurMetaData = nil) and (Count > 0) then
959 with FFirebird30ClientAPI do
960 begin
961 Builder := FFirebird30ClientAPI.MasterIntf.getMetadataBuilder(StatusIntf,Count);
962 Check4DataBaseError;
963 try
964 for i := 0 to Count - 1 do
965 with TIBXSQLVar(Column[i]) do
966 begin
967 Builder.setType(StatusIntf,i,FSQLType+1);
968 Check4DataBaseError;
969 Builder.setSubType(StatusIntf,i,FSQLSubType);
970 Check4DataBaseError;
971 // writeln('Column ',Name,' Type = ',TSQLDataItem.GetSQLTypeName(FSQLType),' Size = ',GetSize,' DataLength = ',GetDataLength);
972 if FSQLType = SQL_VARYING then
973 begin
974 {The datalength can be greater than the metadata size when SQLType has been overridden to text}
975 if (GetDataLength > GetSize) and CanChangeMetaData then
976 Builder.setLength(StatusIntf,i,GetDataLength)
977 else
978 Builder.setLength(StatusIntf,i,GetSize)
979 end
980 else
981 Builder.setLength(StatusIntf,i,GetDataLength);
982 Check4DataBaseError;
983 Builder.setCharSet(StatusIntf,i,GetCharSetID);
984 Check4DataBaseError;
985 Builder.setScale(StatusIntf,i,FScale);
986 Check4DataBaseError;
987 end;
988 FCurMetaData := Builder.getMetadata(StatusIntf);
989 Check4DataBaseError;
990 finally
991 Builder.release;
992 end;
993 end;
994 end;
995
996 procedure TIBXINPUTSQLDA.PackBuffer;
997 var i: integer;
998 P: PByte;
999 begin
1000 BuildMetadata;
1001
1002 if (FMsgLength = 0) and (FCurMetaData <> nil) then
1003 with FFirebird30ClientAPI do
1004 begin
1005 FMsgLength := FCurMetaData.getMessageLength(StatusIntf);
1006 Check4DataBaseError;
1007
1008 IBAlloc(FMessageBuffer,0,FMsgLength);
1009
1010 for i := 0 to Count - 1 do
1011 with TIBXSQLVar(Column[i]) do
1012 begin
1013 P := FMessageBuffer + FCurMetaData.getOffset(StatusIntf,i);
1014 // writeln('Packbuffer: Column ',Name,' Type = ',TSQLDataItem.GetSQLTypeName(FSQLType),' Size = ',GetSize,' DataLength = ',GetDataLength);
1015 if not Modified then
1016 IBError(ibxeUninitializedInputParameter,[i,Name]);
1017 if IsNull then
1018 FillChar(P^,FDataLength,0)
1019 else
1020 if FSQLData <> nil then
1021 begin
1022 if SQLType = SQL_VARYING then
1023 begin
1024 EncodeInteger(FDataLength,2,P);
1025 Inc(P,2);
1026 end
1027 else
1028 if (SQLType = SQL_BLOB) and (FStatement.FBatch <> nil) then
1029 begin
1030 FStatement.FBatch.registerBlob(Statusintf,ISC_QUADPtr(FSQLData),ISC_QUADPtr(FSQLData));
1031 Check4DatabaseError;
1032 end;
1033 Move(FSQLData^,P^,FDataLength);
1034 end;
1035 if IsNullable then
1036 begin
1037 Move(FNullIndicator,(FMessageBuffer + FCurMetaData.getNullOffset(StatusIntf,i))^,sizeof(FNullIndicator));
1038 Check4DataBaseError;
1039 end;
1040 end;
1041 end;
1042 end;
1043
1044 procedure TIBXINPUTSQLDA.FreeXSQLDA;
1045 begin
1046 inherited FreeXSQLDA;
1047 FreeCurMetaData;
1048 FreeMessageBuffer;
1049 end;
1050
1051 constructor TIBXINPUTSQLDA.Create(aStatement: TFB30Statement);
1052 begin
1053 inherited Create(aStatement);
1054 FMessageBuffer := nil;
1055 end;
1056
1057 destructor TIBXINPUTSQLDA.Destroy;
1058 begin
1059 FreeXSQLDA;
1060 inherited Destroy;
1061 end;
1062
1063 procedure TIBXINPUTSQLDA.Bind(aMetaData: Firebird.IMessageMetadata);
1064 var i: integer;
1065 begin
1066 FMetaData := aMetaData;
1067 with FFirebird30ClientAPI do
1068 begin
1069 Count := aMetadata.getCount(StatusIntf);
1070 Check4DataBaseError;
1071 Initialize;
1072
1073 for i := 0 to Count - 1 do
1074 with TIBXSQLVar(Column[i]) do
1075 begin
1076 InitColumnMetaData(aMetaData);
1077 SaveMetaData;
1078 if FNullable then
1079 FSQLNullIndicator := @FNullIndicator
1080 else
1081 FSQLNullIndicator := nil;
1082 ColumnSQLDataInit;
1083 end;
1084 end;
1085 end;
1086
1087 procedure TIBXINPUTSQLDA.Changed;
1088 begin
1089 inherited Changed;
1090 FreeCurMetaData;
1091 FreeMessageBuffer;
1092 end;
1093
1094 procedure TIBXINPUTSQLDA.ReInitialise;
1095 var i: integer;
1096 begin
1097 FreeMessageBuffer;
1098 for i := 0 to Count - 1 do
1099 TIBXSQLVar(Column[i]).ColumnSQLDataInit;
1100 end;
1101
1102 function TIBXINPUTSQLDA.IsInputDataArea: boolean;
1103 begin
1104 Result := true;
1105 end;
1106
1107 { TIBXOUTPUTSQLDA }
1108
1109 procedure TIBXOUTPUTSQLDA.FreeXSQLDA;
1110 begin
1111 inherited FreeXSQLDA;
1112 FreeMem(FMessageBuffer);
1113 FMessageBuffer := nil;
1114 FMsgLength := 0;
1115 end;
1116
1117 procedure TIBXOUTPUTSQLDA.Bind(aMetaData: Firebird.IMessageMetadata);
1118 var i: integer;
1119 begin
1120 FMetaData := aMetaData;
1121 with FFirebird30ClientAPI do
1122 begin
1123 Count := metadata.getCount(StatusIntf);
1124 Check4DataBaseError;
1125 Initialize;
1126
1127 FMsgLength := metaData.getMessageLength(StatusIntf);
1128 Check4DataBaseError;
1129 IBAlloc(FMessageBuffer,0,FMsgLength);
1130
1131 for i := 0 to Count - 1 do
1132 with TIBXSQLVar(Column[i]) do
1133 begin
1134 InitColumnMetaData(aMetaData);
1135 FSQLData := FMessageBuffer + metaData.getOffset(StatusIntf,i);
1136 Check4DataBaseError;
1137 if FNullable then
1138 begin
1139 FSQLNullIndicator := PShort(FMessageBuffer + aMetaData.getNullOffset(StatusIntf,i));
1140 Check4DataBaseError;
1141 end
1142 else
1143 FSQLNullIndicator := nil;
1144 FBlob := nil;
1145 FArrayIntf := nil;
1146 end;
1147 end;
1148 SetUniqueRelationName;
1149 end;
1150
1151 procedure TIBXOUTPUTSQLDA.GetData(index: integer; var aIsNull: boolean;
1152 var len: short; var data: PByte);
1153 begin
1154 with TIBXSQLVAR(Column[index]) do
1155 begin
1156 aIsNull := FNullable and (FSQLNullIndicator^ = -1);
1157 data := FSQLData;
1158 len := FDataLength;
1159 if not IsNull and (FSQLType = SQL_VARYING) then
1160 begin
1161 with FFirebird30ClientAPI do
1162 len := DecodeInteger(data,2);
1163 Inc(Data,2);
1164 end;
1165 end;
1166 end;
1167
1168 function TIBXOUTPUTSQLDA.IsInputDataArea: boolean;
1169 begin
1170 Result := false;
1171 end;
1172
1173 { TIBXSQLDA }
1174 constructor TIBXSQLDA.Create(aStatement: TFB30Statement);
1175 begin
1176 inherited Create;
1177 FStatement := aStatement;
1178 FFirebird30ClientAPI := aStatement.FFirebird30ClientAPI;
1179 FSize := 0;
1180 // writeln('Creating ',ClassName);
1181 end;
1182
1183 destructor TIBXSQLDA.Destroy;
1184 begin
1185 FreeXSQLDA;
1186 // writeln('Destroying ',ClassName);
1187 inherited Destroy;
1188 end;
1189
1190 procedure TIBXSQLDA.Changed;
1191 begin
1192
1193 end;
1194
1195 function TIBXSQLDA.CheckStatementStatus(Request: TStatementStatus): boolean;
1196 begin
1197 Result := false;
1198 case Request of
1199 ssPrepared:
1200 Result := FStatement.IsPrepared;
1201
1202 ssExecuteResults:
1203 Result :=FStatement.FSingleResults;
1204
1205 ssCursorOpen:
1206 Result := FStatement.FOpen;
1207
1208 ssBOF:
1209 Result := FStatement.FBOF;
1210
1211 ssEOF:
1212 Result := FStatement.FEOF;
1213 end;
1214 end;
1215
1216 function TIBXSQLDA.ColumnsInUseCount: integer;
1217 begin
1218 Result := FCount;
1219 end;
1220
1221 function TIBXSQLDA.GetTransaction: TFB30Transaction;
1222 begin
1223 Result := FStatement.GetTransaction as TFB30Transaction;
1224 end;
1225
1226 procedure TIBXSQLDA.Initialize;
1227 begin
1228 if FMetaData <> nil then
1229 inherited Initialize;
1230 end;
1231
1232 function TIBXSQLDA.StateChanged(var ChangeSeqNo: integer): boolean;
1233 begin
1234 Result := FStatement.ChangeSeqNo <> ChangeSeqNo;
1235 if Result then
1236 ChangeSeqNo := FStatement.ChangeSeqNo;
1237 end;
1238
1239 function TIBXSQLDA.CanChangeMetaData: boolean;
1240 begin
1241 Result := FStatement.FBatch = nil;
1242 end;
1243
1244 procedure TIBXSQLDA.SetCount(Value: Integer);
1245 var
1246 i: Integer;
1247 begin
1248 FCount := Value;
1249 if FCount = 0 then
1250 FUniqueRelationName := ''
1251 else
1252 begin
1253 SetLength(FColumnList, FCount);
1254 for i := FSize to FCount - 1 do
1255 FColumnList[i] := TIBXSQLVAR.Create(self,i);
1256 FSize := FCount;
1257 end;
1258 end;
1259
1260 function TIBXSQLDA.GetTransactionSeqNo: integer;
1261 begin
1262 Result := FTransactionSeqNo;
1263 end;
1264
1265 procedure TIBXSQLDA.FreeXSQLDA;
1266 var i: integer;
1267 begin
1268 if FMetaData <> nil then
1269 FMetaData.release;
1270 FMetaData := nil;
1271 for i := 0 to Count - 1 do
1272 TIBXSQLVAR(Column[i]).FreeSQLData;
1273 for i := 0 to FSize - 1 do
1274 TIBXSQLVAR(Column[i]).Free;
1275 FCount := 0;
1276 SetLength(FColumnList,0);
1277 FSize := 0;
1278 end;
1279
1280 function TIBXSQLDA.GetStatement: IStatement;
1281 begin
1282 Result := FStatement;
1283 end;
1284
1285 function TIBXSQLDA.GetPrepareSeqNo: integer;
1286 begin
1287 Result := FStatement.FPrepareSeqNo;
1288 end;
1289
1290 { TFB30Statement }
1291
1292 procedure TFB30Statement.CheckChangeBatchRowLimit;
1293 begin
1294 if IsInBatchMode then
1295 IBError(ibxeInBatchMode,[nil]);
1296 end;
1297
1298 procedure TFB30Statement.CheckHandle;
1299 begin
1300 if FStatementIntf = nil then
1301 IBError(ibxeInvalidStatementHandle,[nil]);
1302 end;
1303
1304 procedure TFB30Statement.CheckBatchModeAvailable;
1305 begin
1306 if not HasBatchMode then
1307 IBError(ibxeBatchModeNotSupported,[nil]);
1308 case SQLStatementType of
1309 SQLInsert,
1310 SQLUpdate: {OK};
1311 else
1312 IBError(ibxeInvalidBatchQuery,[GetSQLStatementTypeName]);
1313 end;
1314 end;
1315
1316 procedure TFB30Statement.GetDSQLInfo(info_request: byte; buffer: ISQLInfoResults
1317 );
1318 begin
1319 with FFirebird30ClientAPI, buffer as TSQLInfoResultsBuffer do
1320 begin
1321 StatementIntf.getInfo(StatusIntf,1,BytePtr(@info_request),
1322 GetBufSize, BytePtr(Buffer));
1323 Check4DataBaseError;
1324 end;
1325 end;
1326
1327 function TFB30Statement.GetStatementIntf: IStatement;
1328 begin
1329 Result := self;
1330 end;
1331
1332 procedure TFB30Statement.InternalPrepare(CursorName: AnsiString);
1333 var GUID : TGUID;
1334 begin
1335 if FPrepared then
1336 Exit;
1337
1338 FCursor := CursorName;
1339 if (FSQL = '') then
1340 IBError(ibxeEmptyQuery, [nil]);
1341 try
1342 CheckTransaction(FTransactionIntf);
1343 with FFirebird30ClientAPI do
1344 begin
1345 if FCursor = '' then
1346 begin
1347 CreateGuid(GUID);
1348 FCursor := GUIDToString(GUID);
1349 end;
1350
1351 if FHasParamNames then
1352 begin
1353 if FProcessedSQL = '' then
1354 ProcessSQL(FSQL,FGenerateParamNames,FProcessedSQL);
1355 FStatementIntf := (GetAttachment as TFB30Attachment).AttachmentIntf.prepare(StatusIntf,
1356 (FTransactionIntf as TFB30Transaction).TransactionIntf,
1357 Length(FProcessedSQL),
1358 PAnsiChar(FProcessedSQL),
1359 FSQLDialect,
1360 Firebird.IStatement.PREPARE_PREFETCH_METADATA);
1361 end
1362 else
1363 FStatementIntf := (GetAttachment as TFB30Attachment).AttachmentIntf.prepare(StatusIntf,
1364 (FTransactionIntf as TFB30Transaction).TransactionIntf,
1365 Length(FSQL),
1366 PAnsiChar(FSQL),
1367 FSQLDialect,
1368 Firebird.IStatement.PREPARE_PREFETCH_METADATA);
1369 Check4DataBaseError;
1370 FSQLStatementType := TIBSQLStatementTypes(FStatementIntf.getType(StatusIntf));
1371 Check4DataBaseError;
1372
1373 if FSQLStatementType = SQLSelect then
1374 begin
1375 FStatementIntf.setCursorName(StatusIntf,PAnsiChar(FCursor));
1376 Check4DataBaseError;
1377 end;
1378 { Done getting the type }
1379 case FSQLStatementType of
1380 SQLGetSegment,
1381 SQLPutSegment,
1382 SQLStartTransaction:
1383 begin
1384 FreeHandle;
1385 IBError(ibxeNotPermitted, [nil]);
1386 end;
1387 SQLCommit,
1388 SQLRollback,
1389 SQLDDL, SQLSetGenerator,
1390 SQLInsert, SQLUpdate, SQLDelete, SQLSelect, SQLSelectForUpdate,
1391 SQLExecProcedure:
1392 begin
1393 {set up input sqlda}
1394 FSQLParams.Bind(FStatementIntf.getInputMetadata(StatusIntf));
1395 Check4DataBaseError;
1396
1397 {setup output sqlda}
1398 if FSQLStatementType in [SQLSelect, SQLSelectForUpdate,
1399 SQLExecProcedure] then
1400 FSQLRecord.Bind(FStatementIntf.getOutputMetadata(StatusIntf));
1401 Check4DataBaseError;
1402 end;
1403 end;
1404 end;
1405 except
1406 on E: Exception do begin
1407 if (FStatementIntf <> nil) then
1408 FreeHandle;
1409 if E is EIBInterBaseError then
1410 E.Message := E.Message + sSQLErrorSeparator + FSQL;
1411 raise;
1412 end;
1413 end;
1414 FPrepared := true;
1415
1416 FSingleResults := false;
1417 if RetainInterfaces then
1418 begin
1419 SetRetainInterfaces(false);
1420 SetRetainInterfaces(true);
1421 end;
1422 Inc(FPrepareSeqNo);
1423 with GetTransaction as TFB30Transaction do
1424 begin
1425 FSQLParams.FTransactionSeqNo := TransactionSeqNo;
1426 FSQLRecord.FTransactionSeqNo := TransactionSeqNo;
1427 end;
1428 SignalActivity;
1429 Inc(FChangeSeqNo);
1430 end;
1431
1432 function TFB30Statement.InternalExecute(aTransaction: ITransaction): IResults;
1433
1434 procedure ExecuteQuery(outMetaData: Firebird.IMessageMetaData=nil; outBuffer: pointer=nil);
1435 begin
1436 with FFirebird30ClientAPI do
1437 begin
1438 SavePerfStats(FBeforeStats);
1439 FStatementIntf.execute(StatusIntf,
1440 (aTransaction as TFB30Transaction).TransactionIntf,
1441 FSQLParams.MetaData,
1442 FSQLParams.MessageBuffer,
1443 outMetaData,
1444 outBuffer);
1445 Check4DataBaseError;
1446 FStatisticsAvailable := SavePerfStats(FAfterStats);
1447 end;
1448 end;
1449
1450 var Cursor: IResultSet;
1451
1452 begin
1453 Result := nil;
1454 FBatchCompletion := nil;
1455 FBOF := false;
1456 FEOF := false;
1457 FSingleResults := false;
1458 FStatisticsAvailable := false;
1459 if IsInBatchMode then
1460 IBerror(ibxeInBatchMode,[]);
1461 CheckTransaction(aTransaction);
1462 if not FPrepared then
1463 InternalPrepare;
1464 CheckHandle;
1465 if aTransaction <> FTransactionIntf then
1466 AddMonitor(aTransaction as TFB30Transaction);
1467 if FStaleReferenceChecks and (FSQLParams.FTransactionSeqNo < (FTransactionIntf as TFB30transaction).TransactionSeqNo) then
1468 IBError(ibxeInterfaceOutofDate,[nil]);
1469
1470
1471 try
1472 with FFirebird30ClientAPI do
1473 begin
1474 case FSQLStatementType of
1475 SQLSelect:
1476 {e.g. Update...returning with a single row in Firebird 5 and later}
1477 begin
1478 Cursor := InternalOpenCursor(aTransaction,false);
1479 if not Cursor.IsEof then
1480 Cursor.FetchNext;
1481 Result := Cursor; {note only first row}
1482 FSingleResults := true;
1483 end;
1484
1485 SQLExecProcedure:
1486 begin
1487 ExecuteQuery(FSQLRecord.MetaData,FSQLRecord.MessageBuffer);
1488 Result := TResults.Create(FSQLRecord);
1489 FSingleResults := true;
1490 end;
1491
1492 else
1493 ExecuteQuery;
1494 end;
1495 end;
1496 finally
1497 if aTransaction <> FTransactionIntf then
1498 RemoveMonitor(aTransaction as TFB30Transaction);
1499 end;
1500 FExecTransactionIntf := aTransaction;
1501 FSQLRecord.FTransaction := (aTransaction as TFB30Transaction);
1502 FSQLRecord.FTransactionSeqNo := FSQLRecord.FTransaction.TransactionSeqNo;
1503 SignalActivity;
1504 Inc(FChangeSeqNo);
1505 end;
1506
1507 function TFB30Statement.InternalOpenCursor(aTransaction: ITransaction;
1508 Scrollable: boolean): IResultSet;
1509 var flags: cardinal;
1510 begin
1511 flags := 0;
1512 if (FSQLStatementType <> SQLSelect) and not (stHasCursor in getFlags) then
1513 IBError(ibxeIsASelectStatement,[]);
1514
1515 FBatchCompletion := nil;
1516 CheckTransaction(aTransaction);
1517 if not FPrepared then
1518 InternalPrepare;
1519 CheckHandle;
1520 if aTransaction <> FTransactionIntf then
1521 AddMonitor(aTransaction as TFB30Transaction);
1522 if FStaleReferenceChecks and (FSQLParams.FTransactionSeqNo < (FTransactionIntf as TFB30transaction).TransactionSeqNo) then
1523 IBError(ibxeInterfaceOutofDate,[nil]);
1524
1525 if Scrollable then
1526 flags := Firebird.IStatement.CURSOR_TYPE_SCROLLABLE;
1527
1528 with FFirebird30ClientAPI do
1529 begin
1530 if FCollectStatistics then
1531 begin
1532 UtilIntf.getPerfCounters(StatusIntf,
1533 (GetAttachment as TFB30Attachment).AttachmentIntf,
1534 ISQL_COUNTERS, @FBeforeStats);
1535 Check4DataBaseError;
1536 end;
1537
1538 FResultSet := FStatementIntf.openCursor(StatusIntf,
1539 (aTransaction as TFB30Transaction).TransactionIntf,
1540 FSQLParams.MetaData,
1541 FSQLParams.MessageBuffer,
1542 FSQLRecord.MetaData,
1543 flags);
1544 Check4DataBaseError;
1545
1546 if FCollectStatistics then
1547 begin
1548 UtilIntf.getPerfCounters(StatusIntf,
1549 (GetAttachment as TFB30Attachment).AttachmentIntf,
1550 ISQL_COUNTERS,@FAfterStats);
1551 Check4DataBaseError;
1552 FStatisticsAvailable := true;
1553 end;
1554 end;
1555 Inc(FCursorSeqNo);
1556 FSingleResults := false;
1557 FOpen := True;
1558 FExecTransactionIntf := aTransaction;
1559 FBOF := true;
1560 FEOF := false;
1561 FSQLRecord.FTransaction := (aTransaction as TFB30Transaction);
1562 FSQLRecord.FTransactionSeqNo := FSQLRecord.FTransaction.TransactionSeqNo;
1563 Result := TResultSet.Create(FSQLRecord);
1564 SignalActivity;
1565 Inc(FChangeSeqNo);
1566 end;
1567
1568 procedure TFB30Statement.ProcessSQL(sql: AnsiString; GenerateParamNames: boolean;
1569 var processedSQL: AnsiString);
1570 begin
1571 FSQLParams.PreprocessSQL(sql,GenerateParamNames,processedSQL);
1572 end;
1573
1574 procedure TFB30Statement.FreeHandle;
1575 begin
1576 Close;
1577 ReleaseInterfaces;
1578 if FBatch <> nil then
1579 begin
1580 FBatch.release;
1581 FBatch := nil;
1582 end;
1583 if FStatementIntf <> nil then
1584 begin
1585 FStatementIntf.release;
1586 FStatementIntf := nil;
1587 FPrepared := false;
1588 end;
1589 FCursor := '';
1590 end;
1591
1592 procedure TFB30Statement.InternalClose(Force: boolean);
1593 begin
1594 if (FStatementIntf <> nil) and (SQLStatementType = SQLSelect) and FOpen then
1595 try
1596 with FFirebird30ClientAPI do
1597 begin
1598 if FResultSet <> nil then
1599 begin
1600 if FSQLRecord.FTransaction.InTransaction and
1601 (FSQLRecord.FTransactionSeqNo = FSQLRecord.FTransaction.TransactionSeqNo) then
1602 FResultSet.close(StatusIntf)
1603 else
1604 FResultSet.release;
1605 end;
1606 FResultSet := nil;
1607 if not Force then Check4DataBaseError;
1608 end;
1609 finally
1610 if (FSQLRecord.FTransaction <> nil) and (FSQLRecord.FTransaction <> (FTransactionIntf as TFB30Transaction)) then
1611 RemoveMonitor(FSQLRecord.FTransaction);
1612 FOpen := False;
1613 FExecTransactionIntf := nil;
1614 FSQLRecord.FTransaction := nil;
1615 end;
1616 SignalActivity;
1617 Inc(FChangeSeqNo);
1618 end;
1619
1620 function TFB30Statement.SavePerfStats(var Stats: TPerfStatistics): boolean;
1621 begin
1622 Result := false;
1623 if FCollectStatistics then
1624 with FFirebird30ClientAPI do
1625 begin
1626 UtilIntf.getPerfCounters(StatusIntf,
1627 (GetAttachment as TFB30Attachment).AttachmentIntf,
1628 ISQL_COUNTERS, @Stats);
1629 Check4DataBaseError;
1630 Result := true;
1631 end;
1632 end;
1633
1634 constructor TFB30Statement.Create(Attachment: TFB30Attachment;
1635 Transaction: ITransaction; sql: AnsiString; aSQLDialect: integer;
1636 CursorName: AnsiString);
1637 begin
1638 inherited Create(Attachment,Transaction,sql,aSQLDialect);
1639 FFirebird30ClientAPI := Attachment.Firebird30ClientAPI;
1640 FSQLParams := TIBXINPUTSQLDA.Create(self);
1641 FSQLRecord := TIBXOUTPUTSQLDA.Create(self);
1642 InternalPrepare(CursorName);
1643 end;
1644
1645 constructor TFB30Statement.CreateWithParameterNames(
1646 Attachment: TFB30Attachment; Transaction: ITransaction; sql: AnsiString;
1647 aSQLDialect: integer; GenerateParamNames: boolean;
1648 CaseSensitiveParams: boolean; CursorName: AnsiString);
1649 begin
1650 inherited CreateWithParameterNames(Attachment,Transaction,sql,aSQLDialect,GenerateParamNames);
1651 FFirebird30ClientAPI := Attachment.Firebird30ClientAPI;
1652 FSQLParams := TIBXINPUTSQLDA.Create(self);
1653 FSQLParams.CaseSensitiveParams := CaseSensitiveParams;
1654 FSQLRecord := TIBXOUTPUTSQLDA.Create(self);
1655 InternalPrepare(CursorName);
1656 end;
1657
1658 destructor TFB30Statement.Destroy;
1659 begin
1660 inherited Destroy;
1661 if assigned(FSQLParams) then FSQLParams.Free;
1662 if assigned(FSQLRecord) then FSQLRecord.Free;
1663 end;
1664
1665 function TFB30Statement.Fetch(FetchType: TFetchType; PosOrOffset: integer
1666 ): boolean;
1667 var fetchResult: integer;
1668 begin
1669 result := false;
1670 if not FOpen then
1671 IBError(ibxeSQLClosed, [nil]);
1672
1673 with FFirebird30ClientAPI do
1674 begin
1675 case FetchType of
1676 ftNext:
1677 begin
1678 if FEOF then
1679 IBError(ibxeEOF,[nil]);
1680 { Go to the next record... }
1681 fetchResult := FResultSet.fetchNext(StatusIntf,FSQLRecord.MessageBuffer);
1682 if fetchResult = Firebird.IStatus.RESULT_NO_DATA then
1683 begin
1684 FBOF := false;
1685 FEOF := true;
1686 Exit; {End of File}
1687 end
1688 end;
1689
1690 ftPrior:
1691 begin
1692 if FBOF then
1693 IBError(ibxeBOF,[nil]);
1694 { Go to the next record... }
1695 fetchResult := FResultSet.fetchPrior(StatusIntf,FSQLRecord.MessageBuffer);
1696 if fetchResult = Firebird.IStatus.RESULT_NO_DATA then
1697 begin
1698 FBOF := true;
1699 FEOF := false;
1700 Exit; {Top of File}
1701 end
1702 end;
1703
1704 ftFirst:
1705 fetchResult := FResultSet.fetchFirst(StatusIntf,FSQLRecord.MessageBuffer);
1706
1707 ftLast:
1708 fetchResult := FResultSet.fetchLast(StatusIntf,FSQLRecord.MessageBuffer);
1709
1710 ftAbsolute:
1711 fetchResult := FResultSet.fetchAbsolute(StatusIntf,PosOrOffset,FSQLRecord.MessageBuffer);
1712
1713 ftRelative:
1714 fetchResult := FResultSet.fetchRelative(StatusIntf,PosOrOffset,FSQLRecord.MessageBuffer);
1715 end;
1716
1717 Check4DataBaseError;
1718 if fetchResult <> Firebird.IStatus.RESULT_OK then
1719 exit; {result = false}
1720
1721 {Result OK}
1722 FBOF := false;
1723 FEOF := false;
1724 result := true;
1725
1726 if FCollectStatistics then
1727 begin
1728 UtilIntf.getPerfCounters(StatusIntf,
1729 (GetAttachment as TFB30Attachment).AttachmentIntf,
1730 ISQL_COUNTERS,@FAfterStats);
1731 Check4DataBaseError;
1732 FStatisticsAvailable := true;
1733 end;
1734 end;
1735 FSQLRecord.RowChange;
1736 SignalActivity;
1737 if FEOF then
1738 Inc(FChangeSeqNo);
1739 end;
1740
1741 function TFB30Statement.GetSQLParams: ISQLParams;
1742 begin
1743 CheckHandle;
1744 if not HasInterface(0) then
1745 AddInterface(0,TSQLParams.Create(FSQLParams));
1746 Result := TSQLParams(GetInterface(0));
1747 end;
1748
1749 function TFB30Statement.GetMetaData: IMetaData;
1750 begin
1751 CheckHandle;
1752 if not HasInterface(1) then
1753 AddInterface(1, TMetaData.Create(FSQLRecord));
1754 Result := TMetaData(GetInterface(1));
1755 end;
1756
1757 function TFB30Statement.GetPlan: AnsiString;
1758 begin
1759 CheckHandle;
1760 if (not (FSQLStatementType in [SQLSelect, SQLSelectForUpdate,
1761 {TODO: SQLExecProcedure, }
1762 SQLUpdate, SQLDelete])) then
1763 result := ''
1764 else
1765 with FFirebird30ClientAPI do
1766 begin
1767 Result := FStatementIntf.getPlan(StatusIntf,true);
1768 Check4DataBaseError;
1769 end;
1770 end;
1771
1772 function TFB30Statement.CreateBlob(column: TColumnMetaData): IBlob;
1773 begin
1774 if assigned(column) and (column.SQLType <> SQL_Blob) then
1775 IBError(ibxeNotABlob,[nil]);
1776 Result := TFB30Blob.Create(GetAttachment as TFB30Attachment,
1777 GetTransaction as TFB30Transaction,
1778 column.GetBlobMetaData,nil);
1779 end;
1780
1781 function TFB30Statement.CreateArray(column: TColumnMetaData): IArray;
1782 begin
1783 if assigned(column) and (column.SQLType <> SQL_ARRAY) then
1784 IBError(ibxeNotAnArray,[nil]);
1785 Result := TFB30Array.Create(GetAttachment as TFB30Attachment,
1786 GetTransaction as TFB30Transaction,
1787 column.GetArrayMetaData);
1788 end;
1789
1790 procedure TFB30Statement.SetRetainInterfaces(aValue: boolean);
1791 begin
1792 inherited SetRetainInterfaces(aValue);
1793 if HasInterface(1) then
1794 TMetaData(GetInterface(1)).RetainInterfaces := aValue;
1795 if HasInterface(0) then
1796 TSQLParams(GetInterface(0)).RetainInterfaces := aValue;
1797 end;
1798
1799 function TFB30Statement.IsInBatchMode: boolean;
1800 begin
1801 Result := FBatch <> nil;
1802 end;
1803
1804 function TFB30Statement.HasBatchMode: boolean;
1805 begin
1806 Result := GetAttachment.HasBatchMode;
1807 end;
1808
1809 procedure TFB30Statement.AddToBatch;
1810 var BatchPB: TXPBParameterBlock;
1811
1812 const SixteenMB = 16 * 1024 * 1024;
1813 begin
1814 FBatchCompletion := nil;
1815 if not FPrepared then
1816 InternalPrepare;
1817 CheckHandle;
1818 CheckBatchModeAvailable;
1819 with FFirebird30ClientAPI do
1820 begin
1821 if FBatch = nil then
1822 begin
1823 {Start Batch}
1824 BatchPB := TXPBParameterBlock.Create(FFirebird30ClientAPI,Firebird.IXpbBuilder.BATCH);
1825 with FFirebird30ClientAPI do
1826 try
1827 FBatchBufferSize := FBatchRowLimit * FSQLParams.MetaData.getAlignedLength(StatusIntf);
1828 Check4DatabaseError;
1829 if FBatchBufferSize < SixteenMB then
1830 FBatchBufferSize := SixteenMB;
1831 if FBatchBufferSize > 256 * 1024 *1024 {assumed limit} then
1832 IBError(ibxeBatchBufferSizeTooBig,[FBatchBufferSize]);
1833
1834 BatchPB.insertInt(Firebird.IBatch.TAG_RECORD_COUNTS,1);
1835 BatchPB.insertInt(Firebird.IBatch.TAG_BUFFER_BYTES_SIZE,FBatchBufferSize);
1836 FBatch := FStatementIntf.createBatch(StatusIntf,
1837 FSQLParams.MetaData,
1838 BatchPB.getDataLength,
1839 BatchPB.getBuffer);
1840 Check4DataBaseError;
1841
1842 finally
1843 BatchPB.Free;
1844 end;
1845 FBatchRowCount := 0;
1846 FBatchBufferUsed := 0;
1847 end;
1848
1849 Inc(FBatchRowCount);
1850 Inc(FBatchBufferUsed,FSQLParams.MetaData.getAlignedLength(StatusIntf));
1851 Check4DataBaseError;
1852 if FBatchBufferUsed > FBatchBufferSize then
1853 raise EIBBatchBufferOverflow.Create(Ord(ibxeBatchRowBufferOverflow),
1854 Format(GetErrorMessage(ibxeBatchRowBufferOverflow),
1855 [FBatchRowCount,FBatchBufferSize]));
1856
1857 FBatch.Add(StatusIntf,1,FSQLParams.GetMessageBuffer);
1858 Check4DataBaseError
1859 end;
1860 end;
1861
1862 function TFB30Statement.ExecuteBatch(aTransaction: ITransaction
1863 ): IBatchCompletion;
1864
1865 procedure Check4BatchCompletionError(bc: IBatchCompletion);
1866 var status: IStatus;
1867 RowNo: integer;
1868 begin
1869 status := nil;
1870 {Raise an exception if there was an error reported in the BatchCompletion}
1871 if (bc <> nil) and bc.getErrorStatus(RowNo,status) then
1872 raise EIBInterbaseError.Create(status);
1873 end;
1874
1875 var cs: Firebird.IBatchCompletionState;
1876
1877 begin
1878 Result := nil;
1879 if FBatch = nil then
1880 IBError(ibxeNotInBatchMode,[]);
1881
1882 with FFirebird30ClientAPI do
1883 begin
1884 SavePerfStats(FBeforeStats);
1885 if aTransaction = nil then
1886 cs := FBatch.execute(StatusIntf,(FTransactionIntf as TFB30Transaction).TransactionIntf)
1887 else
1888 cs := FBatch.execute(StatusIntf,(aTransaction as TFB30Transaction).TransactionIntf);
1889 Check4DataBaseError;
1890 FBatchCompletion := TBatchCompletion.Create(FFirebird30ClientAPI,cs);
1891 FStatisticsAvailable := SavePerfStats(FAfterStats);
1892 FBatch.release;
1893 FBatch := nil;
1894 Check4BatchCompletionError(FBatchCompletion);
1895 Result := FBatchCompletion;
1896 end;
1897 end;
1898
1899 procedure TFB30Statement.CancelBatch;
1900 begin
1901 if FBatch = nil then
1902 IBError(ibxeNotInBatchMode,[]);
1903 FBatch.release;
1904 FBatch := nil;
1905 end;
1906
1907 function TFB30Statement.GetBatchCompletion: IBatchCompletion;
1908 begin
1909 Result := FBatchCompletion;
1910 end;
1911
1912 function TFB30Statement.IsPrepared: boolean;
1913 begin
1914 Result := FStatementIntf <> nil;
1915 end;
1916
1917 function TFB30Statement.GetFlags: TStatementFlags;
1918 var flags: cardinal;
1919 begin
1920 CheckHandle;
1921 Result := [];
1922 with FFirebird30ClientAPI do
1923 begin
1924 flags := FStatementIntf.getFlags(StatusIntf);
1925 Check4DataBaseError;
1926 end;
1927 if flags and Firebird.IStatement.FLAG_HAS_CURSOR <> 0 then
1928 Result := Result + [stHasCursor];
1929 if flags and Firebird.IStatement.FLAG_REPEAT_EXECUTE <> 0 then
1930 Result := Result + [stRepeatExecute];
1931 if flags and Firebird.IStatement.CURSOR_TYPE_SCROLLABLE <> 0 then
1932 Result := Result + [stScrollable];
1933 end;
1934
1935 end.
1936