ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/client/FBSQLData.pas
Revision: 47
Committed: Mon Jan 9 15:31:51 2017 UTC (7 years, 10 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/FBSQLData.pas
File size: 66886 byte(s)
Log Message:
Committing updates for Release R2-0-1

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