ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/3.0/FB30Statement.pas
Revision: 60
Committed: Mon Mar 27 15:21:02 2017 UTC (7 years ago) by tony
Content type: text/x-pascal
File size: 37631 byte(s)
Log Message:

File Contents

# Content
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
82 TFB30Statement = class;
83 TIBXSQLDA = class;
84
85 { TIBXSQLVAR }
86
87 TIBXSQLVAR = class(TSQLVarData)
88 private
89 FStatement: TFB30Statement;
90 FBlob: IBlob; {Cache references}
91 FArray: IArray;
92 FNullIndicator: short;
93 FOwnsSQLData: boolean;
94 FBlobMetaData: IBlobMetaData;
95 FArrayMetaData: IArrayMetaData;
96
97 {SQL Var Type Data}
98 FSQLType: cardinal;
99 FSQLSubType: integer;
100 FSQLData: PByte; {Address of SQL Data in Message Buffer}
101 FSQLNullIndicator: PShort; {Address of null indicator}
102 FDataLength: integer;
103 FNullable: boolean;
104 FScale: integer;
105 FCharSetID: cardinal;
106 FRelationName: AnsiString;
107 FFieldName: AnsiString;
108
109 protected
110 function GetSQLType: cardinal; override;
111 function GetSubtype: integer; override;
112 function GetAliasName: AnsiString; override;
113 function GetFieldName: AnsiString; override;
114 function GetOwnerName: AnsiString; override;
115 function GetRelationName: AnsiString; override;
116 function GetScale: integer; override;
117 function GetCharSetID: cardinal; override;
118 function GetCodePage: TSystemCodePage; override;
119 function GetIsNull: Boolean; override;
120 function GetIsNullable: boolean; override;
121 function GetSQLData: PByte; override;
122 function GetDataLength: cardinal; override;
123 procedure SetIsNull(Value: Boolean); override;
124 procedure SetIsNullable(Value: Boolean); override;
125 procedure SetSQLData(AValue: PByte; len: cardinal); override;
126 procedure SetScale(aValue: integer); override;
127 procedure SetDataLength(len: cardinal); override;
128 procedure SetSQLType(aValue: cardinal); override;
129 procedure SetCharSetID(aValue: cardinal); override;
130
131 public
132 constructor Create(aParent: TIBXSQLDA; aIndex: integer);
133 procedure Changed; override;
134 procedure RowChange; override;
135 procedure FreeSQLData;
136 function GetAsArray(Array_ID: TISC_QUAD): IArray; override;
137 function GetAsBlob(Blob_ID: TISC_QUAD; BPB: IBPB): IBlob; override;
138 function GetArrayMetaData: IArrayMetaData; override;
139 function GetBlobMetaData: IBlobMetaData; override;
140 function CreateBlob: IBlob; override;
141 end;
142
143 { TIBXSQLDA }
144
145 TIBXSQLDA = class(TSQLDataArea)
146 private
147 FCount: Integer; {Columns in use - may be less than inherited columns}
148 FSize: Integer; {Number of TIBXSQLVARs in column list}
149 FMetaData: Firebird.IMessageMetadata;
150 FTransactionSeqNo: integer;
151 protected
152 FStatement: TFB30Statement;
153 function GetTransactionSeqNo: integer; override;
154 procedure FreeXSQLDA; virtual;
155 function GetStatement: IStatement; override;
156 function GetPrepareSeqNo: integer; override;
157 procedure SetCount(Value: Integer); override;
158 public
159 constructor Create(aStatement: TFB30Statement);
160 destructor Destroy; override;
161 procedure Changed; virtual;
162 function CheckStatementStatus(Request: TStatementStatus): boolean; override;
163 function ColumnsInUseCount: integer; override;
164 function GetTransaction: TFB30Transaction; virtual;
165 procedure Initialize; override;
166 function StateChanged(var ChangeSeqNo: integer): boolean; override;
167 property MetaData: Firebird.IMessageMetadata read FMetaData;
168 property Count: Integer read FCount write SetCount;
169 property Statement: TFB30Statement read FStatement;
170 end;
171
172 { TIBXINPUTSQLDA }
173
174 TIBXINPUTSQLDA = class(TIBXSQLDA)
175 private
176 FMessageBuffer: PByte; {Message Buffer}
177 FMsgLength: integer; {Message Buffer length}
178 FCurMetaData: Firebird.IMessageMetadata;
179 procedure FreeMessageBuffer;
180 function GetMessageBuffer: PByte;
181 function GetMetaData: Firebird.IMessageMetadata;
182 function GetModified: Boolean;
183 function GetMsgLength: integer;
184 procedure PackBuffer;
185 protected
186 procedure FreeXSQLDA; override;
187 public
188 constructor Create(aStatement: TFB30Statement);
189 destructor Destroy; override;
190 procedure Bind(aMetaData: Firebird.IMessageMetadata);
191 procedure Changed; override;
192 function IsInputDataArea: boolean; override;
193 property MetaData: Firebird.IMessageMetadata read GetMetaData;
194 property MessageBuffer: PByte read GetMessageBuffer;
195 property MsgLength: integer read GetMsgLength;
196 end;
197
198 { TIBXOUTPUTSQLDA }
199
200 TIBXOUTPUTSQLDA = class(TIBXSQLDA)
201 private
202 FTransaction: TFB30Transaction; {transaction used to execute the statement}
203 FMessageBuffer: PByte; {Message Buffer}
204 FMsgLength: integer; {Message Buffer length}
205 protected
206 procedure FreeXSQLDA; override;
207 public
208 procedure Bind(aMetaData: Firebird.IMessageMetadata);
209 procedure GetData(index: integer; var aIsNull: boolean; var len: short;
210 var data: PByte); override;
211 function IsInputDataArea: boolean; override;
212 property MessageBuffer: PByte read FMessageBuffer;
213 property MsgLength: integer read FMsgLength;
214 end;
215
216 { TResultSet }
217
218 TResultSet = class(TResults,IResultSet)
219 private
220 FResults: TIBXOUTPUTSQLDA;
221 FCursorSeqNo: integer;
222 public
223 constructor Create(aResults: TIBXOUTPUTSQLDA);
224 destructor Destroy; override;
225 {IResultSet}
226 function FetchNext: boolean;
227 function GetCursorName: AnsiString;
228 function GetTransaction: ITransaction; override;
229 function IsEof: boolean;
230 procedure Close;
231 end;
232
233 { TFB30Statement }
234
235 TFB30Statement = class(TFBStatement,IStatement)
236 private
237 FStatementIntf: Firebird.IStatement;
238 FSQLParams: TIBXINPUTSQLDA;
239 FSQLRecord: TIBXOUTPUTSQLDA;
240 FResultSet: Firebird.IResultSet;
241 FCursorSeqNo: integer;
242 protected
243 procedure CheckHandle; override;
244 procedure GetDSQLInfo(info_request: byte; buffer: ISQLInfoResults); override;
245 procedure InternalPrepare; override;
246 function InternalExecute(aTransaction: ITransaction): IResults; override;
247 function InternalOpenCursor(aTransaction: ITransaction): IResultSet; override;
248 procedure FreeHandle; override;
249 procedure InternalClose(Force: boolean); override;
250 public
251 constructor Create(Attachment: TFB30Attachment; Transaction: ITransaction;
252 sql: AnsiString; aSQLDialect: integer);
253 constructor CreateWithParameterNames(Attachment: TFB30Attachment; Transaction: ITransaction;
254 sql: AnsiString; aSQLDialect: integer; GenerateParamNames: boolean =false);
255 destructor Destroy; override;
256 function FetchNext: boolean;
257 property StatementIntf: Firebird.IStatement read FStatementIntf;
258
259 public
260 {IStatement}
261 function GetSQLParams: ISQLParams; override;
262 function GetMetaData: IMetaData; override;
263 function GetPlan: AnsiString;
264 function IsPrepared: boolean;
265 function CreateBlob(column: TColumnMetaData): IBlob; override;
266 function CreateArray(column: TColumnMetaData): IArray; override;
267 procedure SetRetainInterfaces(aValue: boolean); override;
268
269 end;
270
271 implementation
272
273 uses IBUtils, FBMessages, FBBLob, FB30Blob, variants, FBArray, FB30Array;
274
275 const
276 ISQL_COUNTERS = 'CurrentMemory, MaxMemory, RealTime, UserTime, Buffers, Reads, Writes, Fetches';
277
278 { TIBXSQLVAR }
279
280 procedure TIBXSQLVAR.Changed;
281 begin
282 inherited Changed;
283 TIBXSQLDA(Parent).Changed;
284 end;
285
286 function TIBXSQLVAR.GetSQLType: cardinal;
287 begin
288 Result := FSQLType;
289 end;
290
291 function TIBXSQLVAR.GetSubtype: integer;
292 begin
293 Result := FSQLSubType;
294 end;
295
296 function TIBXSQLVAR.GetAliasName: AnsiString;
297 begin
298 with Firebird30ClientAPI do
299 begin
300 result := strpas(TIBXSQLDA(Parent).MetaData.getAlias(StatusIntf,Index));
301 Check4DataBaseError;
302 end;
303 end;
304
305 function TIBXSQLVAR.GetFieldName: AnsiString;
306 begin
307 Result := FFieldName;
308 end;
309
310 function TIBXSQLVAR.GetOwnerName: AnsiString;
311 begin
312 with Firebird30ClientAPI do
313 begin
314 result := strpas(TIBXSQLDA(Parent).MetaData.getOwner(StatusIntf,Index));
315 Check4DataBaseError;
316 end;
317 end;
318
319 function TIBXSQLVAR.GetRelationName: AnsiString;
320 begin
321 Result := FRelationName;
322 end;
323
324 function TIBXSQLVAR.GetScale: integer;
325 begin
326 Result := FScale;
327 end;
328
329 function TIBXSQLVAR.GetCharSetID: cardinal;
330 begin
331 result := 0;
332 case SQLType of
333 SQL_VARYING, SQL_TEXT:
334 result := FCharSetID;
335
336 SQL_BLOB:
337 if (SQLSubType = 1) then
338 result := FCharSetID;
339
340 SQL_ARRAY:
341 if (FRelationName <> '') and (FFieldName <> '') then
342 result := GetArrayMetaData.GetCharSetID
343 else
344 result := FCharSetID;
345 end;
346 result := result;
347 end;
348
349 function TIBXSQLVAR.GetCodePage: TSystemCodePage;
350 begin
351 result := CP_NONE;
352 with Statement.GetAttachment do
353 CharSetID2CodePage(GetCharSetID,result);
354 end;
355
356 function TIBXSQLVAR.GetIsNull: Boolean;
357 begin
358 Result := IsNullable and (FSQLNullIndicator^ = -1);
359 end;
360
361 function TIBXSQLVAR.GetIsNullable: boolean;
362 begin
363 Result := FSQLNullIndicator <> nil;
364 end;
365
366 function TIBXSQLVAR.GetSQLData: PByte;
367 begin
368 Result := FSQLData;
369 end;
370
371 function TIBXSQLVAR.GetDataLength: cardinal;
372 begin
373 Result := FDataLength;
374 end;
375
376 function TIBXSQLVAR.GetArrayMetaData: IArrayMetaData;
377 begin
378 if GetSQLType <> SQL_ARRAY then
379 IBError(ibxeInvalidDataConversion,[nil]);
380
381 if FArrayMetaData = nil then
382 FArrayMetaData := TFB30ArrayMetaData.Create(FStatement.GetAttachment as TFB30Attachment,
383 FStatement.GetTransaction as TFB30Transaction,
384 GetRelationName,GetFieldName);
385 Result := FArrayMetaData;
386 end;
387
388 function TIBXSQLVAR.GetBlobMetaData: IBlobMetaData;
389 begin
390 if GetSQLType <> SQL_BLOB then
391 IBError(ibxeInvalidDataConversion,[nil]);
392
393 if FBlobMetaData = nil then
394 FBlobMetaData := TFB30BlobMetaData.Create(FStatement.GetAttachment as TFB30Attachment,
395 FStatement.GetTransaction as TFB30Transaction,
396 GetRelationName,GetFieldName,
397 GetSubType);
398 (FBlobMetaData as TFBBlobMetaData).SetCharSetID(GetCharSetID);
399 Result := FBlobMetaData;
400 end;
401
402 procedure TIBXSQLVAR.SetIsNull(Value: Boolean);
403 begin
404 if Value then
405 begin
406 IsNullable := true;
407 FNullIndicator := -1;
408 end
409 else
410 if IsNullable then
411 FNullIndicator := 0;
412 Changed;
413 end;
414
415 procedure TIBXSQLVAR.SetIsNullable(Value: Boolean);
416 begin
417 if Value = IsNullable then Exit;
418 if Value then
419 begin
420 FSQLNullIndicator := @FNullIndicator;
421 FNullIndicator := 0;
422 end
423 else
424 FSQLNullIndicator := nil;
425 end;
426
427 procedure TIBXSQLVAR.SetSQLData(AValue: PByte; len: cardinal);
428 begin
429 if FOwnsSQLData then
430 FreeMem(FSQLData);
431 FSQLData := AValue;
432 FDataLength := len;
433 FOwnsSQLData := false;
434 end;
435
436 procedure TIBXSQLVAR.SetScale(aValue: integer);
437 begin
438 FScale := aValue;
439 end;
440
441 procedure TIBXSQLVAR.SetDataLength(len: cardinal);
442 begin
443 if not FOwnsSQLData then
444 FSQLData := nil;
445 FDataLength := len;
446 with Firebird30ClientAPI do
447 IBAlloc(FSQLData, 0, FDataLength);
448 FOwnsSQLData := true;
449 end;
450
451 procedure TIBXSQLVAR.SetSQLType(aValue: cardinal);
452 begin
453 FSQLType := aValue;
454 end;
455
456 procedure TIBXSQLVAR.SetCharSetID(aValue: cardinal);
457 begin
458 FCharSetID := aValue;
459 end;
460
461 constructor TIBXSQLVAR.Create(aParent: TIBXSQLDA; aIndex: integer);
462 begin
463 inherited Create(aParent,aIndex);
464 FStatement := aParent.Statement;
465 end;
466
467 procedure TIBXSQLVAR.RowChange;
468 begin
469 inherited;
470 FBlob := nil;
471 FArray := nil;
472 end;
473
474 procedure TIBXSQLVAR.FreeSQLData;
475 begin
476 if FOwnsSQLData then
477 FreeMem(FSQLData);
478 FSQLData := nil;
479 FOwnsSQLData := true;
480 end;
481
482 function TIBXSQLVAR.GetAsArray(Array_ID: TISC_QUAD): IArray;
483 begin
484 if SQLType <> SQL_ARRAY then
485 IBError(ibxeInvalidDataConversion,[nil]);
486
487 if IsNull then
488 Result := nil
489 else
490 begin
491 if FArray = nil then
492 FArray := TFB30Array.Create(FStatement.GetAttachment as TFB30Attachment,
493 TIBXSQLDA(Parent).GetTransaction,
494 GetArrayMetaData,Array_ID);
495 Result := FArray;
496 end;
497 end;
498
499 function TIBXSQLVAR.GetAsBlob(Blob_ID: TISC_QUAD; BPB: IBPB): IBlob;
500 begin
501 if FBlob <> nil then
502 Result := FBlob
503 else
504 begin
505 if SQLType <> SQL_BLOB then
506 IBError(ibxeInvalidDataConversion, [nil]);
507 if IsNull then
508 Result := nil
509 else
510 Result := TFB30Blob.Create(FStatement.GetAttachment as TFB30Attachment,
511 TIBXSQLDA(Parent).GetTransaction,
512 GetBlobMetaData,
513 Blob_ID,BPB);
514 FBlob := Result;
515 end;
516 end;
517
518 function TIBXSQLVAR.CreateBlob: IBlob;
519 begin
520 Result := TFB30Blob.Create(FStatement.GetAttachment as TFB30Attachment,
521 FStatement.GetTransaction as TFB30Transaction,
522 GetSubType,GetCharSetID,nil);
523 end;
524
525 { TResultSet }
526
527 constructor TResultSet.Create(aResults: TIBXOUTPUTSQLDA);
528 begin
529 inherited Create(aResults);
530 FResults := aResults;
531 FCursorSeqNo := aResults.FStatement.FCursorSeqNo;
532 end;
533
534 destructor TResultSet.Destroy;
535 begin
536 Close;
537 inherited Destroy;
538 end;
539
540 function TResultSet.FetchNext: boolean;
541 var i: integer;
542 begin
543 CheckActive;
544 Result := FResults.FStatement.FetchNext;
545 if Result then
546 for i := 0 to getCount - 1 do
547 FResults.Column[i].RowChange;
548 end;
549
550 function TResultSet.GetCursorName: AnsiString;
551 begin
552 IBError(ibxeNotSupported,[nil]);
553 Result := '';
554 end;
555
556 function TResultSet.GetTransaction: ITransaction;
557 begin
558 Result := FResults.FTransaction;
559 end;
560
561 function TResultSet.IsEof: boolean;
562 begin
563 Result := FResults.FStatement.FEof;
564 end;
565
566 procedure TResultSet.Close;
567 begin
568 if FCursorSeqNo = FResults.FStatement.FCursorSeqNo then
569 FResults.FStatement.Close;
570 end;
571
572 { TIBXINPUTSQLDA }
573
574 function TIBXINPUTSQLDA.GetModified: Boolean;
575 var
576 i: Integer;
577 begin
578 result := False;
579 for i := 0 to FCount - 1 do
580 if Column[i].Modified then
581 begin
582 result := True;
583 exit;
584 end;
585 end;
586
587 procedure TIBXINPUTSQLDA.FreeMessageBuffer;
588 begin
589 if FCurMetaData <> nil then
590 begin
591 FCurMetaData.release;
592 FCurMetaData := nil;
593 end;
594 if FMessageBuffer <> nil then
595 begin
596 FreeMem(FMessageBuffer);
597 FMessageBuffer := nil;
598 end;
599 FMsgLength := 0;
600 end;
601
602 function TIBXINPUTSQLDA.GetMessageBuffer: PByte;
603 begin
604 PackBuffer;
605 Result := FMessageBuffer;
606 end;
607
608 function TIBXINPUTSQLDA.GetMetaData: Firebird.IMessageMetadata;
609 begin
610 PackBuffer;
611 Result := FCurMetaData;
612 end;
613
614 function TIBXINPUTSQLDA.GetMsgLength: integer;
615 begin
616 PackBuffer;
617 Result := FMsgLength;
618 end;
619
620 procedure TIBXINPUTSQLDA.PackBuffer;
621 var Builder: Firebird.IMetadataBuilder;
622 i: integer;
623 begin
624 if FMsgLength > 0 then Exit;
625
626 with Firebird30ClientAPI do
627 begin
628 Builder := inherited MetaData.getBuilder(StatusIntf);
629 Check4DataBaseError;
630 try
631 for i := 0 to Count - 1 do
632 with TIBXSQLVar(Column[i]) do
633 begin
634 Builder.setType(StatusIntf,i,FSQLType);
635 Check4DataBaseError;
636 Builder.setSubType(StatusIntf,i,FSQLSubType);
637 Check4DataBaseError;
638 Builder.setLength(StatusIntf,i,FDataLength);
639 Check4DataBaseError;
640 Builder.setCharSet(StatusIntf,i,GetCharSetID);
641 Check4DataBaseError;
642 Builder.setScale(StatusIntf,i,FScale);
643 Check4DataBaseError;
644 end;
645 FCurMetaData := Builder.getMetadata(StatusIntf);
646 Check4DataBaseError;
647 finally
648 Builder.release;
649 end;
650
651 FMsgLength := FCurMetaData.getMessageLength(StatusIntf);
652 Check4DataBaseError;
653
654 IBAlloc(FMessageBuffer,0,FMsgLength);
655
656 for i := 0 to Count - 1 do
657 with TIBXSQLVar(Column[i]) do
658 begin
659 if IsNull then
660 FillChar((FMessageBuffer + FCurMetaData.getOffset(StatusIntf,i))^,FDataLength,0)
661 else
662 Move(FSQLData^,(FMessageBuffer + FCurMetaData.getOffset(StatusIntf,i))^,FDataLength);
663 Check4DataBaseError;
664 if IsNullable then
665 begin
666 Move(FNullIndicator,(FMessageBuffer + FCurMetaData.getNullOffset(StatusIntf,i))^,sizeof(FNullIndicator));
667 Check4DataBaseError;
668 end;
669 end;
670 end;
671 end;
672
673 procedure TIBXINPUTSQLDA.FreeXSQLDA;
674 begin
675 inherited FreeXSQLDA;
676 FreeMessageBuffer;
677 end;
678
679 constructor TIBXINPUTSQLDA.Create(aStatement: TFB30Statement);
680 begin
681 inherited Create(aStatement);
682 FMessageBuffer := nil;
683 end;
684
685 destructor TIBXINPUTSQLDA.Destroy;
686 begin
687 FreeMessageBuffer;
688 inherited Destroy;
689 end;
690
691 procedure TIBXINPUTSQLDA.Bind(aMetaData: Firebird.IMessageMetadata);
692 var i: integer;
693 begin
694 FMetaData := aMetaData;
695 with Firebird30ClientAPI do
696 begin
697 Count := metadata.getCount(StatusIntf);
698 Check4DataBaseError;
699 Initialize;
700
701 for i := 0 to Count - 1 do
702 with TIBXSQLVar(Column[i]) do
703 begin
704 FSQLType := aMetaData.getType(StatusIntf,i);
705 Check4DataBaseError;
706 if FSQLType = SQL_BLOB then
707 begin
708 FSQLSubType := aMetaData.getSubType(StatusIntf,i);
709 Check4DataBaseError;
710 end
711 else
712 FSQLSubType := 0;
713 FDataLength := aMetaData.getLength(StatusIntf,i);
714 Check4DataBaseError;
715 case SQLType of
716 SQL_TEXT, SQL_TYPE_DATE, SQL_TYPE_TIME, SQL_TIMESTAMP,
717 SQL_BLOB, SQL_ARRAY, SQL_QUAD, SQL_SHORT, SQL_BOOLEAN,
718 SQL_LONG, SQL_INT64, SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
719 begin
720 if (FDataLength = 0) then
721 { Make sure you get a valid pointer anyway
722 select '' from foo }
723 IBAlloc(FSQLData, 0, 1)
724 else
725 IBAlloc(FSQLData, 0, FDataLength)
726 end;
727 SQL_VARYING:
728 IBAlloc(FSQLData, 0, FDataLength + 2);
729 else
730 IBError(ibxeUnknownSQLDataType, [sqltype and (not 1)])
731 end;
732 FNullable := aMetaData.isNullable(StatusIntf,i);
733 FOwnsSQLData := true;
734 Check4DataBaseError;
735 FNullIndicator := -1;
736 if FNullable then
737 FSQLNullIndicator := @FNullIndicator
738 else
739 FSQLNullIndicator := nil;
740 FScale := aMetaData.getScale(StatusIntf,i);
741 Check4DataBaseError;
742 FCharSetID := aMetaData.getCharSet(StatusIntf,i) and $FF;
743 Check4DataBaseError;
744 end;
745 end;
746 end;
747
748 procedure TIBXINPUTSQLDA.Changed;
749 begin
750 inherited Changed;
751 FreeMessageBuffer;
752 end;
753
754 function TIBXINPUTSQLDA.IsInputDataArea: boolean;
755 begin
756 Result := true;
757 end;
758
759 { TIBXOUTPUTSQLDA }
760
761 procedure TIBXOUTPUTSQLDA.FreeXSQLDA;
762 begin
763 inherited FreeXSQLDA;
764 FreeMem(FMessageBuffer);
765 FMessageBuffer := nil;
766 FMsgLength := 0;
767 end;
768
769 procedure TIBXOUTPUTSQLDA.Bind(aMetaData: Firebird.IMessageMetadata);
770 var i: integer;
771 begin
772 FMetaData := aMetaData;
773 with Firebird30ClientAPI do
774 begin
775 Count := metadata.getCount(StatusIntf);
776 Check4DataBaseError;
777 Initialize;
778
779 FMsgLength := metaData.getMessageLength(StatusIntf);
780 Check4DataBaseError;
781 IBAlloc(FMessageBuffer,0,FMsgLength);
782
783 for i := 0 to Count - 1 do
784 with TIBXSQLVar(Column[i]) do
785 begin
786 FSQLType := aMetaData.getType(StatusIntf,i);
787 Check4DataBaseError;
788 if FSQLType = SQL_BLOB then
789 begin
790 FSQLSubType := aMetaData.getSubType(StatusIntf,i);
791 Check4DataBaseError;
792 end
793 else
794 FSQLSubType := 0;
795 FBlob := nil;
796 FArray := nil;
797 FSQLData := FMessageBuffer + metaData.getOffset(StatusIntf,i);
798 Check4DataBaseError;
799 FDataLength := aMetaData.getLength(StatusIntf,i);
800 Check4DataBaseError;
801 FRelationName := strpas(aMetaData.getRelation(StatusIntf,i));
802 Check4DataBaseError;
803 FFieldName := strpas(aMetaData.getField(StatusIntf,i));
804 Check4DataBaseError;
805 FNullable := aMetaData.isNullable(StatusIntf,i);
806 Check4DataBaseError;
807 if FNullable then
808 begin
809 FSQLNullIndicator := PShort(FMessageBuffer + aMetaData.getNullOffset(StatusIntf,i));
810 Check4DataBaseError;
811 end
812 else
813 FSQLNullIndicator := nil;
814 FScale := aMetaData.getScale(StatusIntf,i);
815 Check4DataBaseError;
816 FCharSetID := aMetaData.getCharSet(StatusIntf,i) and $FF;
817 Check4DataBaseError;
818 end;
819 end;
820 SetUniqueRelationName;
821 end;
822
823 procedure TIBXOUTPUTSQLDA.GetData(index: integer; var aIsNull: boolean;
824 var len: short; var data: PByte);
825 begin
826 with TIBXSQLVAR(Column[index]) do
827 begin
828 aIsNull := FNullable and (FSQLNullIndicator^ = -1);
829 data := FSQLData;
830 len := FDataLength;
831 if not IsNull and (FSQLType = SQL_VARYING) then
832 begin
833 with Firebird30ClientAPI do
834 len := DecodeInteger(data,2);
835 Inc(Data,2);
836 end;
837 end;
838 end;
839
840 function TIBXOUTPUTSQLDA.IsInputDataArea: boolean;
841 begin
842 Result := false;
843 end;
844
845 { TIBXSQLDA }
846 constructor TIBXSQLDA.Create(aStatement: TFB30Statement);
847 begin
848 inherited Create;
849 FStatement := aStatement;
850 FSize := 0;
851 // writeln('Creating ',ClassName);
852 end;
853
854 destructor TIBXSQLDA.Destroy;
855 begin
856 FreeXSQLDA;
857 // writeln('Destroying ',ClassName);
858 inherited Destroy;
859 end;
860
861 procedure TIBXSQLDA.Changed;
862 begin
863
864 end;
865
866 function TIBXSQLDA.CheckStatementStatus(Request: TStatementStatus): boolean;
867 begin
868 Result := false;
869 case Request of
870 ssPrepared:
871 Result := FStatement.IsPrepared;
872
873 ssExecuteResults:
874 Result :=FStatement.FSingleResults;
875
876 ssCursorOpen:
877 Result := FStatement.FOpen;
878
879 ssBOF:
880 Result := FStatement.FBOF;
881
882 ssEOF:
883 Result := FStatement.FEOF;
884 end;
885 end;
886
887 function TIBXSQLDA.ColumnsInUseCount: integer;
888 begin
889 Result := FCount;
890 end;
891
892 function TIBXSQLDA.GetTransaction: TFB30Transaction;
893 begin
894 Result := FStatement.GetTransaction as TFB30Transaction;
895 end;
896
897 procedure TIBXSQLDA.Initialize;
898 begin
899 if FMetaData <> nil then
900 inherited Initialize;
901 end;
902
903 function TIBXSQLDA.StateChanged(var ChangeSeqNo: integer): boolean;
904 begin
905 Result := FStatement.ChangeSeqNo <> ChangeSeqNo;
906 if Result then
907 ChangeSeqNo := FStatement.ChangeSeqNo;
908 end;
909
910 procedure TIBXSQLDA.SetCount(Value: Integer);
911 var
912 i: Integer;
913 begin
914 FCount := Value;
915 if FCount = 0 then
916 FUniqueRelationName := ''
917 else
918 begin
919 SetLength(FColumnList, FCount);
920 for i := FSize to FCount - 1 do
921 FColumnList[i] := TIBXSQLVAR.Create(self,i);
922 FSize := FCount;
923 end;
924 end;
925
926 function TIBXSQLDA.GetTransactionSeqNo: integer;
927 begin
928 Result := FTransactionSeqNo;
929 end;
930
931 procedure TIBXSQLDA.FreeXSQLDA;
932 var i: integer;
933 begin
934 if FMetaData <> nil then
935 FMetaData.release;
936 FMetaData := nil;
937 for i := 0 to Count - 1 do
938 TIBXSQLVAR(Column[i]).FreeSQLData;
939 for i := 0 to FSize - 1 do
940 TIBXSQLVAR(Column[i]).Free;
941 SetLength(FColumnList,0);
942 FSize := 0;
943 end;
944
945 function TIBXSQLDA.GetStatement: IStatement;
946 begin
947 Result := FStatement;
948 end;
949
950 function TIBXSQLDA.GetPrepareSeqNo: integer;
951 begin
952 Result := FStatement.FPrepareSeqNo;
953 end;
954
955 { TFB30Statement }
956
957 procedure TFB30Statement.CheckHandle;
958 begin
959 if FStatementIntf = nil then
960 IBError(ibxeInvalidStatementHandle,[nil]);
961 end;
962
963 procedure TFB30Statement.GetDSQLInfo(info_request: byte; buffer: ISQLInfoResults
964 );
965 begin
966 with Firebird30ClientAPI, buffer as TSQLInfoResultsBuffer do
967 begin
968 StatementIntf.getInfo(StatusIntf,1,BytePtr(@info_request),
969 GetBufSize, BytePtr(Buffer));
970 Check4DataBaseError;
971 end;
972 end;
973
974 procedure TFB30Statement.InternalPrepare;
975 begin
976 if FPrepared then
977 Exit;
978 if (FSQL = '') then
979 IBError(ibxeEmptyQuery, [nil]);
980 try
981 CheckTransaction(FTransactionIntf);
982 with Firebird30ClientAPI do
983 begin
984 if FHasParamNames then
985 begin
986 if FProcessedSQL = '' then
987 FSQLParams.PreprocessSQL(FSQL,FGenerateParamNames,FProcessedSQL);
988 FStatementIntf := (GetAttachment as TFB30Attachment).AttachmentIntf.prepare(StatusIntf,
989 (FTransactionIntf as TFB30Transaction).TransactionIntf,
990 Length(FProcessedSQL),
991 PAnsiChar(FProcessedSQL),
992 FSQLDialect,
993 Firebird.IStatement.PREPARE_PREFETCH_METADATA);
994 end
995 else
996 FStatementIntf := (GetAttachment as TFB30Attachment).AttachmentIntf.prepare(StatusIntf,
997 (FTransactionIntf as TFB30Transaction).TransactionIntf,
998 Length(FSQL),
999 PAnsiChar(FSQL),
1000 FSQLDialect,
1001 Firebird.IStatement.PREPARE_PREFETCH_METADATA);
1002 Check4DataBaseError;
1003 FSQLStatementType := TIBSQLStatementTypes(FStatementIntf.getType(StatusIntf));
1004 Check4DataBaseError;
1005
1006 { Done getting the type }
1007 case FSQLStatementType of
1008 SQLGetSegment,
1009 SQLPutSegment,
1010 SQLStartTransaction:
1011 begin
1012 FreeHandle;
1013 IBError(ibxeNotPermitted, [nil]);
1014 end;
1015 SQLCommit,
1016 SQLRollback,
1017 SQLDDL, SQLSetGenerator,
1018 SQLInsert, SQLUpdate, SQLDelete, SQLSelect, SQLSelectForUpdate,
1019 SQLExecProcedure:
1020 begin
1021 {set up input sqlda}
1022 FSQLParams.Bind(FStatementIntf.getInputMetadata(StatusIntf));
1023 Check4DataBaseError;
1024
1025 {setup output sqlda}
1026 if FSQLStatementType in [SQLSelect, SQLSelectForUpdate,
1027 SQLExecProcedure] then
1028 FSQLRecord.Bind(FStatementIntf.getOutputMetadata(StatusIntf));
1029 Check4DataBaseError;
1030 end;
1031 end;
1032 end;
1033 except
1034 on E: Exception do begin
1035 if (FStatementIntf <> nil) then
1036 FreeHandle;
1037 if E is EIBInterBaseError then
1038 raise EIBInterBaseError.Create(EIBInterBaseError(E).SQLCode,
1039 EIBInterBaseError(E).IBErrorCode,
1040 EIBInterBaseError(E).Message +
1041 sSQLErrorSeparator + FSQL)
1042 else
1043 raise;
1044 end;
1045 end;
1046 FPrepared := true;
1047 FSingleResults := false;
1048 if RetainInterfaces then
1049 begin
1050 SetRetainInterfaces(false);
1051 SetRetainInterfaces(true);
1052 end;
1053 Inc(FPrepareSeqNo);
1054 with GetTransaction as TFB30Transaction do
1055 begin
1056 FSQLParams.FTransactionSeqNo := TransactionSeqNo;
1057 FSQLRecord.FTransactionSeqNo := TransactionSeqNo;
1058 end;
1059 SignalActivity;
1060 Inc(FChangeSeqNo);
1061 end;
1062
1063 function TFB30Statement.InternalExecute(aTransaction: ITransaction): IResults;
1064 begin
1065 Result := nil;
1066 FBOF := false;
1067 FEOF := false;
1068 FSingleResults := false;
1069 CheckTransaction(aTransaction);
1070 if not FPrepared then
1071 InternalPrepare;
1072 CheckHandle;
1073 if aTransaction <> FTransactionIntf then
1074 AddMonitor(aTransaction as TFB30Transaction);
1075 if (FSQLParams.FTransactionSeqNo < (FTransactionIntf as TFB30transaction).TransactionSeqNo) then
1076 IBError(ibxeInterfaceOutofDate,[nil]);
1077
1078 try
1079 with Firebird30ClientAPI do
1080 begin
1081 if FCollectStatistics then
1082 begin
1083 UtilIntf.getPerfCounters(StatusIntf,
1084 (GetAttachment as TFB30Attachment).AttachmentIntf,
1085 ISQL_COUNTERS,@FBeforeStats);
1086 Check4DataBaseError;
1087 end;
1088
1089 case FSQLStatementType of
1090 SQLSelect:
1091 IBError(ibxeIsAExecuteProcedure,[]);
1092
1093 SQLExecProcedure:
1094 begin
1095 FStatementIntf.execute(StatusIntf,
1096 (aTransaction as TFB30Transaction).TransactionIntf,
1097 FSQLParams.MetaData,
1098 FSQLParams.MessageBuffer,
1099 FSQLRecord.MetaData,
1100 FSQLRecord.MessageBuffer);
1101 Check4DataBaseError;
1102
1103 Result := TResults.Create(FSQLRecord);
1104 FSingleResults := true;
1105 end
1106 else
1107 FStatementIntf.execute(StatusIntf,
1108 (aTransaction as TFB30Transaction).TransactionIntf,
1109 FSQLParams.MetaData,
1110 FSQLParams.MessageBuffer,
1111 nil,
1112 nil);
1113 Check4DataBaseError;
1114 end;
1115 if FCollectStatistics then
1116 begin
1117 UtilIntf.getPerfCounters(StatusIntf,
1118 (GetAttachment as TFB30Attachment).AttachmentIntf,
1119 ISQL_COUNTERS, @FAfterStats);
1120 Check4DataBaseError;
1121 FStatisticsAvailable := true;
1122 end;
1123 end;
1124 finally
1125 if aTransaction <> FTransactionIntf then
1126 RemoveMonitor(aTransaction as TFB30Transaction);
1127 end;
1128 FExecTransactionIntf := aTransaction;
1129 SignalActivity;
1130 Inc(FChangeSeqNo);
1131 end;
1132
1133 function TFB30Statement.InternalOpenCursor(aTransaction: ITransaction
1134 ): IResultSet;
1135 begin
1136 if FSQLStatementType <> SQLSelect then
1137 IBError(ibxeIsASelectStatement,[]);
1138
1139 CheckTransaction(aTransaction);
1140 if not FPrepared then
1141 InternalPrepare;
1142 CheckHandle;
1143 if aTransaction <> FTransactionIntf then
1144 AddMonitor(aTransaction as TFB30Transaction);
1145 if (FSQLParams.FTransactionSeqNo < (FTransactionIntf as TFB30transaction).TransactionSeqNo) then
1146 IBError(ibxeInterfaceOutofDate,[nil]);
1147
1148 with Firebird30ClientAPI do
1149 begin
1150 if FCollectStatistics then
1151 begin
1152 UtilIntf.getPerfCounters(StatusIntf,
1153 (GetAttachment as TFB30Attachment).AttachmentIntf,
1154 ISQL_COUNTERS, @FBeforeStats);
1155 Check4DataBaseError;
1156 end;
1157
1158 FResultSet := FStatementIntf.openCursor(StatusIntf,
1159 (aTransaction as TFB30Transaction).TransactionIntf,
1160 FSQLParams.MetaData,
1161 FSQLParams.MessageBuffer,
1162 FSQLRecord.MetaData,
1163 0);
1164 Check4DataBaseError;
1165
1166 if FCollectStatistics then
1167 begin
1168 UtilIntf.getPerfCounters(StatusIntf,
1169 (GetAttachment as TFB30Attachment).AttachmentIntf,
1170 ISQL_COUNTERS,@FAfterStats);
1171 Check4DataBaseError;
1172 FStatisticsAvailable := true;
1173 end;
1174 end;
1175 Inc(FCursorSeqNo);
1176 FSingleResults := false;
1177 FOpen := True;
1178 FExecTransactionIntf := aTransaction;
1179 FBOF := true;
1180 FEOF := false;
1181 FSQLRecord.FTransaction := (aTransaction as TFB30Transaction);
1182 FSQLRecord.FTransactionSeqNo := FSQLRecord.FTransaction.TransactionSeqNo;
1183 Result := TResultSet.Create(FSQLRecord);
1184 SignalActivity;
1185 Inc(FChangeSeqNo);
1186 end;
1187
1188 procedure TFB30Statement.FreeHandle;
1189 begin
1190 Close;
1191 ReleaseInterfaces;
1192 if FStatementIntf <> nil then
1193 begin
1194 FStatementIntf.release;
1195 FStatementIntf := nil;
1196 FPrepared := false;
1197 end;
1198 end;
1199
1200 procedure TFB30Statement.InternalClose(Force: boolean);
1201 begin
1202 if (FStatementIntf <> nil) and (SQLStatementType = SQLSelect) and FOpen then
1203 try
1204 with Firebird30ClientAPI do
1205 begin
1206 if FResultSet <> nil then
1207 begin
1208 if FSQLRecord.FTransaction.InTransaction and
1209 (FSQLRecord.FTransactionSeqNo = FSQLRecord.FTransaction.TransactionSeqNo) then
1210 FResultSet.close(StatusIntf)
1211 else
1212 FResultSet.release;
1213 end;
1214 FResultSet := nil;
1215 if not Force then Check4DataBaseError;
1216 end;
1217 finally
1218 if (FSQLRecord.FTransaction <> nil) and (FSQLRecord.FTransaction <> (FTransactionIntf as TFB30Transaction)) then
1219 RemoveMonitor(FSQLRecord.FTransaction);
1220 FOpen := False;
1221 FExecTransactionIntf := nil;
1222 FSQLRecord.FTransaction := nil;
1223 end;
1224 SignalActivity;
1225 Inc(FChangeSeqNo);
1226 end;
1227
1228 constructor TFB30Statement.Create(Attachment: TFB30Attachment;
1229 Transaction: ITransaction; sql: AnsiString; aSQLDialect: integer);
1230 begin
1231 inherited Create(Attachment,Transaction,sql,aSQLDialect);
1232 FSQLParams := TIBXINPUTSQLDA.Create(self);
1233 FSQLRecord := TIBXOUTPUTSQLDA.Create(self);
1234 InternalPrepare;
1235 end;
1236
1237 constructor TFB30Statement.CreateWithParameterNames(
1238 Attachment: TFB30Attachment; Transaction: ITransaction; sql: AnsiString;
1239 aSQLDialect: integer; GenerateParamNames: boolean);
1240 begin
1241 inherited CreateWithParameterNames(Attachment,Transaction,sql,aSQLDialect,GenerateParamNames);
1242 FSQLParams := TIBXINPUTSQLDA.Create(self);
1243 FSQLRecord := TIBXOUTPUTSQLDA.Create(self);
1244 InternalPrepare;
1245 end;
1246
1247 destructor TFB30Statement.Destroy;
1248 begin
1249 inherited Destroy;
1250 if assigned(FSQLParams) then FSQLParams.Free;
1251 if assigned(FSQLRecord) then FSQLRecord.Free;
1252 end;
1253
1254 function TFB30Statement.FetchNext: boolean;
1255 var fetchResult: integer;
1256 begin
1257 result := false;
1258 if not FOpen then
1259 IBError(ibxeSQLClosed, [nil]);
1260 if FEOF then
1261 IBError(ibxeEOF,[nil]);
1262
1263 with Firebird30ClientAPI do
1264 begin
1265 { Go to the next record... }
1266 fetchResult := FResultSet.fetchNext(StatusIntf,FSQLRecord.MessageBuffer);
1267 if fetchResult = Firebird.IStatus.RESULT_NO_DATA then
1268 begin
1269 FBOF := false;
1270 FEOF := true;
1271 Exit; {End of File}
1272 end
1273 else
1274 if fetchResult <> Firebird.IStatus.RESULT_OK then
1275 begin
1276 try
1277 IBDataBaseError;
1278 except
1279 Close;
1280 raise;
1281 end;
1282 end
1283 else
1284 begin
1285 FBOF := false;
1286 result := true;
1287 end;
1288 end;
1289 FSQLRecord.RowChange;
1290 SignalActivity;
1291 if FEOF then
1292 Inc(FChangeSeqNo);
1293 end;
1294
1295 function TFB30Statement.GetSQLParams: ISQLParams;
1296 begin
1297 CheckHandle;
1298 if not HasInterface(0) then
1299 AddInterface(0,TSQLParams.Create(FSQLParams));
1300 Result := TSQLParams(GetInterface(0));
1301 end;
1302
1303 function TFB30Statement.GetMetaData: IMetaData;
1304 begin
1305 CheckHandle;
1306 if not HasInterface(1) then
1307 AddInterface(1, TMetaData.Create(FSQLRecord));
1308 Result := TMetaData(GetInterface(1));
1309 end;
1310
1311 function TFB30Statement.GetPlan: AnsiString;
1312 begin
1313 CheckHandle;
1314 if (not (FSQLStatementType in [SQLSelect, SQLSelectForUpdate,
1315 {TODO: SQLExecProcedure, }
1316 SQLUpdate, SQLDelete])) then
1317 result := ''
1318 else
1319 with Firebird30ClientAPI do
1320 begin
1321 Result := FStatementIntf.getPlan(StatusIntf,true);
1322 Check4DataBaseError;
1323 end;
1324 end;
1325
1326 function TFB30Statement.CreateBlob(column: TColumnMetaData): IBlob;
1327 begin
1328 if assigned(column) and (column.SQLType <> SQL_Blob) then
1329 IBError(ibxeNotABlob,[nil]);
1330 Result := TFB30Blob.Create(GetAttachment as TFB30Attachment,
1331 GetTransaction as TFB30Transaction,
1332 column.GetBlobMetaData,nil);
1333 end;
1334
1335 function TFB30Statement.CreateArray(column: TColumnMetaData): IArray;
1336 begin
1337 if assigned(column) and (column.SQLType <> SQL_ARRAY) then
1338 IBError(ibxeNotAnArray,[nil]);
1339 Result := TFB30Array.Create(GetAttachment as TFB30Attachment,
1340 GetTransaction as TFB30Transaction,
1341 column.GetArrayMetaData);
1342 end;
1343
1344 procedure TFB30Statement.SetRetainInterfaces(aValue: boolean);
1345 begin
1346 inherited SetRetainInterfaces(aValue);
1347 if HasInterface(1) then
1348 TMetaData(GetInterface(1)).RetainInterfaces := aValue;
1349 if HasInterface(0) then
1350 TSQLParams(GetInterface(0)).RetainInterfaces := aValue;
1351 end;
1352
1353 function TFB30Statement.IsPrepared: boolean;
1354 begin
1355 Result := FStatementIntf <> nil;
1356 end;
1357
1358 end.
1359