ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/FBSQLData.pas
Revision: 56
Committed: Mon Mar 6 10:20:02 2017 UTC (7 years, 8 months ago) by tony
Content type: text/x-pascal
File size: 67582 byte(s)
Log Message:
Committing updates for Trunk

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