ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/client/FBSQLData.pas
Revision: 45
Committed: Tue Dec 6 10:33:46 2016 UTC (7 years, 11 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/FBSQLData.pas
File size: 66100 byte(s)
Log Message:
Committing updates for Release R2-0-0

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