ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/client/FBSQLData.pas
Revision: 59
Committed: Mon Mar 13 09:51:56 2017 UTC (7 years ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/FBSQLData.pas
File size: 68187 byte(s)
Log Message:

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