ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/client/FBSQLData.pas
Revision: 309
Committed: Tue Jul 21 08:00:42 2020 UTC (4 years, 4 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/FBSQLData.pas
File size: 67775 byte(s)
Log Message: 
Fixes Merged

File Contents

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