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

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