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

File Contents

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