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