ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/client/FBSQLData.pas
Revision: 263
Committed: Thu Dec 6 15:55:01 2018 UTC (5 years, 3 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/FBSQLData.pas
File size: 65390 byte(s)
Log Message:
Release 2.3.2 committed

File Contents

# Content
1 (*
2 * Firebird Interface (fbintf). The fbintf components provide a set of
3 * Pascal language bindings for the Firebird API. Although predominantly
4 * a new development they include source code taken from IBX and may be
5 * considered a derived product. This software thus also includes the copyright
6 * notice and license conditions from IBX.
7 *
8 * Except for those parts dervied from IBX, contents of this file are subject
9 * to the Initial Developer's Public License Version 1.0 (the "License"); you
10 * may not use this file except in compliance with the License. You may obtain a
11 * copy of the License here:
12 *
13 * http://www.firebirdsql.org/index.php?op=doc&id=idpl
14 *
15 * Software distributed under the License is distributed on an "AS
16 * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
17 * implied. See the License for the specific language governing rights
18 * and limitations under the License.
19 *
20 * The Initial Developer of the Original Code is Tony Whyman.
21 *
22 * The Original Code is (C) 2016 Tony Whyman, MWA Software
23 * (http://www.mwasoftware.co.uk).
24 *
25 * All Rights Reserved.
26 *
27 * Contributor(s): ______________________________________.
28 *
29 *)
30 {************************************************************************}
31 { }
32 { Borland Delphi Visual Component Library }
33 { InterBase Express core components }
34 { }
35 { Copyright (c) 1998-2000 Inprise Corporation }
36 { }
37 { InterBase Express is based in part on the product }
38 { Free IB Components, written by Gregory H. Deatz for }
39 { Hoagland, Longo, Moran, Dunst & Doukas Company. }
40 { Free IB Components is used under license. }
41 { }
42 { The contents of this file are subject to the InterBase }
43 { Public License Version 1.0 (the "License"); you may not }
44 { use this file except in compliance with the License. You }
45 { may obtain a copy of the License at http://www.Inprise.com/IPL.html }
46 { Software distributed under the License is distributed on }
47 { an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
48 { express or implied. See the License for the specific language }
49 { governing rights and limitations under the License. }
50 { The Original Code was created by InterBase Software Corporation }
51 { and its successors. }
52 { Portions created by Inprise Corporation are Copyright (C) Inprise }
53 { Corporation. All Rights Reserved. }
54 { Contributor(s): Jeff Overcash }
55 { }
56 { IBX For Lazarus (Firebird Express) }
57 { Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
58 { Portions created by MWA Software are copyright McCallum Whyman }
59 { Associates Ltd 2011 - 2015 }
60 { }
61 {************************************************************************}
62 unit FBSQLData;
63 {$IFDEF MSWINDOWS}
64 {$DEFINE WINDOWS}
65 {$ENDIF}
66
67 {$IFDEF FPC}
68 {$mode delphi}
69 {$codepage UTF8}
70 {$interfaces COM}
71 {$ENDIF}
72
73 { This Unit was hacked out of the IBSQL unit and defines a class used as the
74 base for interfaces accessing SQLDAVar data and Array Elements. The abstract
75 methods are used to customise for an SQLDAVar or Array Element. The empty
76 methods are needed for SQL parameters only. The string getters and setters
77 are virtual as SQLVar and Array encodings of string data is different.}
78
79 { Note on SQL Parameter Names
80 --------------------------------------------
81
82 IBX processes parameter names case insensitive. This does result in some additional
83 overhead due to a call to "AnsiUpperCase". This can be avoided by undefining
84 "UseCaseInSensitiveParamName" below.
85
86 }
87 {$define UseCaseInSensitiveParamName}
88
89 interface
90
91 uses
92 Classes, SysUtils, IBExternals, IBHeader, IB, FBActivityMonitor, FBClientAPI;
93
94 type
95
96 { TSQLDataItem }
97
98 TSQLDataItem = class(TFBInterfacedObject)
99 private
100 FFirebirdClientAPI: TFBClientAPI;
101 function AdjustScale(Value: Int64; aScale: Integer): Double;
102 function AdjustScaleToInt64(Value: Int64; aScale: Integer): Int64;
103 function AdjustScaleToCurrency(Value: Int64; aScale: Integer): Currency;
104 procedure SetAsInteger(AValue: Integer);
105 protected
106 function AdjustScaleFromCurrency(Value: Currency; aScale: Integer): Int64;
107 function AdjustScaleFromDouble(Value: Double; aScale: Integer): Int64;
108 procedure CheckActive; virtual;
109 function GetSQLDialect: integer; virtual; abstract;
110 procedure Changed; virtual;
111 procedure Changing; virtual;
112 procedure InternalSetAsString(Value: AnsiString); virtual;
113 function SQLData: PByte; virtual; abstract;
114 function GetDataLength: cardinal; virtual; abstract;
115 function GetCodePage: TSystemCodePage; virtual; abstract;
116 function getCharSetID: cardinal; virtual; abstract;
117 function Transliterate(s: AnsiString; CodePage: TSystemCodePage): RawByteString;
118 procedure SetScale(aValue: integer); virtual;
119 procedure SetDataLength(len: cardinal); virtual;
120 procedure SetSQLType(aValue: cardinal); virtual;
121 property DataLength: cardinal read GetDataLength write SetDataLength;
122
123 public
124 constructor Create(api: TFBClientAPI);
125 function GetSQLType: cardinal; virtual; abstract;
126 function GetSQLTypeName: AnsiString; overload;
127 class function GetSQLTypeName(SQLType: short): AnsiString; overload;
128 function GetName: AnsiString; virtual; abstract;
129 function GetScale: integer; virtual; abstract;
130 function GetAsBoolean: boolean;
131 function GetAsCurrency: Currency;
132 function GetAsInt64: Int64;
133 function GetAsDateTime: TDateTime;
134 function GetAsDouble: Double;
135 function GetAsFloat: Float;
136 function GetAsLong: Long;
137 function GetAsPointer: Pointer;
138 function GetAsQuad: TISC_QUAD;
139 function GetAsShort: short;
140 function GetAsString: AnsiString; virtual;
141 function GetIsNull: Boolean; virtual;
142 function GetIsNullable: boolean; virtual;
143 function GetAsVariant: Variant;
144 function GetModified: boolean; virtual;
145 procedure SetAsBoolean(AValue: boolean); virtual;
146 procedure SetAsCurrency(Value: Currency); virtual;
147 procedure SetAsInt64(Value: Int64); virtual;
148 procedure SetAsDate(Value: TDateTime); virtual;
149 procedure SetAsLong(Value: Long); virtual;
150 procedure SetAsTime(Value: TDateTime); virtual;
151 procedure SetAsDateTime(Value: TDateTime);
152 procedure SetAsDouble(Value: Double); virtual;
153 procedure SetAsFloat(Value: Float); virtual;
154 procedure SetAsPointer(Value: Pointer);
155 procedure SetAsQuad(Value: TISC_QUAD);
156 procedure SetAsShort(Value: short); virtual;
157 procedure SetAsString(Value: AnsiString); virtual;
158 procedure SetAsVariant(Value: Variant);
159 procedure SetAsNumeric(Value: Int64; aScale: integer);
160 procedure SetIsNull(Value: Boolean); virtual;
161 procedure SetIsNullable(Value: Boolean); virtual;
162 procedure SetName(aValue: AnsiString); virtual;
163 property AsDate: TDateTime read GetAsDateTime write SetAsDate;
164 property AsBoolean:boolean read GetAsBoolean write SetAsBoolean;
165 property AsTime: TDateTime read GetAsDateTime write SetAsTime;
166 property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
167 property AsDouble: Double read GetAsDouble write SetAsDouble;
168 property AsFloat: Float read GetAsFloat write SetAsFloat;
169 property AsCurrency: Currency read GetAsCurrency write SetAsCurrency;
170 property AsInt64: Int64 read GetAsInt64 write SetAsInt64;
171 property AsInteger: Integer read GetAsLong write SetAsInteger;
172 property AsLong: Long read GetAsLong write SetAsLong;
173 property AsPointer: Pointer read GetAsPointer write SetAsPointer;
174 property AsQuad: TISC_QUAD read GetAsQuad write SetAsQuad;
175 property AsShort: short read GetAsShort write SetAsShort;
176 property AsString: AnsiString read GetAsString write SetAsString;
177 property AsVariant: Variant read GetAsVariant write SetAsVariant;
178 property Modified: Boolean read getModified;
179 property IsNull: Boolean read GetIsNull write SetIsNull;
180 property IsNullable: Boolean read GetIsNullable write SetIsNullable;
181 property Scale: integer read GetScale write SetScale;
182 property SQLType: cardinal read GetSQLType write SetSQLType;
183 end;
184
185 TSQLVarData = class;
186
187 TStatementStatus = (ssPrepared, ssExecuteResults, ssCursorOpen, ssBOF, ssEOF);
188
189 { TSQLDataArea }
190
191 TSQLDataArea = class
192 private
193 function GetColumn(index: integer): TSQLVarData;
194 function GetCount: integer;
195 protected
196 FUniqueRelationName: AnsiString;
197 FColumnList: array of TSQLVarData;
198 function GetStatement: IStatement; virtual; abstract;
199 function GetPrepareSeqNo: integer; virtual; abstract;
200 function GetTransactionSeqNo: integer; virtual; abstract;
201 procedure SetCount(aValue: integer); virtual; abstract;
202 procedure SetUniqueRelationName;
203 public
204 procedure Initialize; virtual;
205 function IsInputDataArea: boolean; virtual; abstract; {Input to Database}
206 procedure PreprocessSQL(sSQL: AnsiString; GenerateParamNames: boolean;
207 var sProcessedSQL: AnsiString);
208 function ColumnsInUseCount: integer; virtual;
209 function ColumnByName(Idx: AnsiString): TSQLVarData;
210 function CheckStatementStatus(Request: TStatementStatus): boolean; virtual; abstract;
211 procedure GetData(index: integer; var IsNull: boolean; var len: short;
212 var data: PByte); virtual;
213 procedure RowChange;
214 function StateChanged(var ChangeSeqNo: integer): boolean; virtual; abstract;
215 property Count: integer read GetCount;
216 property Column[index: integer]: TSQLVarData read GetColumn;
217 property UniqueRelationName: AnsiString read FUniqueRelationName;
218 property Statement: IStatement read GetStatement;
219 property PrepareSeqNo: integer read GetPrepareSeqNo;
220 property TransactionSeqNo: integer read GetTransactionSeqNo;
221 end;
222
223 { TSQLVarData }
224
225 TSQLVarData = class
226 private
227 FParent: TSQLDataArea;
228 FName: AnsiString;
229 FIndex: integer;
230 FModified: boolean;
231 FUniqueName: boolean;
232 FVarString: RawByteString;
233 function GetStatement: IStatement;
234 procedure SetName(AValue: AnsiString);
235 protected
236 function GetSQLType: cardinal; virtual; abstract;
237 function GetSubtype: integer; virtual; abstract;
238 function GetAliasName: AnsiString; virtual; abstract;
239 function GetFieldName: AnsiString; virtual; abstract;
240 function GetOwnerName: AnsiString; virtual; abstract;
241 function GetRelationName: AnsiString; virtual; abstract;
242 function GetScale: integer; virtual; abstract;
243 function GetCharSetID: cardinal; virtual; abstract;
244 function GetCodePage: TSystemCodePage; virtual; abstract;
245 function GetIsNull: Boolean; virtual; abstract;
246 function GetIsNullable: boolean; virtual; abstract;
247 function GetSQLData: PByte; virtual; abstract;
248 function GetDataLength: cardinal; virtual; abstract;
249 procedure SetIsNull(Value: Boolean); virtual; abstract;
250 procedure SetIsNullable(Value: Boolean); virtual; abstract;
251 procedure SetSQLData(AValue: PByte; len: cardinal); virtual; abstract;
252 procedure SetScale(aValue: integer); virtual; abstract;
253 procedure SetDataLength(len: cardinal); virtual; abstract;
254 procedure SetSQLType(aValue: cardinal); virtual; abstract;
255 procedure SetCharSetID(aValue: cardinal); virtual; abstract;
256 public
257 constructor Create(aParent: TSQLDataArea; aIndex: integer);
258 procedure SetString(aValue: AnsiString);
259 procedure Changed; virtual;
260 procedure RowChange; virtual;
261 function GetAsArray(Array_ID: TISC_QUAD): IArray; virtual; abstract;
262 function GetAsBlob(Blob_ID: TISC_QUAD; BPB: IBPB): IBlob; virtual; abstract;
263 function CreateBlob: IBlob; virtual; abstract;
264 function GetArrayMetaData: IArrayMetaData; virtual; abstract;
265 function GetBlobMetaData: IBlobMetaData; virtual; abstract;
266 procedure Initialize; virtual;
267
268 public
269 property AliasName: AnsiString read GetAliasName;
270 property FieldName: AnsiString read GetFieldName;
271 property OwnerName: AnsiString read GetOwnerName;
272 property RelationName: AnsiString read GetRelationName;
273 property Parent: TSQLDataArea read FParent;
274 property Index: integer read FIndex;
275 property Name: AnsiString read FName write SetName;
276 property CharSetID: cardinal read GetCharSetID write SetCharSetID;
277 property SQLType: cardinal read GetSQLType write SetSQLType;
278 property SQLSubtype: integer read GetSubtype;
279 property SQLData: PByte read GetSQLData;
280 property DataLength: cardinal read GetDataLength write SetDataLength;
281 property IsNull: Boolean read GetIsNull write SetIsNull;
282 property IsNullable: Boolean read GetIsNullable write SetIsNullable;
283 property Scale: integer read GetScale write SetScale;
284 public
285 property Modified: Boolean read FModified;
286 property Statement: IStatement read GetStatement;
287 property UniqueName: boolean read FUniqueName write FUniqueName;
288 end;
289
290 { TColumnMetaData }
291
292 TColumnMetaData = class(TSQLDataItem,IColumnMetaData)
293 private
294 FIBXSQLVAR: TSQLVarData;
295 FOwner: IUnknown; {Keep reference to ensure Metadata/statement not discarded}
296 FPrepareSeqNo: integer;
297 FStatement: IStatement;
298 FChangeSeqNo: integer;
299 protected
300 procedure CheckActive; override;
301 function SQLData: PByte; override;
302 function GetDataLength: cardinal; override;
303 function GetCodePage: TSystemCodePage; override;
304
305 public
306 constructor Create(aOwner: IUnknown; aIBXSQLVAR: TSQLVarData);
307 destructor Destroy; override;
308 function GetSQLDialect: integer; override;
309 property Statement: IStatement read FStatement;
310
311 public
312 {IColumnMetaData}
313 function GetIndex: integer;
314 function GetSQLType: cardinal; override;
315 function getSubtype: integer;
316 function getRelationName: AnsiString;
317 function getOwnerName: AnsiString;
318 function getSQLName: AnsiString; {Name of the column}
319 function getAliasName: AnsiString; {Alias Name of column or Column Name if not alias}
320 function GetName: AnsiString; override; {Disambiguated uppercase Field Name}
321 function GetScale: integer; override;
322 function getCharSetID: cardinal; override;
323 function GetIsNullable: boolean; override;
324 function GetSize: cardinal;
325 function GetArrayMetaData: IArrayMetaData;
326 function GetBlobMetaData: IBlobMetaData;
327 property Name: AnsiString read GetName;
328 property Size: cardinal read GetSize;
329 property CharSetID: cardinal read getCharSetID;
330 property SQLSubtype: integer read getSubtype;
331 property IsNullable: Boolean read GetIsNullable;
332 end;
333
334 { TIBSQLData }
335
336 TIBSQLData = class(TColumnMetaData,ISQLData)
337 protected
338 procedure CheckActive; override;
339 public
340 function GetIsNull: Boolean; override;
341 function GetAsArray: IArray;
342 function GetAsBlob: IBlob; overload;
343 function GetAsBlob(BPB: IBPB): IBlob; overload;
344 function GetAsString: AnsiString; override;
345 property AsBlob: IBlob read GetAsBlob;
346 end;
347
348 { TSQLParam }
349
350 TSQLParam = class(TIBSQLData,ISQLParam)
351 protected
352 procedure CheckActive; override;
353 procedure Changed; override;
354 procedure InternalSetAsString(Value: AnsiString); override;
355 procedure SetScale(aValue: integer); override;
356 procedure SetDataLength(len: cardinal); override;
357 procedure SetSQLType(aValue: cardinal); override;
358 public
359 procedure Clear;
360 function GetModified: boolean; override;
361 function GetAsPointer: Pointer;
362 procedure SetName(Value: AnsiString); override;
363 procedure SetIsNull(Value: Boolean); override;
364 procedure SetIsNullable(Value: Boolean); override;
365 procedure SetAsArray(anArray: IArray);
366
367 {overrides}
368 procedure SetAsBoolean(AValue: boolean);
369 procedure SetAsCurrency(AValue: Currency);
370 procedure SetAsInt64(AValue: Int64);
371 procedure SetAsDate(AValue: TDateTime);
372 procedure SetAsLong(AValue: Long);
373 procedure SetAsTime(AValue: TDateTime);
374 procedure SetAsDateTime(AValue: TDateTime);
375 procedure SetAsDouble(AValue: Double);
376 procedure SetAsFloat(AValue: Float);
377 procedure SetAsPointer(AValue: Pointer);
378 procedure SetAsShort(AValue: Short);
379 procedure SetAsString(AValue: AnsiString); override;
380 procedure SetAsVariant(AValue: Variant);
381 procedure SetAsBlob(aValue: IBlob);
382 procedure SetAsQuad(AValue: TISC_QUAD);
383 procedure SetCharSetID(aValue: cardinal);
384
385 property AsBlob: IBlob read GetAsBlob write SetAsBlob;
386 property IsNullable: Boolean read GetIsNullable write SetIsNullable;
387 end;
388
389 { TMetaData }
390
391 TMetaData = class(TInterfaceOwner,IMetaData)
392 private
393 FPrepareSeqNo: integer;
394 FMetaData: TSQLDataArea;
395 FStatement: IStatement; {ensure FStatement not destroyed until no longer needed}
396 procedure CheckActive;
397 public
398 constructor Create(aMetaData: TSQLDataArea);
399 destructor Destroy; override;
400 public
401 {IMetaData}
402 function GetUniqueRelationName: AnsiString;
403 function getCount: integer;
404 function getColumnMetaData(index: integer): IColumnMetaData;
405 function ByName(Idx: AnsiString): IColumnMetaData;
406 end;
407
408 { TSQLParams }
409
410 TSQLParams = class(TInterfaceOwner,ISQLParams)
411 private
412 FPrepareSeqNo: integer;
413 FChangeSeqNo: integer;
414 FSQLParams: TSQLDataArea;
415 FStatement: IStatement; {ensure FStatement not destroyed until no longer needed}
416 procedure CheckActive;
417 public
418 constructor Create(aSQLParams: TSQLDataArea);
419 destructor Destroy; override;
420 public
421 {ISQLParams}
422 function getCount: integer;
423 function getSQLParam(index: integer): ISQLParam;
424 function ByName(Idx: AnsiString): ISQLParam ;
425 function GetModified: Boolean;
426 end;
427
428 { TResults }
429
430 TResults = class(TInterfaceOwner,IResults)
431 private
432 FPrepareSeqNo: integer;
433 FTransactionSeqNo: integer;
434 FChangeSeqNo: integer;
435 FResults: TSQLDataArea;
436 FStatement: IStatement; {ensure FStatement not destroyed until no longer needed}
437 function GetISQLData(aIBXSQLVAR: TSQLVarData): ISQLData;
438 protected
439 procedure CheckActive;
440 public
441 constructor Create(aResults: TSQLDataArea);
442 {IResults}
443 function getCount: integer;
444 function ByName(Idx: AnsiString): ISQLData;
445 function getSQLData(index: integer): ISQLData;
446 procedure GetData(index: integer; var IsNull:boolean; var len: short; var data: PByte);
447 function GetTransaction: ITransaction; virtual;
448 procedure SetRetainInterfaces(aValue: boolean);
449 end;
450
451 implementation
452
453 uses FBMessages, variants, IBUtils, FBTransaction;
454
455 type
456
457 { TSQLParamProcessor }
458
459 TSQLParamProcessor = class(TSQLwithNamedParamsTokeniser)
460 private
461 const
462 sIBXParam = 'IBXParam'; {do not localize}
463 private
464 FInString: AnsiString;
465 FIndex: integer;
466 function DoExecute(GenerateParamNames: boolean;
467 var slNames: TStrings): AnsiString;
468 protected
469 function GetChar: AnsiChar; override;
470 public
471 class function Execute(sSQL: AnsiString; GenerateParamNames: boolean;
472 var slNames: TStrings): AnsiString;
473 end;
474
475 { TSQLParamProcessor }
476
477 function TSQLParamProcessor.DoExecute(GenerateParamNames: boolean;
478 var slNames: TStrings): AnsiString;
479 var token: TSQLTokens;
480 iParamSuffix: Integer;
481 begin
482 Result := '';
483 iParamSuffix := 0;
484
485 while not EOF do
486 begin
487 token := GetNextToken;
488 case token of
489 sqltParam,
490 sqltQuotedParam:
491 begin
492 Result := Result + '?';
493 slNames.Add(TokenText);
494 end;
495
496 sqltPlaceHolder:
497 if GenerateParamNames then
498 begin
499 Inc(iParamSuffix);
500 slNames.AddObject(sIBXParam + IntToStr(iParamSuffix),self); //Note local convention
501 //add pointer to self to mark entry
502 Result := Result + '?';
503 end
504 else
505 IBError(ibxeSQLParseError, [SParamNameExpected]);
506
507 sqltQuotedString:
508 Result := Result + '''' + SQLSafeString(TokenText) + '''';
509
510 sqltIdentifierInDoubleQuotes:
511 Result := Result + '"' + StringReplace(TokenText,'"','""',[rfReplaceAll]) + '"';
512
513 sqltComment:
514 Result := Result + '/*' + TokenText + '*/';
515
516 sqltCommentLine:
517 Result := Result + '//' + TokenText + LineEnding;
518
519 sqltEOL:
520 Result := Result + LineEnding;
521
522 else
523 Result := Result + TokenText;
524 end;
525 end;
526 end;
527
528 function TSQLParamProcessor.GetChar: AnsiChar;
529 begin
530 if FIndex <= Length(FInString) then
531 begin
532 Result := FInString[FIndex];
533 Inc(FIndex);
534 end
535 else
536 Result := #0;
537 end;
538
539 class function TSQLParamProcessor.Execute(sSQL: AnsiString;
540 GenerateParamNames: boolean; var slNames: TStrings): AnsiString;
541 begin
542 with self.Create do
543 try
544 FInString := sSQL;
545 FIndex := 1;
546 Result := DoExecute(GenerateParamNames,slNames);
547 finally
548 Free;
549 end;
550 end;
551
552
553 { TSQLDataArea }
554
555 function TSQLDataArea.GetColumn(index: integer): TSQLVarData;
556 begin
557 if (index < 0) or (index >= Count) then
558 IBError(ibxeInvalidColumnIndex,[nil]);
559 Result := FColumnList[index];
560 end;
561
562 function TSQLDataArea.GetCount: integer;
563 begin
564 Result := Length(FColumnList);
565 end;
566
567 procedure TSQLDataArea.SetUniqueRelationName;
568 var
569 i: Integer;
570 bUnique: Boolean;
571 RelationName: AnsiString;
572 begin
573 bUnique := True;
574 for i := 0 to ColumnsInUseCount - 1 do
575 begin
576 RelationName := Column[i].RelationName;
577
578 {First get the unique relation name, if any}
579
580 if bUnique and (RelationName <> '') then
581 begin
582 if FUniqueRelationName = '' then
583 FUniqueRelationName := RelationName
584 else
585 if RelationName <> FUniqueRelationName then
586 begin
587 FUniqueRelationName := '';
588 bUnique := False;
589 end;
590 end;
591 end;
592 end;
593
594 procedure TSQLDataArea.Initialize;
595 var
596 i: Integer;
597 begin
598 for i := 0 to ColumnsInUseCount - 1 do
599 Column[i].Initialize;
600 end;
601
602 procedure TSQLDataArea.PreprocessSQL(sSQL: AnsiString; GenerateParamNames: boolean;
603 var sProcessedSQL: AnsiString);
604
605 var slNames: TStrings;
606
607 procedure SetColumnNames(slNames: TStrings);
608 var i, j: integer;
609 found: boolean;
610 begin
611 found := false;
612 SetCount(slNames.Count);
613 for i := 0 to slNames.Count - 1 do
614 begin
615 Column[i].Name := slNames[i];
616 Column[i].UniqueName := (slNames.Objects[i] <> nil);
617 end;
618 for i := 0 to Count - 1 do
619 begin
620 if not Column[i].UniqueName then
621 begin
622 found := false;
623 for j := i + 1 to Count - 1 do
624 if Column[i].Name = Column[j].Name then
625 begin
626 found := true;
627 break;
628 end;
629 Column[i].UniqueName := not found;
630 end;
631 end;
632 end;
633
634 begin
635 if not IsInputDataArea then
636 IBError(ibxeNotPermitted,[nil]);
637
638 slNames := TStringList.Create;
639 try
640 sProcessedSQL := TSQLParamProcessor.Execute(sSQL,GenerateParamNames,slNames);
641 SetColumnNames(slNames);
642 finally
643 slNames.Free;
644 end;
645 end;
646
647 function TSQLDataArea.ColumnsInUseCount: integer;
648 begin
649 Result := Count;
650 end;
651
652 function TSQLDataArea.ColumnByName(Idx: AnsiString): TSQLVarData;
653 var
654 s: AnsiString;
655 i: Integer;
656 begin
657 {$ifdef UseCaseInSensitiveParamName}
658 s := AnsiUpperCase(Idx);
659 {$else}
660 s := Idx;
661 {$endif}
662 for i := 0 to Count - 1 do
663 if Column[i].Name = s then
664 begin
665 Result := Column[i];
666 Exit;
667 end;
668 Result := nil;
669 end;
670
671 procedure TSQLDataArea.GetData(index: integer; var IsNull: boolean;
672 var len: short; var data: PByte);
673 begin
674 //Do Nothing
675 end;
676
677 procedure TSQLDataArea.RowChange;
678 var i: integer;
679 begin
680 for i := 0 to Count - 1 do
681 Column[i].RowChange;
682 end;
683
684 {TSQLVarData}
685
686 function TSQLVarData.GetStatement: IStatement;
687 begin
688 Result := FParent.Statement;
689 end;
690
691 procedure TSQLVarData.SetName(AValue: AnsiString);
692 begin
693 if FName = AValue then Exit;
694 {$ifdef UseCaseInSensitiveParamName}
695 if Parent.IsInputDataArea then
696 FName := AnsiUpperCase(AValue)
697 else
698 {$endif}
699 FName := AValue;
700 end;
701
702 constructor TSQLVarData.Create(aParent: TSQLDataArea; aIndex: integer);
703 begin
704 inherited Create;
705 FParent := aParent;
706 FIndex := aIndex;
707 FUniqueName := true;
708 end;
709
710 procedure TSQLVarData.SetString(aValue: AnsiString);
711 begin
712 {we take full advantage here of reference counted strings. When setting a string
713 value, a reference is kept in FVarString and a pointer to it placed in the
714 SQLVar. This avoids string copies. Note that PAnsiChar is guaranteed to point to
715 a zero byte when the string is empty, neatly avoiding a nil pointer error.}
716
717 FVarString := aValue;
718 SQLType := SQL_TEXT;
719 SetSQLData(PByte(PAnsiChar(FVarString)),Length(aValue));
720 end;
721
722 procedure TSQLVarData.Changed;
723 begin
724 FModified := true;
725 end;
726
727 procedure TSQLVarData.RowChange;
728 begin
729 FModified := false;
730 FVarString := '';
731 end;
732
733 procedure TSQLVarData.Initialize;
734
735 function FindVarByName(idx: AnsiString; limit: integer): TSQLVarData;
736 var
737 k: integer;
738 begin
739 for k := 0 to limit do
740 if Parent.Column[k].Name = idx then
741 begin
742 Result := Parent.Column[k];
743 Exit;
744 end;
745 Result := nil;
746 end;
747
748 var
749 j, j_len: Integer;
750 st: AnsiString;
751 sBaseName: AnsiString;
752 begin
753 RowChange;
754
755 {If an output SQLDA then copy the aliasname to the FName. Ensure
756 that they are all upper case only and disambiguated.
757 }
758
759 if not Parent.IsInputDataArea then
760 begin
761 st := Space2Underscore(AnsiUppercase(AliasName));
762 if st = '' then
763 begin
764 sBaseName := 'F_'; {do not localize}
765 j := 1; j_len := 1;
766 st := sBaseName + IntToStr(j);
767 end
768 else
769 begin
770 j := 0; j_len := 0;
771 sBaseName := st;
772 end;
773
774 {Look for other columns with the same name and make unique}
775
776 while FindVarByName(st,Index-1) <> nil do
777 begin
778 Inc(j);
779 j_len := Length(IntToStr(j));
780 if j_len + Length(sBaseName) > 31 then
781 st := system.Copy(sBaseName, 1, 31 - j_len) + IntToStr(j)
782 else
783 st := sBaseName + IntToStr(j);
784 end;
785
786 Name := st;
787 end;
788 end;
789
790 {TSQLDataItem}
791
792 function TSQLDataItem.AdjustScale(Value: Int64; aScale: Integer): Double;
793 var
794 Scaling : Int64;
795 i: Integer;
796 Val: Double;
797 begin
798 Scaling := 1; Val := Value;
799 if aScale > 0 then
800 begin
801 for i := 1 to aScale do
802 Scaling := Scaling * 10;
803 result := Val * Scaling;
804 end
805 else
806 if aScale < 0 then
807 begin
808 for i := -1 downto aScale do
809 Scaling := Scaling * 10;
810 result := Val / Scaling;
811 end
812 else
813 result := Val;
814 end;
815
816 function TSQLDataItem.AdjustScaleToInt64(Value: Int64; aScale: Integer): Int64;
817 var
818 Scaling : Int64;
819 i: Integer;
820 Val: Int64;
821 begin
822 Scaling := 1; Val := Value;
823 if aScale > 0 then begin
824 for i := 1 to aScale do Scaling := Scaling * 10;
825 result := Val * Scaling;
826 end else if aScale < 0 then begin
827 for i := -1 downto aScale do Scaling := Scaling * 10;
828 result := Val div Scaling;
829 end else
830 result := Val;
831 end;
832
833 function TSQLDataItem.AdjustScaleToCurrency(Value: Int64; aScale: Integer
834 ): Currency;
835 var
836 Scaling : Int64;
837 i : Integer;
838 FractionText, PadText, CurrText: AnsiString;
839 begin
840 Result := 0;
841 Scaling := 1;
842 PadText := '';
843 if aScale > 0 then
844 begin
845 for i := 1 to aScale do
846 Scaling := Scaling * 10;
847 result := Value * Scaling;
848 end
849 else
850 if aScale < 0 then
851 begin
852 for i := -1 downto aScale do
853 Scaling := Scaling * 10;
854 FractionText := IntToStr(abs(Value mod Scaling));
855 for i := Length(FractionText) to -aScale -1 do
856 PadText := '0' + PadText;
857 {$IF declared(DefaultFormatSettings)}
858 with DefaultFormatSettings do
859 {$ELSE}
860 {$IF declared(FormatSettings)}
861 with FormatSettings do
862 {$IFEND}
863 {$IFEND}
864 if Value < 0 then
865 CurrText := '-' + IntToStr(Abs(Value div Scaling)) + DecimalSeparator + PadText + FractionText
866 else
867 CurrText := IntToStr(Abs(Value div Scaling)) + DecimalSeparator + PadText + FractionText;
868 try
869 result := StrToCurr(CurrText);
870 except
871 on E: Exception do
872 IBError(ibxeInvalidDataConversion, [nil]);
873 end;
874 end
875 else
876 result := Value;
877 end;
878
879 procedure TSQLDataItem.SetAsInteger(AValue: Integer);
880 begin
881 SetAsLong(aValue);
882 end;
883
884 function TSQLDataItem.AdjustScaleFromCurrency(Value: Currency; aScale: Integer
885 ): Int64;
886 var
887 Scaling : Int64;
888 i : Integer;
889 begin
890 Result := 0;
891 Scaling := 1;
892 if aScale < 0 then
893 begin
894 for i := -1 downto aScale do
895 Scaling := Scaling * 10;
896 result := trunc(Value * Scaling);
897 end
898 else
899 if aScale > 0 then
900 begin
901 for i := 1 to aScale do
902 Scaling := Scaling * 10;
903 result := trunc(Value / Scaling);
904 end
905 else
906 result := trunc(Value);
907 end;
908
909 function TSQLDataItem.AdjustScaleFromDouble(Value: Double; aScale: Integer
910 ): Int64;
911 var
912 Scaling : Int64;
913 i : Integer;
914 begin
915 Result := 0;
916 Scaling := 1;
917 if aScale < 0 then
918 begin
919 for i := -1 downto aScale do
920 Scaling := Scaling * 10;
921 result := trunc(Value * Scaling);
922 end
923 else
924 if aScale > 0 then
925 begin
926 for i := 1 to aScale do
927 Scaling := Scaling * 10;
928 result := trunc(Value / Scaling);
929 end
930 else
931 result := trunc(Value);
932 end;
933
934 procedure TSQLDataItem.CheckActive;
935 begin
936 //Do nothing by default
937 end;
938
939 procedure TSQLDataItem.Changed;
940 begin
941 //Do nothing by default
942 end;
943
944 procedure TSQLDataItem.Changing;
945 begin
946 //Do nothing by default
947 end;
948
949 procedure TSQLDataItem.InternalSetAsString(Value: AnsiString);
950 begin
951 //Do nothing by default
952 end;
953
954 function TSQLDataItem.Transliterate(s: AnsiString; CodePage: TSystemCodePage
955 ): RawByteString;
956 begin
957 Result := s;
958 if StringCodePage(Result) <> CodePage then
959 SetCodePage(Result,CodePage,CodePage <> CP_NONE);
960 end;
961
962 procedure TSQLDataItem.SetScale(aValue: integer);
963 begin
964 //Do nothing by default
965 end;
966
967 procedure TSQLDataItem.SetDataLength(len: cardinal);
968 begin
969 //Do nothing by default
970 end;
971
972 procedure TSQLDataItem.SetSQLType(aValue: cardinal);
973 begin
974 //Do nothing by default
975 end;
976
977 constructor TSQLDataItem.Create(api: TFBClientAPI);
978 begin
979 inherited Create;
980 FFirebirdClientAPI := api;
981 end;
982
983 function TSQLDataItem.GetSQLTypeName: AnsiString;
984 begin
985 Result := GetSQLTypeName(GetSQLType);
986 end;
987
988 class function TSQLDataItem.GetSQLTypeName(SQLType: short): AnsiString;
989 begin
990 Result := 'Unknown';
991 case SQLType of
992 SQL_VARYING: Result := 'SQL_VARYING';
993 SQL_TEXT: Result := 'SQL_TEXT';
994 SQL_DOUBLE: Result := 'SQL_DOUBLE';
995 SQL_FLOAT: Result := 'SQL_FLOAT';
996 SQL_LONG: Result := 'SQL_LONG';
997 SQL_SHORT: Result := 'SQL_SHORT';
998 SQL_TIMESTAMP: Result := 'SQL_TIMESTAMP';
999 SQL_BLOB: Result := 'SQL_BLOB';
1000 SQL_D_FLOAT: Result := 'SQL_D_FLOAT';
1001 SQL_ARRAY: Result := 'SQL_ARRAY';
1002 SQL_QUAD: Result := 'SQL_QUAD';
1003 SQL_TYPE_TIME: Result := 'SQL_TYPE_TIME';
1004 SQL_TYPE_DATE: Result := 'SQL_TYPE_DATE';
1005 SQL_INT64: Result := 'SQL_INT64';
1006 end;
1007 end;
1008
1009 function TSQLDataItem.GetAsBoolean: boolean;
1010 begin
1011 CheckActive;
1012 result := false;
1013 if not IsNull then
1014 begin
1015 if SQLType = SQL_BOOLEAN then
1016 result := PByte(SQLData)^ = ISC_TRUE
1017 else
1018 IBError(ibxeInvalidDataConversion, [nil]);
1019 end
1020 end;
1021
1022 function TSQLDataItem.GetAsCurrency: Currency;
1023 begin
1024 CheckActive;
1025 result := 0;
1026 if GetSQLDialect < 3 then
1027 result := GetAsDouble
1028 else begin
1029 if not IsNull then
1030 case SQLType of
1031 SQL_TEXT, SQL_VARYING: begin
1032 try
1033 result := StrtoCurr(AsString);
1034 except
1035 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
1036 end;
1037 end;
1038 SQL_SHORT:
1039 result := AdjustScaleToCurrency(Int64(PShort(SQLData)^),
1040 Scale);
1041 SQL_LONG:
1042 result := AdjustScaleToCurrency(Int64(PLong(SQLData)^),
1043 Scale);
1044 SQL_INT64:
1045 result := AdjustScaleToCurrency(PInt64(SQLData)^,
1046 Scale);
1047 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1048 result := Trunc(AsDouble);
1049 else
1050 IBError(ibxeInvalidDataConversion, [nil]);
1051 end;
1052 end;
1053 end;
1054
1055 function TSQLDataItem.GetAsInt64: Int64;
1056 begin
1057 CheckActive;
1058 result := 0;
1059 if not IsNull then
1060 case SQLType of
1061 SQL_TEXT, SQL_VARYING: begin
1062 try
1063 result := StrToInt64(AsString);
1064 except
1065 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
1066 end;
1067 end;
1068 SQL_SHORT:
1069 result := AdjustScaleToInt64(Int64(PShort(SQLData)^),
1070 Scale);
1071 SQL_LONG:
1072 result := AdjustScaleToInt64(Int64(PLong(SQLData)^),
1073 Scale);
1074 SQL_INT64:
1075 result := AdjustScaleToInt64(PInt64(SQLData)^,
1076 Scale);
1077 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1078 result := Trunc(AsDouble);
1079 else
1080 IBError(ibxeInvalidDataConversion, [nil]);
1081 end;
1082 end;
1083
1084 function TSQLDataItem.GetAsDateTime: TDateTime;
1085 begin
1086 CheckActive;
1087 result := 0;
1088 if not IsNull then
1089 with FFirebirdClientAPI do
1090 case SQLType of
1091 SQL_TEXT, SQL_VARYING: begin
1092 try
1093 result := StrToDate(AsString);
1094 except
1095 on E: EConvertError do IBError(ibxeInvalidDataConversion, [nil]);
1096 end;
1097 end;
1098 SQL_TYPE_DATE:
1099 result := SQLDecodeDate(SQLData);
1100 SQL_TYPE_TIME:
1101 result := SQLDecodeTime(SQLData);
1102 SQL_TIMESTAMP:
1103 result := SQLDecodeDateTime(SQLData);
1104 else
1105 IBError(ibxeInvalidDataConversion, [nil]);
1106 end;
1107 end;
1108
1109 function TSQLDataItem.GetAsDouble: Double;
1110 begin
1111 CheckActive;
1112 result := 0;
1113 if not IsNull then begin
1114 case SQLType of
1115 SQL_TEXT, SQL_VARYING: begin
1116 try
1117 result := StrToFloat(AsString);
1118 except
1119 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
1120 end;
1121 end;
1122 SQL_SHORT:
1123 result := AdjustScale(Int64(PShort(SQLData)^),
1124 Scale);
1125 SQL_LONG:
1126 result := AdjustScale(Int64(PLong(SQLData)^),
1127 Scale);
1128 SQL_INT64:
1129 result := AdjustScale(PInt64(SQLData)^, Scale);
1130 SQL_FLOAT:
1131 result := PFloat(SQLData)^;
1132 SQL_DOUBLE, SQL_D_FLOAT:
1133 result := PDouble(SQLData)^;
1134 else
1135 IBError(ibxeInvalidDataConversion, [nil]);
1136 end;
1137 if Scale <> 0 then
1138 result :=
1139 StrToFloat(FloatToStrF(result, fffixed, 15,
1140 Abs(Scale) ));
1141 end;
1142 end;
1143
1144 function TSQLDataItem.GetAsFloat: Float;
1145 begin
1146 CheckActive;
1147 result := 0;
1148 try
1149 result := AsDouble;
1150 except
1151 on E: EOverflow do
1152 IBError(ibxeInvalidDataConversion, [nil]);
1153 end;
1154 end;
1155
1156 function TSQLDataItem.GetAsLong: Long;
1157 begin
1158 CheckActive;
1159 result := 0;
1160 if not IsNull then
1161 case SQLType of
1162 SQL_TEXT, SQL_VARYING: begin
1163 try
1164 result := StrToInt(AsString);
1165 except
1166 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
1167 end;
1168 end;
1169 SQL_SHORT:
1170 result := Trunc(AdjustScale(Int64(PShort(SQLData)^),
1171 Scale));
1172 SQL_LONG:
1173 result := Trunc(AdjustScale(Int64(PLong(SQLData)^),
1174 Scale));
1175 SQL_INT64:
1176 result := Trunc(AdjustScale(PInt64(SQLData)^, Scale));
1177 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1178 result := Trunc(AsDouble);
1179 else
1180 IBError(ibxeInvalidDataConversion, [nil]);
1181 end;
1182 end;
1183
1184 function TSQLDataItem.GetAsPointer: Pointer;
1185 begin
1186 CheckActive;
1187 if not IsNull then
1188 result := SQLData
1189 else
1190 result := nil;
1191 end;
1192
1193 function TSQLDataItem.GetAsQuad: TISC_QUAD;
1194 begin
1195 CheckActive;
1196 result.gds_quad_high := 0;
1197 result.gds_quad_low := 0;
1198 if not IsNull then
1199 case SQLType of
1200 SQL_BLOB, SQL_ARRAY, SQL_QUAD:
1201 result := PISC_QUAD(SQLData)^;
1202 else
1203 IBError(ibxeInvalidDataConversion, [nil]);
1204 end;
1205 end;
1206
1207 function TSQLDataItem.GetAsShort: short;
1208 begin
1209 CheckActive;
1210 result := 0;
1211 try
1212 result := AsLong;
1213 except
1214 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
1215 end;
1216 end;
1217
1218
1219 function TSQLDataItem.GetAsString: AnsiString;
1220 var
1221 sz: PByte;
1222 str_len: Integer;
1223 rs: RawByteString;
1224 begin
1225 CheckActive;
1226 result := '';
1227 { Check null, if so return a default string }
1228 if not IsNull then
1229 with FFirebirdClientAPI do
1230 case SQLType of
1231 SQL_BOOLEAN:
1232 if AsBoolean then
1233 Result := sTrue
1234 else
1235 Result := SFalse;
1236
1237 SQL_TEXT, SQL_VARYING:
1238 begin
1239 sz := SQLData;
1240 if (SQLType = SQL_TEXT) then
1241 str_len := DataLength
1242 else begin
1243 str_len := DecodeInteger(SQLData, 2);
1244 Inc(sz, 2);
1245 end;
1246 SetString(rs, PAnsiChar(sz), str_len);
1247 SetCodePage(rs,GetCodePage,false);
1248 if (SQLType = SQL_TEXT) and (GetCharSetID <> 1) then
1249 Result := TrimRight(rs)
1250 else
1251 Result := rs
1252 end;
1253 SQL_TYPE_DATE:
1254 case GetSQLDialect of
1255 1 : result := DateTimeToStr(AsDateTime);
1256 3 : result := DateToStr(AsDateTime);
1257 end;
1258 SQL_TYPE_TIME :
1259 result := TimeToStr(AsDateTime);
1260 SQL_TIMESTAMP:
1261 {$IF declared(DefaultFormatSettings)}
1262 with DefaultFormatSettings do
1263 {$ELSE}
1264 {$IF declared(FormatSettings)}
1265 with FormatSettings do
1266 {$IFEND}
1267 {$IFEND}
1268 result := FormatDateTime(ShortDateFormat + ' ' +
1269 LongTimeFormat+'.zzz',AsDateTime);
1270 SQL_SHORT, SQL_LONG:
1271 if Scale = 0 then
1272 result := IntToStr(AsLong)
1273 else if Scale >= (-4) then
1274 result := CurrToStr(AsCurrency)
1275 else
1276 result := FloatToStr(AsDouble);
1277 SQL_INT64:
1278 if Scale = 0 then
1279 result := IntToStr(AsInt64)
1280 else if Scale >= (-4) then
1281 result := CurrToStr(AsCurrency)
1282 else
1283 result := FloatToStr(AsDouble);
1284 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1285 result := FloatToStr(AsDouble);
1286 else
1287 IBError(ibxeInvalidDataConversion, [nil]);
1288 end;
1289 end;
1290
1291 function TSQLDataItem.GetIsNull: Boolean;
1292 begin
1293 CheckActive;
1294 Result := false;
1295 end;
1296
1297 function TSQLDataItem.getIsNullable: boolean;
1298 begin
1299 CheckActive;
1300 Result := false;
1301 end;
1302
1303 function TSQLDataItem.GetAsVariant: Variant;
1304 begin
1305 CheckActive;
1306 if IsNull then
1307 result := NULL
1308 { Check null, if so return a default string }
1309 else case SQLType of
1310 SQL_ARRAY:
1311 result := '(Array)'; {do not localize}
1312 SQL_BLOB,
1313 SQL_TEXT, SQL_VARYING:
1314 result := AsString;
1315 SQL_TIMESTAMP, SQL_TYPE_DATE, SQL_TYPE_TIME:
1316 result := AsDateTime;
1317 SQL_SHORT, SQL_LONG:
1318 if Scale = 0 then
1319 result := AsLong
1320 else if Scale >= (-4) then
1321 result := AsCurrency
1322 else
1323 result := AsDouble;
1324 SQL_INT64:
1325 if Scale = 0 then
1326 result := AsInt64
1327 else if Scale >= (-4) then
1328 result := AsCurrency
1329 else
1330 result := AsDouble;
1331 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1332 result := AsDouble;
1333 SQL_BOOLEAN:
1334 result := AsBoolean;
1335 else
1336 IBError(ibxeInvalidDataConversion, [nil]);
1337 end;
1338 end;
1339
1340 function TSQLDataItem.GetModified: boolean;
1341 begin
1342 Result := false;
1343 end;
1344
1345
1346 procedure TSQLDataItem.SetIsNull(Value: Boolean);
1347 begin
1348 //ignore unless overridden
1349 end;
1350
1351 procedure TSQLDataItem.SetIsNullable(Value: Boolean);
1352 begin
1353 //ignore unless overridden
1354 end;
1355
1356 procedure TSQLDataItem.SetName(aValue: AnsiString);
1357 begin
1358 //ignore unless overridden
1359 end;
1360
1361 procedure TSQLDataItem.SetAsCurrency(Value: Currency);
1362 begin
1363 CheckActive;
1364 if GetSQLDialect < 3 then
1365 AsDouble := Value
1366 else
1367 begin
1368 Changing;
1369 if IsNullable then
1370 IsNull := False;
1371 SQLType := SQL_INT64;
1372 Scale := -4;
1373 DataLength := SizeOf(Int64);
1374 PCurrency(SQLData)^ := Value;
1375 Changed;
1376 end;
1377 end;
1378
1379 procedure TSQLDataItem.SetAsInt64(Value: Int64);
1380 begin
1381 CheckActive;
1382 Changing;
1383 if IsNullable then
1384 IsNull := False;
1385
1386 SQLType := SQL_INT64;
1387 Scale := 0;
1388 DataLength := SizeOf(Int64);
1389 PInt64(SQLData)^ := Value;
1390 Changed;
1391 end;
1392
1393 procedure TSQLDataItem.SetAsDate(Value: TDateTime);
1394 begin
1395 CheckActive;
1396 if GetSQLDialect < 3 then
1397 begin
1398 AsDateTime := Value;
1399 exit;
1400 end;
1401
1402 Changing;
1403 if IsNullable then
1404 IsNull := False;
1405
1406 SQLType := SQL_TYPE_DATE;
1407 DataLength := SizeOf(ISC_DATE);
1408 with FFirebirdClientAPI do
1409 SQLEncodeDate(Value,SQLData);
1410 Changed;
1411 end;
1412
1413 procedure TSQLDataItem.SetAsTime(Value: TDateTime);
1414 begin
1415 CheckActive;
1416 if GetSQLDialect < 3 then
1417 begin
1418 AsDateTime := Value;
1419 exit;
1420 end;
1421
1422 Changing;
1423 if IsNullable then
1424 IsNull := False;
1425
1426 SQLType := SQL_TYPE_TIME;
1427 DataLength := SizeOf(ISC_TIME);
1428 with FFirebirdClientAPI do
1429 SQLEncodeTime(Value,SQLData);
1430 Changed;
1431 end;
1432
1433 procedure TSQLDataItem.SetAsDateTime(Value: TDateTime);
1434 begin
1435 CheckActive;
1436 if IsNullable then
1437 IsNull := False;
1438
1439 Changing;
1440 SQLType := SQL_TIMESTAMP;
1441 DataLength := SizeOf(ISC_TIME) + sizeof(ISC_DATE);
1442 with FFirebirdClientAPI do
1443 SQLEncodeDateTime(Value,SQLData);
1444 Changed;
1445 end;
1446
1447 procedure TSQLDataItem.SetAsDouble(Value: Double);
1448 begin
1449 CheckActive;
1450 if IsNullable then
1451 IsNull := False;
1452
1453 Changing;
1454 SQLType := SQL_DOUBLE;
1455 DataLength := SizeOf(Double);
1456 Scale := 0;
1457 PDouble(SQLData)^ := Value;
1458 Changed;
1459 end;
1460
1461 procedure TSQLDataItem.SetAsFloat(Value: Float);
1462 begin
1463 CheckActive;
1464 if IsNullable then
1465 IsNull := False;
1466
1467 Changing;
1468 SQLType := SQL_FLOAT;
1469 DataLength := SizeOf(Float);
1470 Scale := 0;
1471 PSingle(SQLData)^ := Value;
1472 Changed;
1473 end;
1474
1475 procedure TSQLDataItem.SetAsLong(Value: Long);
1476 begin
1477 CheckActive;
1478 if IsNullable then
1479 IsNull := False;
1480
1481 Changing;
1482 SQLType := SQL_LONG;
1483 DataLength := SizeOf(Long);
1484 Scale := 0;
1485 PLong(SQLData)^ := Value;
1486 Changed;
1487 end;
1488
1489 procedure TSQLDataItem.SetAsPointer(Value: Pointer);
1490 begin
1491 CheckActive;
1492 Changing;
1493 if IsNullable and (Value = nil) then
1494 IsNull := True
1495 else
1496 begin
1497 IsNull := False;
1498 SQLType := SQL_TEXT;
1499 Move(Value^, SQLData^, DataLength);
1500 end;
1501 Changed;
1502 end;
1503
1504 procedure TSQLDataItem.SetAsQuad(Value: TISC_QUAD);
1505 begin
1506 CheckActive;
1507 Changing;
1508 if IsNullable then
1509 IsNull := False;
1510 if (SQLType <> SQL_BLOB) and
1511 (SQLType <> SQL_ARRAY) then
1512 IBError(ibxeInvalidDataConversion, [nil]);
1513 DataLength := SizeOf(TISC_QUAD);
1514 PISC_QUAD(SQLData)^ := Value;
1515 Changed;
1516 end;
1517
1518 procedure TSQLDataItem.SetAsShort(Value: short);
1519 begin
1520 CheckActive;
1521 Changing;
1522 if IsNullable then
1523 IsNull := False;
1524
1525 SQLType := SQL_SHORT;
1526 DataLength := SizeOf(Short);
1527 Scale := 0;
1528 PShort(SQLData)^ := Value;
1529 Changed;
1530 end;
1531
1532 procedure TSQLDataItem.SetAsString(Value: AnsiString);
1533 begin
1534 InternalSetAsString(Value);
1535 end;
1536
1537 procedure TSQLDataItem.SetAsVariant(Value: Variant);
1538 begin
1539 CheckActive;
1540 if VarIsNull(Value) then
1541 IsNull := True
1542 else case VarType(Value) of
1543 varEmpty, varNull:
1544 IsNull := True;
1545 varSmallint, varInteger, varByte,
1546 varWord, varShortInt:
1547 AsLong := Value;
1548 varInt64:
1549 AsInt64 := Value;
1550 varSingle, varDouble:
1551 AsDouble := Value;
1552 varCurrency:
1553 AsCurrency := Value;
1554 varBoolean:
1555 AsBoolean := Value;
1556 varDate:
1557 AsDateTime := Value;
1558 varOleStr, varString:
1559 AsString := Value;
1560 varArray:
1561 IBError(ibxeNotSupported, [nil]);
1562 varByRef, varDispatch, varError, varUnknown, varVariant:
1563 IBError(ibxeNotPermitted, [nil]);
1564 end;
1565 end;
1566
1567 procedure TSQLDataItem.SetAsNumeric(Value: Int64; aScale: integer);
1568 begin
1569 CheckActive;
1570 Changing;
1571 if IsNullable then
1572 IsNull := False;
1573
1574 SQLType := SQL_INT64;
1575 Scale := aScale;
1576 DataLength := SizeOf(Int64);
1577 PInt64(SQLData)^ := Value;
1578 Changed;
1579 end;
1580
1581 procedure TSQLDataItem.SetAsBoolean(AValue: boolean);
1582 begin
1583 CheckActive;
1584 Changing;
1585 if IsNullable then
1586 IsNull := False;
1587
1588 SQLType := SQL_BOOLEAN;
1589 DataLength := 1;
1590 Scale := 0;
1591 if AValue then
1592 PByte(SQLData)^ := ISC_TRUE
1593 else
1594 PByte(SQLData)^ := ISC_FALSE;
1595 Changed;
1596 end;
1597
1598 {TColumnMetaData}
1599
1600 procedure TColumnMetaData.CheckActive;
1601 begin
1602 if not FIBXSQLVAR.Parent.StateChanged(FChangeSeqNo) then Exit;
1603
1604 if FPrepareSeqNo < FIBXSQLVAR.Parent.GetPrepareSeqNo then
1605 IBError(ibxeInterfaceOutofDate,[nil]);
1606
1607 if not FIBXSQLVAR.Parent.CheckStatementStatus(ssPrepared) then
1608 IBError(ibxeStatementNotPrepared, [nil]);
1609 end;
1610
1611 function TColumnMetaData.SQLData: PByte;
1612 begin
1613 Result := FIBXSQLVAR.SQLData;
1614 end;
1615
1616 function TColumnMetaData.GetDataLength: cardinal;
1617 begin
1618 Result := FIBXSQLVAR.DataLength;
1619 end;
1620
1621 function TColumnMetaData.GetCodePage: TSystemCodePage;
1622 begin
1623 Result := FIBXSQLVAR.GetCodePage;
1624 end;
1625
1626 constructor TColumnMetaData.Create(aOwner: IUnknown; aIBXSQLVAR: TSQLVarData);
1627 begin
1628 inherited Create(aIBXSQLVAR.GetStatement.GetAttachment.getFirebirdAPI as TFBClientAPI);
1629 FIBXSQLVAR := aIBXSQLVAR;
1630 FOwner := aOwner;
1631 FPrepareSeqNo := FIBXSQLVAR.Parent.PrepareSeqNo;
1632 FIBXSQLVAR.Parent.StateChanged(FChangeSeqNo)
1633 end;
1634
1635 destructor TColumnMetaData.Destroy;
1636 begin
1637 (FOwner as TInterfaceOwner).Remove(self);
1638 inherited Destroy;
1639 end;
1640
1641
1642 function TColumnMetaData.GetSQLDialect: integer;
1643 begin
1644 Result := FIBXSQLVAR.Statement.GetSQLDialect;
1645 end;
1646
1647 function TColumnMetaData.GetIndex: integer;
1648 begin
1649 Result := FIBXSQLVAR.Index;
1650 end;
1651
1652 function TColumnMetaData.GetSQLType: cardinal;
1653 begin
1654 CheckActive;
1655 result := FIBXSQLVAR.SQLType;
1656 end;
1657
1658 function TColumnMetaData.getSubtype: integer;
1659 begin
1660 CheckActive;
1661 result := FIBXSQLVAR.SQLSubtype;
1662 end;
1663
1664 function TColumnMetaData.getRelationName: AnsiString;
1665 begin
1666 CheckActive;
1667 result := FIBXSQLVAR.RelationName;
1668 end;
1669
1670 function TColumnMetaData.getOwnerName: AnsiString;
1671 begin
1672 CheckActive;
1673 result := FIBXSQLVAR.OwnerName;
1674 end;
1675
1676 function TColumnMetaData.getSQLName: AnsiString;
1677 begin
1678 CheckActive;
1679 result := FIBXSQLVAR.FieldName;
1680 end;
1681
1682 function TColumnMetaData.getAliasName: AnsiString;
1683 begin
1684 CheckActive;
1685 result := FIBXSQLVAR.AliasName;
1686 end;
1687
1688 function TColumnMetaData.GetName: AnsiString;
1689 begin
1690 CheckActive;
1691 Result := FIBXSQLVAR. Name;
1692 end;
1693
1694 function TColumnMetaData.GetScale: integer;
1695 begin
1696 CheckActive;
1697 result := FIBXSQLVAR.Scale;
1698 end;
1699
1700 function TColumnMetaData.getCharSetID: cardinal;
1701 begin
1702 CheckActive;
1703 Result := FIBXSQLVAR.CharSetID;
1704 end;
1705
1706 function TColumnMetaData.GetIsNullable: boolean;
1707 begin
1708 CheckActive;
1709 result := FIBXSQLVAR.IsNullable;
1710 end;
1711
1712 function TColumnMetaData.GetSize: cardinal;
1713 begin
1714 CheckActive;
1715 result := FIBXSQLVAR.DataLength;
1716 end;
1717
1718 function TColumnMetaData.GetArrayMetaData: IArrayMetaData;
1719 begin
1720 CheckActive;
1721 result := FIBXSQLVAR.GetArrayMetaData;
1722 end;
1723
1724 function TColumnMetaData.GetBlobMetaData: IBlobMetaData;
1725 begin
1726 CheckActive;
1727 result := FIBXSQLVAR.GetBlobMetaData;
1728 end;
1729
1730 { TIBSQLData }
1731
1732 procedure TIBSQLData.CheckActive;
1733 begin
1734 if not FIBXSQLVAR.Parent.StateChanged(FChangeSeqNo) then Exit;
1735
1736 inherited CheckActive;
1737
1738 if not FIBXSQLVAR.Parent.CheckStatementStatus(ssCursorOpen) and
1739 not FIBXSQLVAR.Parent.CheckStatementStatus(ssExecuteResults) then
1740 IBError(ibxeSQLClosed, [nil]);
1741
1742 if FIBXSQLVAR.Parent.CheckStatementStatus(ssEOF) then
1743 IBError(ibxeEOF,[nil]);
1744
1745 if FIBXSQLVAR.Parent.CheckStatementStatus(ssBOF) then
1746 IBError(ibxeBOF,[nil]);
1747 end;
1748
1749 function TIBSQLData.GetIsNull: Boolean;
1750 begin
1751 CheckActive;
1752 result := FIBXSQLVAR.IsNull;
1753 end;
1754
1755 function TIBSQLData.GetAsArray: IArray;
1756 begin
1757 CheckActive;
1758 result := FIBXSQLVAR.GetAsArray(AsQuad);
1759 end;
1760
1761 function TIBSQLData.GetAsBlob: IBlob;
1762 begin
1763 CheckActive;
1764 result := FIBXSQLVAR.GetAsBlob(AsQuad,nil);
1765 end;
1766
1767 function TIBSQLData.GetAsBlob(BPB: IBPB): IBlob;
1768 begin
1769 CheckActive;
1770 result := FIBXSQLVAR.GetAsBlob(AsQuad,BPB);
1771 end;
1772
1773 function TIBSQLData.GetAsString: AnsiString;
1774 begin
1775 CheckActive;
1776 Result := '';
1777 { Check null, if so return a default string }
1778 if not IsNull then
1779 case SQLType of
1780 SQL_ARRAY:
1781 result := SArray;
1782 SQL_BLOB:
1783 Result := FIBXSQLVAR.GetAsBlob(AsQuad,nil).GetAsString;
1784 else
1785 Result := inherited GetAsString;
1786 end;
1787 end;
1788
1789 { TSQLParam }
1790
1791 procedure TSQLParam.InternalSetAsString(Value: AnsiString);
1792 var b: IBlob;
1793 dt: TDateTime;
1794 begin
1795 CheckActive;
1796 if IsNullable then
1797 IsNull := False;
1798 case SQLTYPE of
1799 SQL_BOOLEAN:
1800 if AnsiCompareText(Value,STrue) = 0 then
1801 AsBoolean := true
1802 else
1803 if AnsiCompareText(Value,SFalse) = 0 then
1804 AsBoolean := false
1805 else
1806 IBError(ibxeInvalidDataConversion,[nil]);
1807
1808 SQL_BLOB:
1809 begin
1810 Changing;
1811 b := FIBXSQLVAR.CreateBlob;
1812 b.SetAsString(Value);
1813 AsBlob := b;
1814 Changed;
1815 end;
1816
1817 SQL_VARYING,
1818 SQL_TEXT:
1819 begin
1820 Changing;
1821 FIBXSQLVar.SetString(Transliterate(Value,GetCodePage));
1822 Changed;
1823 end;
1824
1825 SQL_SHORT,
1826 SQL_LONG,
1827 SQL_INT64:
1828 SetAsNumeric(AdjustScaleFromCurrency(StrToCurr(Value),GetScale),GetScale);
1829
1830 SQL_D_FLOAT,
1831 SQL_DOUBLE,
1832 SQL_FLOAT:
1833 SetAsDouble(StrToFloat(Value));
1834
1835 SQL_TIMESTAMP:
1836 if TryStrToDateTime(Value,dt) then
1837 SetAsDateTime(dt)
1838 else
1839 FIBXSQLVar.SetString(Value);
1840
1841 SQL_TYPE_DATE:
1842 if TryStrToDateTime(Value,dt) then
1843 SetAsDate(dt)
1844 else
1845 FIBXSQLVar.SetString(Value);
1846
1847 SQL_TYPE_TIME:
1848 if TryStrToDateTime(Value,dt) then
1849 SetAsTime(dt)
1850 else
1851 FIBXSQLVar.SetString(Value);
1852
1853 else
1854 IBError(ibxeInvalidDataConversion,[nil]);
1855 end;
1856 end;
1857
1858 procedure TSQLParam.CheckActive;
1859 begin
1860 if not FIBXSQLVAR.Parent.StateChanged(FChangeSeqNo) then Exit;
1861
1862 if FPrepareSeqNo < FIBXSQLVAR.Parent.GetPrepareSeqNo then
1863 IBError(ibxeInterfaceOutofDate,[nil]);
1864
1865 if not FIBXSQLVAR.Parent.CheckStatementStatus(ssPrepared) then
1866 IBError(ibxeStatementNotPrepared, [nil]);
1867 end;
1868
1869 procedure TSQLParam.SetScale(aValue: integer);
1870 begin
1871 CheckActive;
1872 FIBXSQLVAR.Scale := aValue;
1873 end;
1874
1875 procedure TSQLParam.SetDataLength(len: cardinal);
1876 begin
1877 CheckActive;
1878 FIBXSQLVAR.DataLength := len;
1879 end;
1880
1881 procedure TSQLParam.SetSQLType(aValue: cardinal);
1882 begin
1883 CheckActive;
1884 FIBXSQLVAR.SQLType := aValue;
1885 end;
1886
1887 procedure TSQLParam.Clear;
1888 begin
1889 IsNull := true;
1890 end;
1891
1892 function TSQLParam.GetModified: boolean;
1893 begin
1894 CheckActive;
1895 Result := FIBXSQLVAR.Modified;
1896 end;
1897
1898 function TSQLParam.GetAsPointer: Pointer;
1899 begin
1900 IsNull := false; {Assume that we get the pointer in order to set a value}
1901 Changed;
1902 Result := inherited GetAsPointer;
1903 end;
1904
1905 procedure TSQLParam.SetName(Value: AnsiString);
1906 begin
1907 CheckActive;
1908 FIBXSQLVAR.Name := Value;
1909 end;
1910
1911 procedure TSQLParam.SetIsNull(Value: Boolean);
1912 var i: integer;
1913 begin
1914 CheckActive;
1915 if FIBXSQLVAR.UniqueName then
1916 FIBXSQLVAR.IsNull := Value
1917 else
1918 with FIBXSQLVAR.Parent do
1919 begin
1920 for i := 0 to Count - 1 do
1921 if Column[i].Name = Name then
1922 Column[i].IsNull := Value;
1923 end
1924 end;
1925
1926 procedure TSQLParam.SetIsNullable(Value: Boolean);
1927 var i: integer;
1928 begin
1929 CheckActive;
1930 if FIBXSQLVAR.UniqueName then
1931 FIBXSQLVAR.IsNullable := Value
1932 else
1933 with FIBXSQLVAR.Parent do
1934 begin
1935 for i := 0 to Count - 1 do
1936 if Column[i].Name = Name then
1937 Column[i].IsNullable := Value;
1938 end
1939 end;
1940
1941 procedure TSQLParam.SetAsArray(anArray: IArray);
1942 begin
1943 CheckActive;
1944 if GetSQLType <> SQL_ARRAY then
1945 IBError(ibxeInvalidDataConversion,[nil]);
1946
1947 if not FIBXSQLVAR.UniqueName then
1948 IBError(ibxeDuplicateParamName,[FIBXSQLVAR.Name]);
1949
1950 SetAsQuad(AnArray.GetArrayID);
1951 end;
1952
1953 procedure TSQLParam.Changed;
1954 begin
1955 FIBXSQLVAR.Changed;
1956 end;
1957
1958 procedure TSQLParam.SetAsBoolean(AValue: boolean);
1959 var i: integer;
1960 OldSQLVar: TSQLVarData;
1961 begin
1962 if FIBXSQLVAR.UniqueName then
1963 inherited SetAsBoolean(AValue)
1964 else
1965 with FIBXSQLVAR.Parent do
1966 begin
1967 for i := 0 to Count - 1 do
1968 if Column[i].Name = Name then
1969 begin
1970 OldSQLVar := FIBXSQLVAR;
1971 FIBXSQLVAR := Column[i];
1972 try
1973 inherited SetAsBoolean(AValue);
1974 finally
1975 FIBXSQLVAR := OldSQLVar;
1976 end;
1977 end;
1978 end;
1979 end;
1980
1981 procedure TSQLParam.SetAsCurrency(AValue: Currency);
1982 var i: integer;
1983 OldSQLVar: TSQLVarData;
1984 begin
1985 if FIBXSQLVAR.UniqueName then
1986 inherited SetAsCurrency(AValue)
1987 else
1988 with FIBXSQLVAR.Parent do
1989 begin
1990 for i := 0 to Count - 1 do
1991 if Column[i].Name = Name then
1992 begin
1993 OldSQLVar := FIBXSQLVAR;
1994 FIBXSQLVAR := Column[i];
1995 try
1996 inherited SetAsCurrency(AValue);
1997 finally
1998 FIBXSQLVAR := OldSQLVar;
1999 end;
2000 end;
2001 end;
2002 end;
2003
2004 procedure TSQLParam.SetAsInt64(AValue: Int64);
2005 var i: integer;
2006 OldSQLVar: TSQLVarData;
2007 begin
2008 if FIBXSQLVAR.UniqueName then
2009 inherited SetAsInt64(AValue)
2010 else
2011 with FIBXSQLVAR.Parent do
2012 begin
2013 for i := 0 to Count - 1 do
2014 if Column[i].Name = Name then
2015 begin
2016 OldSQLVar := FIBXSQLVAR;
2017 FIBXSQLVAR := Column[i];
2018 try
2019 inherited SetAsInt64(AValue);
2020 finally
2021 FIBXSQLVAR := OldSQLVar;
2022 end;
2023 end;
2024 end;
2025 end;
2026
2027 procedure TSQLParam.SetAsDate(AValue: TDateTime);
2028 var i: integer;
2029 OldSQLVar: TSQLVarData;
2030 begin
2031 if FIBXSQLVAR.UniqueName then
2032 inherited SetAsDate(AValue)
2033 else
2034 with FIBXSQLVAR.Parent do
2035 begin
2036 for i := 0 to Count - 1 do
2037 if Column[i].Name = Name then
2038 begin
2039 OldSQLVar := FIBXSQLVAR;
2040 FIBXSQLVAR := Column[i];
2041 try
2042 inherited SetAsDate(AValue);
2043 finally
2044 FIBXSQLVAR := OldSQLVar;
2045 end;
2046 end;
2047 end;
2048 end;
2049
2050 procedure TSQLParam.SetAsLong(AValue: Long);
2051 var i: integer;
2052 OldSQLVar: TSQLVarData;
2053 begin
2054 if FIBXSQLVAR.UniqueName then
2055 inherited SetAsLong(AValue)
2056 else
2057 with FIBXSQLVAR.Parent do
2058 begin
2059 for i := 0 to Count - 1 do
2060 if Column[i].Name = Name then
2061 begin
2062 OldSQLVar := FIBXSQLVAR;
2063 FIBXSQLVAR := Column[i];
2064 try
2065 inherited SetAsLong(AValue);
2066 finally
2067 FIBXSQLVAR := OldSQLVar;
2068 end;
2069 end;
2070 end;
2071 end;
2072
2073 procedure TSQLParam.SetAsTime(AValue: TDateTime);
2074 var i: integer;
2075 OldSQLVar: TSQLVarData;
2076 begin
2077 if FIBXSQLVAR.UniqueName then
2078 inherited SetAsTime(AValue)
2079 else
2080 with FIBXSQLVAR.Parent do
2081 begin
2082 for i := 0 to Count - 1 do
2083 if Column[i].Name = Name then
2084 begin
2085 OldSQLVar := FIBXSQLVAR;
2086 FIBXSQLVAR := Column[i];
2087 try
2088 inherited SetAsTime(AValue);
2089 finally
2090 FIBXSQLVAR := OldSQLVar;
2091 end;
2092 end;
2093 end;
2094 end;
2095
2096 procedure TSQLParam.SetAsDateTime(AValue: TDateTime);
2097 var i: integer;
2098 OldSQLVar: TSQLVarData;
2099 begin
2100 if FIBXSQLVAR.UniqueName then
2101 inherited SetAsDateTime(AValue)
2102 else
2103 with FIBXSQLVAR.Parent do
2104 begin
2105 for i := 0 to Count - 1 do
2106 if Column[i].Name = Name then
2107 begin
2108 OldSQLVar := FIBXSQLVAR;
2109 FIBXSQLVAR := Column[i];
2110 try
2111 inherited SetAsDateTime(AValue);
2112 finally
2113 FIBXSQLVAR := OldSQLVar;
2114 end;
2115 end;
2116 end;
2117 end;
2118
2119 procedure TSQLParam.SetAsDouble(AValue: Double);
2120 var i: integer;
2121 OldSQLVar: TSQLVarData;
2122 begin
2123 if FIBXSQLVAR.UniqueName then
2124 inherited SetAsDouble(AValue)
2125 else
2126 with FIBXSQLVAR.Parent do
2127 begin
2128 for i := 0 to Count - 1 do
2129 if Column[i].Name = Name then
2130 begin
2131 OldSQLVar := FIBXSQLVAR;
2132 FIBXSQLVAR := Column[i];
2133 try
2134 inherited SetAsDouble(AValue);
2135 finally
2136 FIBXSQLVAR := OldSQLVar;
2137 end;
2138 end;
2139 end;
2140 end;
2141
2142 procedure TSQLParam.SetAsFloat(AValue: Float);
2143 var i: integer;
2144 OldSQLVar: TSQLVarData;
2145 begin
2146 if FIBXSQLVAR.UniqueName then
2147 inherited SetAsFloat(AValue)
2148 else
2149 with FIBXSQLVAR.Parent do
2150 begin
2151 for i := 0 to Count - 1 do
2152 if Column[i].Name = Name then
2153 begin
2154 OldSQLVar := FIBXSQLVAR;
2155 FIBXSQLVAR := Column[i];
2156 try
2157 inherited SetAsFloat(AValue);
2158 finally
2159 FIBXSQLVAR := OldSQLVar;
2160 end;
2161 end;
2162 end;
2163 end;
2164
2165 procedure TSQLParam.SetAsPointer(AValue: Pointer);
2166 var i: integer;
2167 OldSQLVar: TSQLVarData;
2168 begin
2169 if FIBXSQLVAR.UniqueName then
2170 inherited SetAsPointer(AValue)
2171 else
2172 with FIBXSQLVAR.Parent do
2173 begin
2174 for i := 0 to Count - 1 do
2175 if Column[i].Name = Name then
2176 begin
2177 OldSQLVar := FIBXSQLVAR;
2178 FIBXSQLVAR := Column[i];
2179 try
2180 inherited SetAsPointer(AValue);
2181 finally
2182 FIBXSQLVAR := OldSQLVar;
2183 end;
2184 end;
2185 end;
2186 end;
2187
2188 procedure TSQLParam.SetAsShort(AValue: Short);
2189 var i: integer;
2190 OldSQLVar: TSQLVarData;
2191 begin
2192 if FIBXSQLVAR.UniqueName then
2193 inherited SetAsShort(AValue)
2194 else
2195 with FIBXSQLVAR.Parent do
2196 begin
2197 for i := 0 to Count - 1 do
2198 if Column[i].Name = Name then
2199 begin
2200 OldSQLVar := FIBXSQLVAR;
2201 FIBXSQLVAR := Column[i];
2202 try
2203 inherited SetAsShort(AValue);
2204 finally
2205 FIBXSQLVAR := OldSQLVar;
2206 end;
2207 end;
2208 end;
2209 end;
2210
2211 procedure TSQLParam.SetAsString(AValue: AnsiString);
2212 var i: integer;
2213 OldSQLVar: TSQLVarData;
2214 begin
2215 if FIBXSQLVAR.UniqueName then
2216 InternalSetAsString(AValue)
2217 else
2218 with FIBXSQLVAR.Parent do
2219 begin
2220 for i := 0 to Count - 1 do
2221 if Column[i].Name = Name then
2222 begin
2223 OldSQLVar := FIBXSQLVAR;
2224 FIBXSQLVAR := Column[i];
2225 try
2226 InternalSetAsString(AValue);
2227 finally
2228 FIBXSQLVAR := OldSQLVar;
2229 end;
2230 end;
2231 end;
2232 end;
2233
2234 procedure TSQLParam.SetAsVariant(AValue: Variant);
2235 var i: integer;
2236 OldSQLVar: TSQLVarData;
2237 begin
2238 if FIBXSQLVAR.UniqueName then
2239 inherited SetAsVariant(AValue)
2240 else
2241 with FIBXSQLVAR.Parent do
2242 begin
2243 for i := 0 to Count - 1 do
2244 if Column[i].Name = Name then
2245 begin
2246 OldSQLVar := FIBXSQLVAR;
2247 FIBXSQLVAR := Column[i];
2248 try
2249 inherited SetAsVariant(AValue);
2250 finally
2251 FIBXSQLVAR := OldSQLVar;
2252 end;
2253 end;
2254 end;
2255 end;
2256
2257 procedure TSQLParam.SetAsBlob(aValue: IBlob);
2258 begin
2259 with FIBXSQLVAR do
2260 if not UniqueName then
2261 IBError(ibxeDuplicateParamName,[Name]);
2262 CheckActive;
2263 Changing;
2264 aValue.Close;
2265 if aValue.GetSubType <> GetSubType then
2266 IBError(ibxeIncompatibleBlob,[GetSubType,aValue.GetSubType]);
2267 AsQuad := aValue.GetBlobID;
2268 Changed;
2269 end;
2270
2271 procedure TSQLParam.SetAsQuad(AValue: TISC_QUAD);
2272 var i: integer;
2273 OldSQLVar: TSQLVarData;
2274 begin
2275 if FIBXSQLVAR.UniqueName then
2276 inherited SetAsQuad(AValue)
2277 else
2278 with FIBXSQLVAR.Parent do
2279 begin
2280 for i := 0 to Count - 1 do
2281 if Column[i].Name = Name then
2282 begin
2283 OldSQLVar := FIBXSQLVAR;
2284 FIBXSQLVAR := Column[i];
2285 try
2286 inherited SetAsQuad(AValue);
2287 finally
2288 FIBXSQLVAR := OldSQLVar;
2289 end;
2290 end;
2291 end;
2292 end;
2293
2294 procedure TSQLParam.SetCharSetID(aValue: cardinal);
2295 begin
2296 FIBXSQLVAR.SetCharSetID(aValue);
2297 end;
2298
2299 { TMetaData }
2300
2301 procedure TMetaData.CheckActive;
2302 begin
2303 if FPrepareSeqNo < FMetaData.PrepareSeqNo then
2304 IBError(ibxeInterfaceOutofDate,[nil]);
2305
2306 if not FMetaData.CheckStatementStatus(ssPrepared) then
2307 IBError(ibxeStatementNotPrepared, [nil]);
2308 end;
2309
2310 constructor TMetaData.Create(aMetaData: TSQLDataArea);
2311 begin
2312 inherited Create(aMetaData.Count);
2313 FMetaData := aMetaData;
2314 FStatement := aMetaData.Statement;
2315 FPrepareSeqNo := aMetaData.PrepareSeqNo;
2316 end;
2317
2318 destructor TMetaData.Destroy;
2319 begin
2320 (FStatement as TInterfaceOwner).Remove(self);
2321 inherited Destroy;
2322 end;
2323
2324 function TMetaData.GetUniqueRelationName: AnsiString;
2325 begin
2326 CheckActive;
2327 Result := FMetaData.UniqueRelationName;
2328 end;
2329
2330 function TMetaData.getCount: integer;
2331 begin
2332 CheckActive;
2333 Result := FMetaData.ColumnsInUseCount;
2334 end;
2335
2336 function TMetaData.getColumnMetaData(index: integer): IColumnMetaData;
2337 begin
2338 CheckActive;
2339 if (index < 0) or (index >= getCount) then
2340 IBError(ibxeInvalidColumnIndex,[nil]);
2341
2342 if FMetaData.Count = 0 then
2343 Result := nil
2344 else
2345 begin
2346 if not HasInterface(index) then
2347 AddInterface(index,TColumnMetaData.Create(self,FMetaData.Column[index]));
2348 Result := TColumnMetaData(GetInterface(index));
2349 end;
2350 end;
2351
2352 function TMetaData.ByName(Idx: AnsiString): IColumnMetaData;
2353 var aIBXSQLVAR: TSQLVarData;
2354 begin
2355 CheckActive;
2356 aIBXSQLVAR := FMetaData.ColumnByName(Idx);
2357 if aIBXSQLVAR = nil then
2358 IBError(ibxeFieldNotFound,[Idx]);
2359 Result := getColumnMetaData(aIBXSQLVAR.index);
2360 end;
2361
2362 { TSQLParams }
2363
2364 procedure TSQLParams.CheckActive;
2365 begin
2366 if not FSQLParams.StateChanged(FChangeSeqNo) then Exit;
2367
2368 if FPrepareSeqNo < FSQLParams.PrepareSeqNo then
2369 IBError(ibxeInterfaceOutofDate,[nil]);
2370
2371 if not FSQLParams.CheckStatementStatus(ssPrepared) then
2372 IBError(ibxeStatementNotPrepared, [nil]);
2373 end;
2374
2375 constructor TSQLParams.Create(aSQLParams: TSQLDataArea);
2376 begin
2377 inherited Create(aSQLParams.Count);
2378 FSQLParams := aSQLParams;
2379 FStatement := aSQLParams.Statement;
2380 FPrepareSeqNo := aSQLParams.PrepareSeqNo;
2381 FSQLParams.StateChanged(FChangeSeqNo);
2382 end;
2383
2384 destructor TSQLParams.Destroy;
2385 begin
2386 (FStatement as TInterfaceOwner).Remove(self);
2387 inherited Destroy;
2388 end;
2389
2390 function TSQLParams.getCount: integer;
2391 begin
2392 CheckActive;
2393 Result := FSQLParams.ColumnsInUseCount;
2394 end;
2395
2396 function TSQLParams.getSQLParam(index: integer): ISQLParam;
2397 begin
2398 CheckActive;
2399 if (index < 0) or (index >= getCount) then
2400 IBError(ibxeInvalidColumnIndex,[nil]);
2401
2402 if getCount = 0 then
2403 Result := nil
2404 else
2405 begin
2406 if not HasInterface(index) then
2407 AddInterface(index, TSQLParam.Create(self,FSQLParams.Column[index]));
2408 Result := TSQLParam(GetInterface(index));
2409 end;
2410 end;
2411
2412 function TSQLParams.ByName(Idx: AnsiString): ISQLParam;
2413 var aIBXSQLVAR: TSQLVarData;
2414 begin
2415 CheckActive;
2416 aIBXSQLVAR := FSQLParams.ColumnByName(Idx);
2417 if aIBXSQLVAR = nil then
2418 IBError(ibxeFieldNotFound,[Idx]);
2419 Result := getSQLParam(aIBXSQLVAR.index);
2420 end;
2421
2422 function TSQLParams.GetModified: Boolean;
2423 var
2424 i: Integer;
2425 begin
2426 CheckActive;
2427 result := False;
2428 with FSQLParams do
2429 for i := 0 to Count - 1 do
2430 if Column[i].Modified then
2431 begin
2432 result := True;
2433 exit;
2434 end;
2435 end;
2436
2437 { TResults }
2438
2439 procedure TResults.CheckActive;
2440 begin
2441 if not FResults.StateChanged(FChangeSeqNo) then Exit;
2442
2443 if FPrepareSeqNo < FResults.PrepareSeqNo then
2444 IBError(ibxeInterfaceOutofDate,[nil]);
2445
2446 if not FResults.CheckStatementStatus(ssPrepared) then
2447 IBError(ibxeStatementNotPrepared, [nil]);
2448
2449 with GetTransaction as TFBTransaction do
2450 if not InTransaction or (FResults.TransactionSeqNo <> FTransactionSeqNo) then
2451 IBError(ibxeInterfaceOutofDate,[nil]);
2452 end;
2453
2454 function TResults.GetISQLData(aIBXSQLVAR: TSQLVarData): ISQLData;
2455 begin
2456 if (aIBXSQLVAR.Index < 0) or (aIBXSQLVAR.Index >= getCount) then
2457 IBError(ibxeInvalidColumnIndex,[nil]);
2458
2459 if not HasInterface(aIBXSQLVAR.Index) then
2460 AddInterface(aIBXSQLVAR.Index, TIBSQLData.Create(self,aIBXSQLVAR));
2461 Result := TIBSQLData(GetInterface(aIBXSQLVAR.Index));
2462 end;
2463
2464 constructor TResults.Create(aResults: TSQLDataArea);
2465 begin
2466 inherited Create(aResults.Count);
2467 FResults := aResults;
2468 FStatement := aResults.Statement;
2469 FPrepareSeqNo := aResults.PrepareSeqNo;
2470 FTransactionSeqNo := aResults.TransactionSeqNo;
2471 FResults.StateChanged(FChangeSeqNo);
2472 end;
2473
2474 function TResults.getCount: integer;
2475 begin
2476 CheckActive;
2477 Result := FResults.Count;
2478 end;
2479
2480 function TResults.ByName(Idx: AnsiString): ISQLData;
2481 var col: TSQLVarData;
2482 begin
2483 Result := nil;
2484 CheckActive;
2485 if FResults.CheckStatementStatus(ssBOF) then
2486 IBError(ibxeBOF,[nil]);
2487 if FResults.CheckStatementStatus(ssEOF) then
2488 IBError(ibxeEOF,[nil]);
2489
2490 if FResults.Count > 0 then
2491 begin
2492 col := FResults.ColumnByName(Idx);
2493 if col <> nil then
2494 Result := GetISQLData(col);
2495 end;
2496 end;
2497
2498 function TResults.getSQLData(index: integer): ISQLData;
2499 begin
2500 CheckActive;
2501 if FResults.CheckStatementStatus(ssBOF) then
2502 IBError(ibxeBOF,[nil]);
2503 if FResults.CheckStatementStatus(ssEOF) then
2504 IBError(ibxeEOF,[nil]);
2505 if (index < 0) or (index >= FResults.Count) then
2506 IBError(ibxeInvalidColumnIndex,[nil]);
2507
2508 Result := GetISQLData(FResults.Column[index]);
2509 end;
2510
2511 procedure TResults.GetData(index: integer; var IsNull: boolean; var len: short;
2512 var data: PByte);
2513 begin
2514 CheckActive;
2515 FResults.GetData(index,IsNull, len,data);
2516 end;
2517
2518 function TResults.GetTransaction: ITransaction;
2519 begin
2520 Result := FStatement.GetTransaction;
2521 end;
2522
2523 procedure TResults.SetRetainInterfaces(aValue: boolean);
2524 begin
2525 RetainInterfaces := aValue;
2526 end;
2527
2528 end.
2529