ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/client/FBSQLData.pas
Revision: 349
Committed: Mon Oct 18 08:39:40 2021 UTC (3 years, 1 month ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/FBSQLData.pas
File size: 90604 byte(s)
Log Message:
FIxes Merged

File Contents

# Content
1 (*
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 {$IFDEF MSWINDOWS}
64 {$DEFINE WINDOWS}
65 {$ENDIF}
66
67 {$IFDEF FPC}
68 {$mode delphi}
69 {$codepage UTF8}
70 {$interfaces COM}
71 {$ENDIF}
72
73 { This Unit was hacked out of the IBSQL unit and defines a class used as the
74 base for interfaces accessing SQLDAVar data and Array Elements. The abstract
75 methods are used to customise for an SQLDAVar or Array Element. The empty
76 methods are needed for SQL parameters only. The string getters and setters
77 are virtual as SQLVar and Array encodings of string data is different.}
78
79
80 interface
81
82 uses
83 Classes, SysUtils, IBExternals, {$IFDEF WINDOWS} Windows, {$ENDIF} IB, FBActivityMonitor, FBClientAPI,
84 FmtBCD;
85
86 type
87
88 {The IExTimeZoneServices is only available in FB4 and onwards}
89
90 IExTimeZoneServices = interface(ITimeZoneServices)
91 ['{789c2eeb-c4a7-4fed-837e-0cbdef775904}']
92 {encode/decode - used to encode/decode the wire protocol}
93 procedure EncodeTimestampTZ(timestamp: TDateTime; timezoneID: TFBTimeZoneID;
94 bufptr: PByte); overload;
95 procedure EncodeTimestampTZ(timestamp: TDateTime; timezone: AnsiString;
96 bufptr: PByte); overload;
97 procedure EncodeTimeTZ(time: TDateTime; timezoneID: TFBTimeZoneID; OnDate: TDateTime;
98 bufptr: PByte); overload;
99 procedure EncodeTimeTZ(time: TDateTime; timezone: AnsiString; OnDate: TDateTime;
100 bufptr: PByte); overload;
101 procedure DecodeTimestampTZ(bufptr: PByte; var timestamp: TDateTime;
102 var dstOffset: smallint; var timezoneID: TFBTimeZoneID); overload;
103 procedure DecodeTimestampTZ(bufptr: PByte; var timestamp: TDateTime;
104 var dstOffset: smallint; var timezone: AnsiString); overload;
105 procedure DecodeTimestampTZEx(bufptr: PByte; var timestamp: TDateTime;
106 var dstOffset: smallint; var timezoneID: TFBTimeZoneID); overload;
107 procedure DecodeTimestampTZEx(bufptr: PByte; var timestamp: TDateTime;
108 var dstOffset: smallint; var timezone: AnsiString); overload;
109 procedure DecodeTimeTZ(bufptr: PByte; OnDate: TDateTime; var time: TDateTime;
110 var dstOffset: smallint; var timezoneID: TFBTimeZoneID); overload;
111 procedure DecodeTimeTZ(bufptr: PByte; OnDate: TDateTime; var time: TDateTime;
112 var dstOffset: smallint; var timezone: AnsiString); overload;
113 procedure DecodeTimeTZEx(bufptr: PByte; OnDate: TDateTime; var time: TDateTime;
114 var dstOffset: smallint; var timezoneID: TFBTimeZoneID); overload;
115 procedure DecodeTimeTZEx(bufptr: PByte; OnDate: TDateTime; var time: TDateTime;
116 var dstOffset: smallint; var timezone: AnsiString); overload;
117 end;
118
119 { TSQLDataItem }
120
121 TSQLDataItem = class(TFBInterfacedObject)
122 private
123 FFirebirdClientAPI: TFBClientAPI;
124 FTimeZoneServices: IExTimeZoneServices;
125 function AdjustScale(Value: Int64; aScale: Integer): Double;
126 function AdjustScaleToInt64(Value: Int64; aScale: Integer): Int64;
127 function AdjustScaleToCurrency(Value: Int64; aScale: Integer): Currency;
128 function GetDateFormatStr(IncludeTime: boolean): AnsiString;
129 function GetTimeFormatStr: AnsiString;
130 function GetTimestampFormatStr: AnsiString;
131 procedure SetAsInteger(AValue: Integer);
132 procedure InternalGetAsDateTime(var aDateTime: TDateTime; var dstOffset: smallint;
133 var aTimezone: AnsiString; var aTimeZoneID: TFBTimeZoneID);
134 protected
135 function AdjustScaleFromCurrency(Value: Currency; aScale: Integer): Int64;
136 function AdjustScaleFromDouble(Value: Double; aScale: Integer): Int64;
137 procedure CheckActive; virtual;
138 procedure CheckTZSupport;
139 function GetAttachment: IAttachment; virtual; abstract;
140 function GetSQLDialect: integer; virtual; abstract;
141 function GetTimeZoneServices: IExTimeZoneServices; virtual;
142 procedure Changed; virtual;
143 procedure Changing; virtual;
144 procedure InternalSetAsString(Value: AnsiString); virtual;
145 function SQLData: PByte; virtual; abstract;
146 function GetDataLength: cardinal; virtual; abstract;
147 function GetCodePage: TSystemCodePage; virtual; abstract;
148 function getCharSetID: cardinal; virtual; abstract;
149 function Transliterate(s: AnsiString; CodePage: TSystemCodePage): RawByteString;
150 procedure SetScale(aValue: integer); virtual;
151 procedure SetDataLength(len: cardinal); virtual;
152 procedure SetSQLType(aValue: cardinal); virtual;
153 property DataLength: cardinal read GetDataLength write SetDataLength;
154 property FirebirdClientAPI: TFBClientAPI read FFirebirdClientAPI;
155 public
156 constructor Create(api: TFBClientAPI);
157 function GetSQLType: cardinal; virtual; abstract; {Current Field Data SQL Type}
158 function GetSQLTypeName: AnsiString; overload;
159 class function GetSQLTypeName(SQLType: cardinal): AnsiString; overload;
160 function GetStrDataLength: short;
161 function GetName: AnsiString; virtual; abstract;
162 function GetScale: integer; virtual; abstract; {Current Field Data scale}
163 function GetAsBoolean: boolean;
164 function GetAsCurrency: Currency;
165 function GetAsInt64: Int64;
166 function GetAsDateTime: TDateTime; overload;
167 procedure GetAsDateTime(var aDateTime: TDateTime; var dstOffset: smallint; var aTimezone: AnsiString); overload;
168 procedure GetAsDateTime(var aDateTime: TDateTime; var dstOffset: smallint; var aTimezoneID: TFBTimeZoneID); overload;
169 procedure GetAsTime(var aTime: TDateTime; var dstOffset: smallint; var aTimezoneID: TFBTimeZoneID; OnDate: TDateTime); overload;
170 procedure GetAsTime(var aTime: TDateTime; var dstOffset: smallint; var aTimezone: AnsiString; OnDate: TDateTime); overload;
171 procedure GetAsTime(var aTime: TDateTime; var dstOffset: smallint; var aTimezoneID: TFBTimeZoneID); overload;
172 procedure GetAsTime(var aTime: TDateTime; var dstOffset: smallint; var aTimezone: AnsiString); overload;
173 function GetAsUTCDateTime: TDateTime;
174 function GetAsDouble: Double;
175 function GetAsFloat: Float;
176 function GetAsLong: Long;
177 function GetAsPointer: Pointer;
178 function GetAsQuad: TISC_QUAD;
179 function GetAsShort: short;
180 function GetAsString: AnsiString; virtual;
181 function GetIsNull: Boolean; virtual;
182 function GetIsNullable: boolean; virtual;
183 function GetAsVariant: Variant;
184 function GetModified: boolean; virtual;
185 function GetDateTimeStrLength(DateTimeFormat: TIBDateTimeFormats): integer;
186 function GetAsBCD: tBCD;
187 function GetSize: cardinal; virtual; abstract;
188 function GetCharSetWidth: integer; virtual; abstract;
189 procedure SetAsBoolean(AValue: boolean); virtual;
190 procedure SetAsCurrency(Value: Currency); virtual;
191 procedure SetAsInt64(Value: Int64); virtual;
192 procedure SetAsDate(Value: TDateTime); virtual;
193 procedure SetAsLong(Value: Long); virtual;
194 procedure SetAsTime(Value: TDateTime); overload;
195 procedure SetAsTime(aValue: TDateTime; OnDate: TDateTime;aTimeZoneID: TFBTimeZoneID); overload;
196 procedure SetAsTime(aValue: TDateTime; OnDate: TDateTime; aTimeZone: AnsiString); overload;
197 procedure SetAsDateTime(Value: TDateTime); overload;
198 procedure SetAsDateTime(aValue: TDateTime; aTimeZoneID: TFBTimeZoneID); overload;
199 procedure SetAsDateTime(aValue: TDateTime; aTimeZone: AnsiString); overload;
200 procedure SetAsUTCDateTime(aUTCTime: TDateTime);
201 procedure SetAsDouble(Value: Double); virtual;
202 procedure SetAsFloat(Value: Float); virtual;
203 procedure SetAsPointer(Value: Pointer);
204 procedure SetAsQuad(Value: TISC_QUAD);
205 procedure SetAsShort(Value: short); virtual;
206 procedure SetAsString(Value: AnsiString); virtual;
207 procedure SetAsVariant(Value: Variant);
208 procedure SetAsNumeric(Value: Int64; aScale: integer);
209 procedure SetAsBcd(aValue: tBCD); virtual;
210 procedure SetIsNull(Value: Boolean); virtual;
211 procedure SetIsNullable(Value: Boolean); virtual;
212 procedure SetName(aValue: AnsiString); virtual;
213 property AsDate: TDateTime read GetAsDateTime write SetAsDate;
214 property AsBoolean:boolean read GetAsBoolean write SetAsBoolean;
215 property AsTime: TDateTime read GetAsDateTime write SetAsTime;
216 property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
217 property AsDouble: Double read GetAsDouble write SetAsDouble;
218 property AsFloat: Float read GetAsFloat write SetAsFloat;
219 property AsCurrency: Currency read GetAsCurrency write SetAsCurrency;
220 property AsInt64: Int64 read GetAsInt64 write SetAsInt64;
221 property AsInteger: Integer read GetAsLong write SetAsInteger;
222 property AsLong: Long read GetAsLong write SetAsLong;
223 property AsPointer: Pointer read GetAsPointer write SetAsPointer;
224 property AsQuad: TISC_QUAD read GetAsQuad write SetAsQuad;
225 property AsShort: short read GetAsShort write SetAsShort;
226 property AsString: AnsiString read GetAsString write SetAsString;
227 property AsVariant: Variant read GetAsVariant write SetAsVariant;
228 property Modified: Boolean read getModified;
229 property IsNull: Boolean read GetIsNull write SetIsNull;
230 property IsNullable: Boolean read GetIsNullable write SetIsNullable;
231 property Scale: integer read GetScale write SetScale;
232 property SQLType: cardinal read GetSQLType write SetSQLType;
233 end;
234
235 TSQLVarData = class;
236
237 TStatementStatus = (ssPrepared, ssExecuteResults, ssCursorOpen, ssBOF, ssEOF);
238
239 { TSQLDataArea }
240
241 TSQLDataArea = class
242 private
243 FCaseSensitiveParams: boolean;
244 function GetColumn(index: integer): TSQLVarData;
245 function GetCount: integer;
246 protected
247 FUniqueRelationName: AnsiString;
248 FColumnList: array of TSQLVarData;
249 function GetStatement: IStatement; virtual; abstract;
250 function GetPrepareSeqNo: integer; virtual; abstract;
251 function GetTransactionSeqNo: integer; virtual; abstract;
252 procedure SetCount(aValue: integer); virtual; abstract;
253 procedure SetUniqueRelationName;
254 public
255 procedure Initialize; virtual;
256 function IsInputDataArea: boolean; virtual; abstract; {Input to Database}
257 procedure PreprocessSQL(sSQL: AnsiString; GenerateParamNames: boolean;
258 var sProcessedSQL: AnsiString);
259 function ColumnsInUseCount: integer; virtual;
260 function ColumnByName(Idx: AnsiString): TSQLVarData;
261 function CheckStatementStatus(Request: TStatementStatus): boolean; virtual; abstract;
262 procedure GetData(index: integer; var IsNull: boolean; var len: short;
263 var data: PByte); virtual;
264 procedure RowChange;
265 function StateChanged(var ChangeSeqNo: integer): boolean; virtual; abstract;
266 property CaseSensitiveParams: boolean read FCaseSensitiveParams
267 write FCaseSensitiveParams; {Only used when IsInputDataArea true}
268 function CanChangeMetaData: boolean; virtual; abstract;
269 property Count: integer read GetCount;
270 property Column[index: integer]: TSQLVarData read GetColumn;
271 property UniqueRelationName: AnsiString read FUniqueRelationName;
272 property Statement: IStatement read GetStatement;
273 property PrepareSeqNo: integer read GetPrepareSeqNo;
274 property TransactionSeqNo: integer read GetTransactionSeqNo;
275 end;
276
277 { TSQLVarData }
278
279 TSQLVarData = class
280 private
281 FParent: TSQLDataArea;
282 FName: AnsiString;
283 FIndex: integer;
284 FModified: boolean;
285 FUniqueName: boolean;
286 FVarString: RawByteString;
287 FColMetaData: IParamMetaData;
288 function GetStatement: IStatement;
289 procedure SetName(AValue: AnsiString);
290 protected
291 function GetAttachment: IAttachment; virtual; abstract;
292 function GetSQLType: cardinal; virtual; abstract;
293 function GetSubtype: integer; virtual; abstract;
294 function GetAliasName: AnsiString; virtual; abstract;
295 function GetFieldName: AnsiString; virtual; abstract;
296 function GetOwnerName: AnsiString; virtual; abstract;
297 function GetRelationName: AnsiString; virtual; abstract;
298 function GetScale: integer; virtual; abstract;
299 function GetCharSetID: cardinal; virtual; abstract;
300 function GetCharSetWidth: integer; virtual; abstract;
301 function GetCodePage: TSystemCodePage; virtual; abstract;
302 function GetIsNull: Boolean; virtual; abstract;
303 function GetIsNullable: boolean; virtual; abstract;
304 function GetSQLData: PByte; virtual; abstract;
305 function GetDataLength: cardinal; virtual; abstract; {current field length}
306 function GetSize: cardinal; virtual; abstract; {field length as given by metadata}
307 function GetDefaultTextSQLType: cardinal; virtual; abstract;
308 procedure SetIsNull(Value: Boolean); virtual; abstract;
309 procedure SetIsNullable(Value: Boolean); virtual; abstract;
310 procedure SetSQLData(AValue: PByte; len: cardinal); virtual; abstract;
311 procedure SetScale(aValue: integer); virtual; abstract;
312 procedure SetDataLength(len: cardinal); virtual; abstract;
313 procedure SetSQLType(aValue: cardinal); virtual; abstract;
314 procedure SetCharSetID(aValue: cardinal); virtual; abstract;
315 procedure SetMetaSize(aValue: cardinal); virtual;
316 public
317 constructor Create(aParent: TSQLDataArea; aIndex: integer);
318 procedure SetString(aValue: AnsiString);
319 procedure Changed; virtual;
320 procedure RowChange; virtual;
321 function GetAsArray(Array_ID: TISC_QUAD): IArray; virtual; abstract;
322 function GetAsBlob(Blob_ID: TISC_QUAD; BPB: IBPB): IBlob; virtual; abstract;
323 function CreateBlob: IBlob; virtual; abstract;
324 function GetArrayMetaData: IArrayMetaData; virtual; abstract;
325 function GetBlobMetaData: IBlobMetaData; virtual; abstract;
326 function getColMetadata: IParamMetaData;
327 procedure Initialize; virtual;
328 procedure SaveMetaData;
329
330 public
331 property AliasName: AnsiString read GetAliasName;
332 property FieldName: AnsiString read GetFieldName;
333 property OwnerName: AnsiString read GetOwnerName;
334 property RelationName: AnsiString read GetRelationName;
335 property Parent: TSQLDataArea read FParent;
336 property Index: integer read FIndex;
337 property Name: AnsiString read FName write SetName;
338 property CharSetID: cardinal read GetCharSetID write SetCharSetID;
339 property SQLType: cardinal read GetSQLType write SetSQLType;
340 property SQLSubtype: integer read GetSubtype;
341 property SQLData: PByte read GetSQLData;
342 property DataLength: cardinal read GetDataLength write SetDataLength;
343 property IsNull: Boolean read GetIsNull write SetIsNull;
344 property IsNullable: Boolean read GetIsNullable write SetIsNullable;
345 property Scale: integer read GetScale write SetScale;
346 public
347 property Modified: Boolean read FModified;
348 property Statement: IStatement read GetStatement;
349 property UniqueName: boolean read FUniqueName write FUniqueName;
350 end;
351
352 { TColumnMetaData }
353
354 TColumnMetaData = class(TSQLDataItem,IColumnMetaData)
355 private
356 FIBXSQLVAR: TSQLVarData;
357 FOwner: IUnknown; {Keep reference to ensure Metadata/statement not discarded}
358 FPrepareSeqNo: integer;
359 FChangeSeqNo: integer;
360 protected
361 procedure CheckActive; override;
362 function GetAttachment: IAttachment; override;
363 function SQLData: PByte; override;
364 function GetDataLength: cardinal; override;
365 function GetCodePage: TSystemCodePage; override;
366
367 public
368 constructor Create(aOwner: IUnknown; aIBXSQLVAR: TSQLVarData);
369 destructor Destroy; override;
370 function GetSQLDialect: integer; override;
371
372 public
373 {IColumnMetaData}
374 function GetIndex: integer;
375 function GetSQLType: cardinal; override;
376 function getSubtype: integer;
377 function getRelationName: AnsiString;
378 function getOwnerName: AnsiString;
379 function getSQLName: AnsiString; {Name of the column}
380 function getAliasName: AnsiString; {Alias Name of column or Column Name if not alias}
381 function GetName: AnsiString; override; {Disambiguated uppercase Field Name}
382 function GetScale: integer; override;
383 function getCharSetID: cardinal; override;
384 function GetIsNullable: boolean; override;
385 function GetSize: cardinal; override;
386 function GetCharSetWidth: integer; override;
387 function GetArrayMetaData: IArrayMetaData;
388 function GetBlobMetaData: IBlobMetaData;
389 function GetStatement: IStatement;
390 function GetTransaction: ITransaction; virtual;
391 property Name: AnsiString read GetName;
392 property Size: cardinal read GetSize;
393 property CharSetID: cardinal read getCharSetID;
394 property SQLSubtype: integer read getSubtype;
395 property IsNullable: Boolean read GetIsNullable;
396 public
397 property Statement: IStatement read GetStatement;
398 end;
399
400 { TIBSQLData }
401
402 TIBSQLData = class(TColumnMetaData,ISQLData)
403 private
404 FTransaction: ITransaction;
405 protected
406 procedure CheckActive; override;
407 public
408 function GetTransaction: ITransaction; override;
409 function GetIsNull: Boolean; override;
410 function GetAsArray: IArray;
411 function GetAsBlob: IBlob; overload;
412 function GetAsBlob(BPB: IBPB): IBlob; overload;
413 function GetAsString: AnsiString; override;
414 property AsBlob: IBlob read GetAsBlob;
415 end;
416
417 { TSQLParamMetaData }
418
419 TSQLParamMetaData = class(TFBInterfacedObject,IParamMetaData)
420 private
421 FSQLType: cardinal;
422 FSQLSubType: integer;
423 FScale: integer;
424 FCharSetID: cardinal;
425 FNullable: boolean;
426 FSize: cardinal;
427 FCodePage: TSystemCodePage;
428 public
429 constructor Create(src: TSQLVarData);
430 {IParamMetaData}
431 function GetSQLType: cardinal;
432 function GetSQLTypeName: AnsiString;
433 function getSubtype: integer;
434 function getScale: integer;
435 function getCharSetID: cardinal;
436 function getCodePage: TSystemCodePage;
437 function getIsNullable: boolean;
438 function GetSize: cardinal;
439 property SQLType: cardinal read GetSQLType;
440 end;
441
442 { TSQLParam }
443
444 TSQLParam = class(TIBSQLData,ISQLParam,ISQLData)
445 protected
446 procedure CheckActive; override;
447 procedure Changed; override;
448 procedure InternalSetAsString(Value: AnsiString); override;
449 procedure SetScale(aValue: integer); override;
450 procedure SetDataLength(len: cardinal); override;
451 procedure SetSQLType(aValue: cardinal); override;
452 public
453 procedure Clear;
454 function getColMetadata: IParamMetaData;
455 function GetModified: boolean; override;
456 function GetAsPointer: Pointer;
457 function GetAsString: AnsiString; override;
458 procedure SetName(Value: AnsiString); override;
459 procedure SetIsNull(Value: Boolean); override;
460 procedure SetIsNullable(Value: Boolean); override;
461 procedure SetAsArray(anArray: IArray);
462
463 {overrides}
464 procedure SetAsBoolean(AValue: boolean);
465 procedure SetAsCurrency(AValue: Currency);
466 procedure SetAsInt64(AValue: Int64);
467 procedure SetAsDate(AValue: TDateTime);
468 procedure SetAsLong(AValue: Long);
469 procedure SetAsTime(AValue: TDateTime); overload;
470 procedure SetAsTime(aValue: TDateTime; OnDate: TDateTime; aTimeZoneID: TFBTimeZoneID); overload;
471 procedure SetAsTime(aValue: TDateTime; OnDate: TDateTime; aTimeZone: AnsiString); overload;
472 procedure SetAsTime(aValue: TDateTime; aTimeZoneID: TFBTimeZoneID); overload;
473 procedure SetAsTime(aValue: TDateTime; aTimeZone: AnsiString); overload;
474 procedure SetAsDateTime(AValue: TDateTime); overload;
475 procedure SetAsDateTime(aValue: TDateTime; aTimeZoneID: TFBTimeZoneID); overload;
476 procedure SetAsDateTime(aValue: TDateTime; aTimeZone: AnsiString); overload;
477 procedure SetAsDouble(AValue: Double);
478 procedure SetAsFloat(AValue: Float);
479 procedure SetAsPointer(AValue: Pointer);
480 procedure SetAsShort(AValue: Short);
481 procedure SetAsString(AValue: AnsiString); override;
482 procedure SetAsVariant(AValue: Variant);
483 procedure SetAsBlob(aValue: IBlob);
484 procedure SetAsQuad(AValue: TISC_QUAD);
485 procedure SetCharSetID(aValue: cardinal);
486 procedure SetAsBcd(aValue: tBCD);
487
488 property AsBlob: IBlob read GetAsBlob write SetAsBlob;
489 property IsNullable: Boolean read GetIsNullable write SetIsNullable;
490 end;
491
492 { TMetaData }
493
494 TMetaData = class(TInterfaceOwner,IMetaData)
495 private
496 FPrepareSeqNo: integer;
497 FMetaData: TSQLDataArea;
498 FStatement: IStatement; {ensure FStatement not destroyed until no longer needed}
499 procedure CheckActive;
500 public
501 constructor Create(aMetaData: TSQLDataArea);
502 destructor Destroy; override;
503 public
504 {IMetaData}
505 function GetUniqueRelationName: AnsiString;
506 function getCount: integer;
507 function getColumnMetaData(index: integer): IColumnMetaData;
508 function ByName(Idx: AnsiString): IColumnMetaData;
509 end;
510
511 { TSQLParams }
512
513 TSQLParams = class(TInterfaceOwner,ISQLParams)
514 private
515 FPrepareSeqNo: integer;
516 FChangeSeqNo: integer;
517 FSQLParams: TSQLDataArea;
518 FStatement: IStatement; {ensure FStatement not destroyed until no longer needed}
519 procedure CheckActive;
520 public
521 constructor Create(aSQLParams: TSQLDataArea);
522 destructor Destroy; override;
523 public
524 {ISQLParams}
525 function getCount: integer;
526 function getSQLParam(index: integer): ISQLParam;
527 function ByName(Idx: AnsiString): ISQLParam ;
528 function GetModified: Boolean;
529 function GetHasCaseSensitiveParams: Boolean;
530 end;
531
532 { TResults }
533
534 TResults = class(TInterfaceOwner,IResults)
535 private
536 FPrepareSeqNo: integer;
537 FTransactionSeqNo: integer;
538 FChangeSeqNo: integer;
539 FResults: TSQLDataArea;
540 FStatement: IStatement; {ensure FStatement not destroyed until no longer needed}
541 function GetISQLData(aIBXSQLVAR: TSQLVarData): ISQLData;
542 protected
543 procedure CheckActive;
544 public
545 constructor Create(aResults: TSQLDataArea);
546 {IResults}
547 function getCount: integer;
548 function ByName(Idx: AnsiString): ISQLData;
549 function getSQLData(index: integer): ISQLData;
550 procedure GetData(index: integer; var IsNull:boolean; var len: short; var data: PByte);
551 function GetStatement: IStatement;
552 function GetTransaction: ITransaction; virtual;
553 procedure SetRetainInterfaces(aValue: boolean);
554 end;
555
556 implementation
557
558 uses FBMessages, variants, IBUtils, FBTransaction, DateUtils;
559
560 { TSQLParamMetaData }
561
562 constructor TSQLParamMetaData.Create(src: TSQLVarData);
563 begin
564 inherited Create;
565 FSQLType := src.GetSQLType;
566 FSQLSubType := src.getSubtype;
567 FScale := src.GetScale;
568 FCharSetID := src.getCharSetID;
569 FNullable := src.GetIsNullable;
570 FSize := src.GetSize;
571 FCodePage := src.GetCodePage;
572 end;
573
574 function TSQLParamMetaData.GetSQLType: cardinal;
575 begin
576 Result := FSQLType;
577 end;
578
579 function TSQLParamMetaData.GetSQLTypeName: AnsiString;
580 begin
581 Result := TSQLDataItem.GetSQLTypeName(FSQLType);
582 end;
583
584 function TSQLParamMetaData.getSubtype: integer;
585 begin
586 Result := FSQLSubType;
587 end;
588
589 function TSQLParamMetaData.getScale: integer;
590 begin
591 Result := FScale;
592 end;
593
594 function TSQLParamMetaData.getCharSetID: cardinal;
595 begin
596 Result := FCharSetID;
597 end;
598
599 function TSQLParamMetaData.getCodePage: TSystemCodePage;
600 begin
601 Result := FCodePage;
602 end;
603
604 function TSQLParamMetaData.getIsNullable: boolean;
605 begin
606 Result := FNullable;
607 end;
608
609 function TSQLParamMetaData.GetSize: cardinal;
610 begin
611 Result := FSize;
612 end;
613
614 { TSQLDataArea }
615
616 function TSQLDataArea.GetColumn(index: integer): TSQLVarData;
617 begin
618 if (index < 0) or (index >= Count) then
619 IBError(ibxeInvalidColumnIndex,[nil]);
620 Result := FColumnList[index];
621 end;
622
623 function TSQLDataArea.GetCount: integer;
624 begin
625 Result := Length(FColumnList);
626 end;
627
628 procedure TSQLDataArea.SetUniqueRelationName;
629 var
630 i: Integer;
631 bUnique: Boolean;
632 RelationName: AnsiString;
633 begin
634 bUnique := True;
635 for i := 0 to ColumnsInUseCount - 1 do
636 begin
637 RelationName := Column[i].RelationName;
638
639 {First get the unique relation name, if any}
640
641 if bUnique and (RelationName <> '') then
642 begin
643 if FUniqueRelationName = '' then
644 FUniqueRelationName := RelationName
645 else
646 if RelationName <> FUniqueRelationName then
647 begin
648 FUniqueRelationName := '';
649 bUnique := False;
650 end;
651 end;
652 end;
653 end;
654
655 procedure TSQLDataArea.Initialize;
656 var
657 i: Integer;
658 begin
659 for i := 0 to ColumnsInUseCount - 1 do
660 Column[i].Initialize;
661 end;
662
663 procedure TSQLDataArea.PreprocessSQL(sSQL: AnsiString; GenerateParamNames: boolean;
664 var sProcessedSQL: AnsiString);
665
666 var slNames: TStrings;
667
668 procedure SetColumnNames(slNames: TStrings);
669 var i, j: integer;
670 found: boolean;
671 begin
672 found := false;
673 SetCount(slNames.Count);
674 for i := 0 to slNames.Count - 1 do
675 begin
676 Column[i].Name := slNames[i];
677 Column[i].UniqueName := (slNames.Objects[i] <> nil);
678 end;
679 for i := 0 to Count - 1 do
680 begin
681 if not Column[i].UniqueName then
682 begin
683 found := false;
684 for j := i + 1 to Count - 1 do
685 if Column[i].Name = Column[j].Name then
686 begin
687 found := true;
688 break;
689 end;
690 Column[i].UniqueName := not found;
691 end;
692 end;
693 end;
694
695 begin
696 if not IsInputDataArea then
697 IBError(ibxeNotPermitted,[nil]);
698
699 slNames := TStringList.Create;
700 try
701 sProcessedSQL := TSQLParamProcessor.Execute(sSQL,GenerateParamNames,slNames);
702 SetColumnNames(slNames);
703 finally
704 slNames.Free;
705 end;
706 end;
707
708 function TSQLDataArea.ColumnsInUseCount: integer;
709 begin
710 Result := Count;
711 end;
712
713 function TSQLDataArea.ColumnByName(Idx: AnsiString): TSQLVarData;
714 var
715 s: AnsiString;
716 i: Integer;
717 begin
718 if not IsInputDataArea or not CaseSensitiveParams then
719 s := AnsiUpperCase(Idx)
720 else
721 s := Idx;
722
723 for i := 0 to Count - 1 do
724 if Column[i].Name = s then
725 begin
726 Result := Column[i];
727 Exit;
728 end;
729 Result := nil;
730 end;
731
732 procedure TSQLDataArea.GetData(index: integer; var IsNull: boolean;
733 var len: short; var data: PByte);
734 begin
735 //Do Nothing
736 end;
737
738 procedure TSQLDataArea.RowChange;
739 var i: integer;
740 begin
741 for i := 0 to Count - 1 do
742 Column[i].RowChange;
743 end;
744
745 {TSQLVarData}
746
747 function TSQLVarData.GetStatement: IStatement;
748 begin
749 Result := FParent.Statement;
750 end;
751
752 procedure TSQLVarData.SetName(AValue: AnsiString);
753 begin
754 if not Parent.IsInputDataArea or not Parent.CaseSensitiveParams then
755 FName := AnsiUpperCase(AValue)
756 else
757 FName := AValue;
758 end;
759
760 procedure TSQLVarData.SetMetaSize(aValue: cardinal);
761 begin
762 //Ignore
763 end;
764
765 procedure TSQLVarData.SaveMetaData;
766 begin
767 FColMetaData := TSQLParamMetaData.Create(self);
768 end;
769
770 constructor TSQLVarData.Create(aParent: TSQLDataArea; aIndex: integer);
771 begin
772 inherited Create;
773 FParent := aParent;
774 FIndex := aIndex;
775 FUniqueName := true;
776 end;
777
778 procedure TSQLVarData.SetString(aValue: AnsiString);
779 begin
780 {we take full advantage here of reference counted strings. When setting a string
781 value, a reference is kept in FVarString and a pointer to it placed in the
782 SQLVar. This avoids string copies. Note that PAnsiChar is guaranteed to point to
783 a zero byte when the string is empty, neatly avoiding a nil pointer error.}
784
785 FVarString := aValue;
786 if SQLType = SQL_BLOB then
787 SetMetaSize(GetAttachment.GetInlineBlobLimit);
788 SQLType := GetDefaultTextSQLType;
789 Scale := 0;
790 SetSQLData(PByte(PAnsiChar(FVarString)),Length(aValue));
791 end;
792
793 procedure TSQLVarData.Changed;
794 begin
795 FModified := true;
796 end;
797
798 procedure TSQLVarData.RowChange;
799 begin
800 FModified := false;
801 FVarString := '';
802 end;
803
804 function TSQLVarData.getColMetadata: IParamMetaData;
805 begin
806 Result := FColMetaData;
807 end;
808
809 procedure TSQLVarData.Initialize;
810
811 function FindVarByName(idx: AnsiString; limit: integer): TSQLVarData;
812 var
813 k: integer;
814 begin
815 for k := 0 to limit do
816 if Parent.Column[k].Name = idx then
817 begin
818 Result := Parent.Column[k];
819 Exit;
820 end;
821 Result := nil;
822 end;
823
824 var
825 j, j_len: Integer;
826 st: AnsiString;
827 sBaseName: AnsiString;
828 begin
829 RowChange;
830
831 {If an output SQLDA then copy the aliasname to the FName. Ensure
832 that they are all upper case only and disambiguated.
833 }
834
835 if not Parent.IsInputDataArea then
836 begin
837 st := Space2Underscore(AnsiUppercase(AliasName));
838 if st = '' then
839 begin
840 sBaseName := 'F_'; {do not localize}
841 j := 1; j_len := 1;
842 st := sBaseName + IntToStr(j);
843 end
844 else
845 begin
846 j := 0; j_len := 0;
847 sBaseName := st;
848 end;
849
850 {Look for other columns with the same name and make unique}
851
852 while FindVarByName(st,Index-1) <> nil do
853 begin
854 Inc(j);
855 j_len := Length(IntToStr(j));
856 if j_len + Length(sBaseName) > 31 then
857 st := system.Copy(sBaseName, 1, 31 - j_len) + IntToStr(j)
858 else
859 st := sBaseName + IntToStr(j);
860 end;
861
862 Name := st;
863 end;
864 end;
865
866 {TSQLDataItem}
867
868 function TSQLDataItem.AdjustScale(Value: Int64; aScale: Integer): Double;
869 var
870 Scaling : Int64;
871 i: Integer;
872 Val: Double;
873 begin
874 Scaling := 1; Val := Value;
875 if aScale > 0 then
876 begin
877 for i := 1 to aScale do
878 Scaling := Scaling * 10;
879 result := Val * Scaling;
880 end
881 else
882 if aScale < 0 then
883 begin
884 for i := -1 downto aScale do
885 Scaling := Scaling * 10;
886 result := Val / Scaling;
887 end
888 else
889 result := Val;
890 end;
891
892 function TSQLDataItem.AdjustScaleToInt64(Value: Int64; aScale: Integer): Int64;
893 var
894 Scaling : Int64;
895 i: Integer;
896 Val: Int64;
897 begin
898 Scaling := 1; Val := Value;
899 if aScale > 0 then begin
900 for i := 1 to aScale do Scaling := Scaling * 10;
901 result := Val * Scaling;
902 end else if aScale < 0 then begin
903 for i := -1 downto aScale do Scaling := Scaling * 10;
904 result := Val div Scaling;
905 end else
906 result := Val;
907 end;
908
909 function TSQLDataItem.AdjustScaleToCurrency(Value: Int64; aScale: Integer
910 ): Currency;
911 var
912 Scaling : Int64;
913 i : Integer;
914 FractionText, PadText, CurrText: AnsiString;
915 begin
916 Result := 0;
917 Scaling := 1;
918 PadText := '';
919 if aScale > 0 then
920 begin
921 for i := 1 to aScale do
922 Scaling := Scaling * 10;
923 result := Value * Scaling;
924 end
925 else
926 if aScale < 0 then
927 begin
928 for i := -1 downto aScale do
929 Scaling := Scaling * 10;
930 FractionText := IntToStr(abs(Value mod Scaling));
931 for i := Length(FractionText) to -aScale -1 do
932 PadText := '0' + PadText;
933 {$IF declared(DefaultFormatSettings)}
934 with DefaultFormatSettings do
935 {$ELSE}
936 {$IF declared(FormatSettings)}
937 with FormatSettings do
938 {$IFEND}
939 {$IFEND}
940 if Value < 0 then
941 CurrText := '-' + IntToStr(Abs(Value div Scaling)) + DecimalSeparator + PadText + FractionText
942 else
943 CurrText := IntToStr(Abs(Value div Scaling)) + DecimalSeparator + PadText + FractionText;
944 try
945 result := StrToCurr(CurrText);
946 except
947 on E: Exception do
948 IBError(ibxeInvalidDataConversion, [nil]);
949 end;
950 end
951 else
952 result := Value;
953 end;
954
955 function TSQLDataItem.GetDateFormatStr(IncludeTime: boolean): AnsiString;
956 begin
957 {$IF declared(DefaultFormatSettings)}
958 with DefaultFormatSettings do
959 {$ELSE}
960 {$IF declared(FormatSettings)}
961 with FormatSettings do
962 {$IFEND}
963 {$IFEND}
964 case GetSQLDialect of
965 1:
966 if IncludeTime then
967 result := ShortDateFormat + ' ' + LongTimeFormat
968 else
969 result := ShortDateFormat;
970 3:
971 result := ShortDateFormat;
972 end;
973 end;
974
975 function TSQLDataItem.GetTimeFormatStr: AnsiString;
976 begin
977 {$IF declared(DefaultFormatSettings)}
978 with DefaultFormatSettings do
979 {$ELSE}
980 {$IF declared(FormatSettings)}
981 with FormatSettings do
982 {$IFEND}
983 {$IFEND}
984 Result := 'hh' + TimeSeparator + 'nn' + TimeSeparator + 'ss' + '.zzzz';;
985 end;
986
987 function TSQLDataItem.GetTimestampFormatStr: AnsiString;
988 begin
989 {$IF declared(DefaultFormatSettings)}
990 with DefaultFormatSettings do
991 {$ELSE}
992 {$IF declared(FormatSettings)}
993 with FormatSettings do
994 {$IFEND}
995 {$IFEND}
996 Result := ShortDateFormat + ' ' + 'hh' + TimeSeparator + 'nn' + TimeSeparator + 'ss' + '.zzzz';
997 end;
998
999 procedure TSQLDataItem.SetAsInteger(AValue: Integer);
1000 begin
1001 SetAsLong(aValue);
1002 end;
1003
1004 procedure TSQLDataItem.InternalGetAsDateTime(var aDateTime: TDateTime;
1005 var dstOffset: smallint; var aTimezone: AnsiString;
1006 var aTimeZoneID: TFBTimeZoneID);
1007 begin
1008 CheckActive;
1009 aDateTime := 0;
1010 dstOffset := 0;
1011 aTimezone := '';
1012 aTimeZoneID := TimeZoneID_GMT;
1013 if not IsNull then
1014 with FFirebirdClientAPI do
1015 case SQLType of
1016 SQL_TEXT, SQL_VARYING:
1017 if not ParseDateTimeTZString(AsString,aDateTime,aTimeZone) then
1018 IBError(ibxeInvalidDataConversion, [nil]);
1019 SQL_TYPE_DATE:
1020 aDateTime := SQLDecodeDate(SQLData);
1021 SQL_TYPE_TIME:
1022 aDateTime := SQLDecodeTime(SQLData);
1023 SQL_TIMESTAMP:
1024 aDateTime := SQLDecodeDateTime(SQLData);
1025 SQL_TIMESTAMP_TZ:
1026 begin
1027 GetTimeZoneServices.DecodeTimestampTZ(SQLData,aDateTime,dstOffset,aTimeZone);
1028 aTimeZoneID := PISC_TIMESTAMP_TZ(SQLData)^.time_zone;
1029 end;
1030 SQL_TIMESTAMP_TZ_EX:
1031 begin
1032 GetTimeZoneServices.DecodeTimestampTZEx(SQLData,aDateTime,dstOffset,aTimeZone);
1033 aTimeZoneID := PISC_TIMESTAMP_TZ_EX(SQLData)^.time_zone;
1034 end;
1035 SQL_TIME_TZ:
1036 with GetTimeZoneServices do
1037 begin
1038 DecodeTimeTZ(SQLData,GetTimeTZDate,aDateTime,dstOffset,aTimeZone);
1039 aTimeZoneID := PISC_TIME_TZ(SQLData)^.time_zone;
1040 end;
1041 SQL_TIME_TZ_EX:
1042 with GetTimeZoneServices do
1043 begin
1044 DecodeTimeTZEx(SQLData,GetTimeTZDate,aDateTime,dstOffset,aTimeZone);
1045 aTimeZoneID := PISC_TIME_TZ_EX(SQLData)^.time_zone;
1046 end;
1047 else
1048 IBError(ibxeInvalidDataConversion, [nil]);
1049 end;
1050 end;
1051
1052 function TSQLDataItem.AdjustScaleFromCurrency(Value: Currency; aScale: Integer
1053 ): Int64;
1054 var
1055 Scaling : Int64;
1056 i : Integer;
1057 begin
1058 Result := 0;
1059 Scaling := 1;
1060 if aScale < 0 then
1061 begin
1062 for i := -1 downto aScale do
1063 Scaling := Scaling * 10;
1064 result := trunc(Value * Scaling);
1065 end
1066 else
1067 if aScale > 0 then
1068 begin
1069 for i := 1 to aScale do
1070 Scaling := Scaling * 10;
1071 result := trunc(Value / Scaling);
1072 end
1073 else
1074 result := trunc(Value);
1075 end;
1076
1077 function TSQLDataItem.AdjustScaleFromDouble(Value: Double; aScale: Integer
1078 ): Int64;
1079 var
1080 Scaling : Int64;
1081 i : Integer;
1082 begin
1083 Result := 0;
1084 Scaling := 1;
1085 if aScale < 0 then
1086 begin
1087 for i := -1 downto aScale do
1088 Scaling := Scaling * 10;
1089 result := trunc(Value * Scaling);
1090 end
1091 else
1092 if aScale > 0 then
1093 begin
1094 for i := 1 to aScale do
1095 Scaling := Scaling * 10;
1096 result := trunc(Value / Scaling);
1097 end
1098 else
1099 result := trunc(Value);
1100 // writeln('Adjusted ',Value,' to ',Result);
1101 end;
1102
1103 procedure TSQLDataItem.CheckActive;
1104 begin
1105 //Do nothing by default
1106 end;
1107
1108 procedure TSQLDataItem.CheckTZSupport;
1109 begin
1110 if not FFirebirdClientAPI.HasTimeZoneSupport then
1111 IBError(ibxeNoTimezoneSupport,[]);
1112 end;
1113
1114 function TSQLDataItem.GetTimeZoneServices: IExTimeZoneServices;
1115 begin
1116 if FTimeZoneServices = nil then
1117 begin
1118 if not GetAttachment.HasTimeZoneSupport then
1119 IBError(ibxeNoTimezoneSupport,[]);
1120 GetAttachment.GetTimeZoneServices.QueryInterface(IExTimeZoneServices,FTimeZoneServices);
1121 end;
1122 Result := FTimeZoneServices;
1123 end;
1124
1125 procedure TSQLDataItem.Changed;
1126 begin
1127 //Do nothing by default
1128 end;
1129
1130 procedure TSQLDataItem.Changing;
1131 begin
1132 //Do nothing by default
1133 end;
1134
1135 procedure TSQLDataItem.InternalSetAsString(Value: AnsiString);
1136 begin
1137 //Do nothing by default
1138 end;
1139
1140 function TSQLDataItem.Transliterate(s: AnsiString; CodePage: TSystemCodePage
1141 ): RawByteString;
1142 begin
1143 Result := s;
1144 if StringCodePage(Result) <> CodePage then
1145 SetCodePage(Result,CodePage,CodePage <> CP_NONE);
1146 end;
1147
1148 procedure TSQLDataItem.SetScale(aValue: integer);
1149 begin
1150 //Do nothing by default
1151 end;
1152
1153 procedure TSQLDataItem.SetDataLength(len: cardinal);
1154 begin
1155 //Do nothing by default
1156 end;
1157
1158 procedure TSQLDataItem.SetSQLType(aValue: cardinal);
1159 begin
1160 //Do nothing by default
1161 end;
1162
1163 constructor TSQLDataItem.Create(api: TFBClientAPI);
1164 begin
1165 inherited Create;
1166 FFirebirdClientAPI := api;
1167 end;
1168
1169 function TSQLDataItem.GetSQLTypeName: AnsiString;
1170 begin
1171 Result := GetSQLTypeName(GetSQLType);
1172 end;
1173
1174 class function TSQLDataItem.GetSQLTypeName(SQLType: cardinal): AnsiString;
1175 begin
1176 Result := 'Unknown';
1177 case SQLType of
1178 SQL_VARYING: Result := 'SQL_VARYING';
1179 SQL_TEXT: Result := 'SQL_TEXT';
1180 SQL_DOUBLE: Result := 'SQL_DOUBLE';
1181 SQL_FLOAT: Result := 'SQL_FLOAT';
1182 SQL_LONG: Result := 'SQL_LONG';
1183 SQL_SHORT: Result := 'SQL_SHORT';
1184 SQL_TIMESTAMP: Result := 'SQL_TIMESTAMP';
1185 SQL_TIMESTAMP_TZ: Result := 'SQL_TIMESTAMP_TZ';
1186 SQL_TIMESTAMP_TZ_EX: Result := 'SQL_TIMESTAMP_TZ_EX';
1187 SQL_BLOB: Result := 'SQL_BLOB';
1188 SQL_D_FLOAT: Result := 'SQL_D_FLOAT';
1189 SQL_ARRAY: Result := 'SQL_ARRAY';
1190 SQL_QUAD: Result := 'SQL_QUAD';
1191 SQL_TYPE_TIME: Result := 'SQL_TYPE_TIME';
1192 SQL_TYPE_DATE: Result := 'SQL_TYPE_DATE';
1193 SQL_INT64: Result := 'SQL_INT64';
1194 SQL_TIME_TZ: Result := 'SQL_TIME_TZ';
1195 SQL_TIME_TZ_EX: Result := 'SQL_TIME_TZ_EX';
1196 SQL_DEC_FIXED: Result := 'SQL_DEC_FIXED';
1197 SQL_DEC16: Result := 'SQL_DEC16';
1198 SQL_DEC34: Result := 'SQL_DEC34';
1199 SQL_INT128: Result := 'SQL_INT128';
1200 SQL_NULL: Result := 'SQL_NULL';
1201 SQL_BOOLEAN: Result := 'SQL_BOOLEAN';
1202 end;
1203 end;
1204
1205 function TSQLDataItem.GetStrDataLength: short;
1206 begin
1207 with FFirebirdClientAPI do
1208 if SQLType = SQL_VARYING then
1209 Result := DecodeInteger(SQLData, 2)
1210 else
1211 Result := DataLength;
1212 end;
1213
1214 function TSQLDataItem.GetAsBoolean: boolean;
1215 begin
1216 CheckActive;
1217 result := false;
1218 if not IsNull then
1219 begin
1220 if SQLType = SQL_BOOLEAN then
1221 result := PByte(SQLData)^ = ISC_TRUE
1222 else
1223 IBError(ibxeInvalidDataConversion, [nil]);
1224 end
1225 end;
1226
1227 function TSQLDataItem.GetAsCurrency: Currency;
1228 begin
1229 CheckActive;
1230 result := 0;
1231 if GetSQLDialect < 3 then
1232 result := GetAsDouble
1233 else begin
1234 if not IsNull then
1235 case SQLType of
1236 SQL_TEXT, SQL_VARYING: begin
1237 try
1238 result := StrtoCurr(AsString);
1239 except
1240 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
1241 end;
1242 end;
1243 SQL_SHORT:
1244 result := AdjustScaleToCurrency(Int64(PShort(SQLData)^),
1245 Scale);
1246 SQL_LONG:
1247 result := AdjustScaleToCurrency(Int64(PLong(SQLData)^),
1248 Scale);
1249 SQL_INT64:
1250 result := AdjustScaleToCurrency(PInt64(SQLData)^,
1251 Scale);
1252 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1253 result := Round(AsDouble);
1254
1255 SQL_DEC_FIXED,
1256 SQL_DEC16,
1257 SQL_DEC34,
1258 SQL_INT128:
1259 if not BCDToCurr(GetAsBCD,Result) then
1260 IBError(ibxeInvalidDataConversion, [nil]);
1261
1262 else
1263 IBError(ibxeInvalidDataConversion, [nil]);
1264 end;
1265 end;
1266 end;
1267
1268 function TSQLDataItem.GetAsInt64: Int64;
1269 begin
1270 CheckActive;
1271 result := 0;
1272 if not IsNull then
1273 case SQLType of
1274 SQL_TEXT, SQL_VARYING: begin
1275 try
1276 result := StrToInt64(AsString);
1277 except
1278 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
1279 end;
1280 end;
1281 SQL_SHORT:
1282 result := AdjustScaleToInt64(Int64(PShort(SQLData)^),
1283 Scale);
1284 SQL_LONG:
1285 result := AdjustScaleToInt64(Int64(PLong(SQLData)^),
1286 Scale);
1287 SQL_INT64:
1288 result := AdjustScaleToInt64(PInt64(SQLData)^,
1289 Scale);
1290 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1291 result := Round(AsDouble);
1292 else
1293 IBError(ibxeInvalidDataConversion, [nil]);
1294 end;
1295 end;
1296
1297 function TSQLDataItem.GetAsDateTime: TDateTime;
1298 var aTimezone: AnsiString;
1299 aTimeZoneID: TFBTimeZoneID;
1300 dstOffset: smallint;
1301 begin
1302 InternalGetAsDateTime(Result,dstOffset,aTimeZone,aTimeZoneID);
1303 end;
1304
1305 procedure TSQLDataItem.GetAsDateTime(var aDateTime: TDateTime;
1306 var dstOffset: smallint; var aTimezone: AnsiString);
1307 var aTimeZoneID: TFBTimeZoneID;
1308 begin
1309 InternalGetAsDateTime(aDateTime,dstOffset,aTimeZone,aTimeZoneID);
1310 end;
1311
1312 procedure TSQLDataItem.GetAsDateTime(var aDateTime: TDateTime; var dstOffset: smallint;
1313 var aTimezoneID: TFBTimeZoneID);
1314 var aTimezone: AnsiString;
1315 begin
1316 InternalGetAsDateTime(aDateTime,dstOffset,aTimeZone,aTimeZoneID);
1317 end;
1318
1319 procedure TSQLDataItem.GetAsTime(var aTime: TDateTime; var dstOffset: smallint;
1320 var aTimezoneID: TFBTimeZoneID; OnDate: TDateTime);
1321 var aTimeZone: AnsiString;
1322 begin
1323 CheckActive;
1324 aTime := 0;
1325 dstOffset := 0;
1326 if not IsNull then
1327 with FFirebirdClientAPI do
1328 case SQLType of
1329 SQL_TIME_TZ:
1330 begin
1331 GetTimeZoneServices.DecodeTimeTZ(SQLData,OnDate,aTime,dstOffset,aTimeZone);
1332 aTimeZoneID := PISC_TIME_TZ(SQLData)^.time_zone;
1333 end;
1334 SQL_TIME_TZ_EX:
1335 begin
1336 GetTimeZoneServices.DecodeTimeTZEx(SQLData,OnDate,aTime,dstOffset,aTimeZone);
1337 aTimeZoneID := PISC_TIME_TZ_EX(SQLData)^.time_zone;
1338 end;
1339 else
1340 IBError(ibxeInvalidDataConversion, [nil]);
1341 end;
1342 end;
1343
1344 procedure TSQLDataItem.GetAsTime(var aTime: TDateTime; var dstOffset: smallint;
1345 var aTimezone: AnsiString; OnDate: TDateTime);
1346 begin
1347 CheckActive;
1348 aTime := 0;
1349 dstOffset := 0;
1350 if not IsNull then
1351 with FFirebirdClientAPI do
1352 case SQLType of
1353 SQL_TIME_TZ:
1354 GetTimeZoneServices.DecodeTimeTZ(SQLData,OnDate,aTime,dstOffset,aTimeZone);
1355 SQL_TIME_TZ_EX:
1356 GetTimeZoneServices.DecodeTimeTZEx(SQLData,OnDate,aTime,dstOffset,aTimeZone);
1357 else
1358 IBError(ibxeInvalidDataConversion, [nil]);
1359 end;
1360 end;
1361
1362 procedure TSQLDataItem.GetAsTime(var aTime: TDateTime; var dstOffset: smallint;
1363 var aTimezoneID: TFBTimeZoneID);
1364 begin
1365 GetAsTime(aTime,dstOffset,aTimeZoneID,GetTimeZoneServices.GetTimeTZDate);
1366 end;
1367
1368 procedure TSQLDataItem.GetAsTime(var aTime: TDateTime; var dstOffset: smallint;
1369 var aTimezone: AnsiString);
1370 begin
1371 GetAsTime(aTime,dstOffset,aTimeZone,GetTimeZoneServices.GetTimeTZDate);
1372 end;
1373
1374 function TSQLDataItem.GetAsUTCDateTime: TDateTime;
1375 var aTimezone: AnsiString;
1376 begin
1377 CheckActive;
1378 result := 0;
1379 aTimezone := '';
1380 if not IsNull then
1381 with FFirebirdClientAPI do
1382 case SQLType of
1383 SQL_TEXT, SQL_VARYING:
1384 begin
1385 if not ParseDateTimeTZString(AsString,Result,aTimeZone) then
1386 IBError(ibxeInvalidDataConversion, [nil]);
1387 Result := GetTimeZoneServices.LocalTimeToGMT(Result,aTimeZone);
1388 end;
1389 SQL_TYPE_DATE:
1390 result := SQLDecodeDate(SQLData);
1391 SQL_TYPE_TIME,
1392 SQL_TIME_TZ,
1393 SQL_TIME_TZ_EX:
1394 result := SQLDecodeTime(SQLData);
1395 SQL_TIMESTAMP,
1396 SQL_TIMESTAMP_TZ,
1397 SQL_TIMESTAMP_TZ_EX:
1398 result := SQLDecodeDateTime(SQLData);
1399 else
1400 IBError(ibxeInvalidDataConversion, [nil]);
1401 end;
1402 end;
1403
1404 function TSQLDataItem.GetAsDouble: Double;
1405 begin
1406 CheckActive;
1407 result := 0;
1408 if not IsNull then begin
1409 case SQLType of
1410 SQL_TEXT, SQL_VARYING: begin
1411 try
1412 result := StrToFloat(AsString);
1413 except
1414 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
1415 end;
1416 end;
1417 SQL_SHORT:
1418 result := AdjustScale(Int64(PShort(SQLData)^),
1419 Scale);
1420 SQL_LONG:
1421 result := AdjustScale(Int64(PLong(SQLData)^),
1422 Scale);
1423 SQL_INT64:
1424 result := AdjustScale(PInt64(SQLData)^, Scale);
1425 SQL_FLOAT:
1426 result := PFloat(SQLData)^;
1427 SQL_DOUBLE, SQL_D_FLOAT:
1428 result := PDouble(SQLData)^;
1429 SQL_DEC_FIXED,
1430 SQL_DEC16,
1431 SQL_DEC34,
1432 SQL_INT128:
1433 Result := BCDToDouble(GetAsBCD);
1434 else
1435 IBError(ibxeInvalidDataConversion, [nil]);
1436 end;
1437 if Scale <> 0 then
1438 result :=
1439 StrToFloat(FloatToStrF(result, fffixed, 15,
1440 Abs(Scale) ));
1441 end;
1442 end;
1443
1444 function TSQLDataItem.GetAsFloat: Float;
1445 begin
1446 CheckActive;
1447 result := 0;
1448 try
1449 result := AsDouble;
1450 except
1451 on E: EOverflow do
1452 IBError(ibxeInvalidDataConversion, [nil]);
1453 end;
1454 end;
1455
1456 function TSQLDataItem.GetAsLong: Long;
1457 begin
1458 CheckActive;
1459 result := 0;
1460 if not IsNull then
1461 case SQLType of
1462 SQL_TEXT, SQL_VARYING: begin
1463 try
1464 result := StrToInt(AsString);
1465 except
1466 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
1467 end;
1468 end;
1469 SQL_SHORT:
1470 result := Round(AdjustScale(Int64(PShort(SQLData)^),
1471 Scale));
1472 SQL_LONG:
1473 result := Round(AdjustScale(Int64(PLong(SQLData)^),
1474 Scale));
1475 SQL_INT64:
1476 result := Round(AdjustScale(PInt64(SQLData)^, Scale));
1477 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1478 result := Round(AsDouble);
1479 SQL_DEC_FIXED,
1480 SQL_DEC16,
1481 SQL_DEC34,
1482 SQL_INT128:
1483 Result := BCDToInteger(GetAsBCD);
1484 else
1485 IBError(ibxeInvalidDataConversion, [GetSQLTypeName]);
1486 end;
1487 end;
1488
1489 function TSQLDataItem.GetAsPointer: Pointer;
1490 begin
1491 CheckActive;
1492 if not IsNull then
1493 result := SQLData
1494 else
1495 result := nil;
1496 end;
1497
1498 function TSQLDataItem.GetAsQuad: TISC_QUAD;
1499 begin
1500 CheckActive;
1501 result.gds_quad_high := 0;
1502 result.gds_quad_low := 0;
1503 if not IsNull then
1504 case SQLType of
1505 SQL_BLOB, SQL_ARRAY, SQL_QUAD:
1506 result := PISC_QUAD(SQLData)^;
1507 else
1508 IBError(ibxeInvalidDataConversion, [nil]);
1509 end;
1510 end;
1511
1512 function TSQLDataItem.GetAsShort: short;
1513 begin
1514 CheckActive;
1515 result := 0;
1516 try
1517 result := AsLong;
1518 except
1519 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
1520 end;
1521 end;
1522
1523 {Copied from LazUTF8}
1524
1525 function UTF8CodepointSizeFull(p: PAnsiChar): integer;
1526 const TopBitSetMask = $80; {%10000000}
1527 Top2BitsSetMask = $C0; {%11000000}
1528 Top3BitsSetMask = $E0; {%11100000}
1529 Top4BitsSetMask = $F0; {%11110000}
1530 Top5BitsSetMask = $F8; {%11111000}
1531 begin
1532 case p^ of
1533 #0..#191: // %11000000
1534 // regular single byte character (#0 is a character, this is Pascal ;)
1535 Result:=1;
1536 #192..#223: // p^ and %11100000 = %11000000
1537 begin
1538 // could be 2 byte character
1539 if (ord(p[1]) and Top2BitsSetMask) = TopBitSetMask then
1540 Result:=2
1541 else
1542 Result:=1;
1543 end;
1544 #224..#239: // p^ and %11110000 = %11100000
1545 begin
1546 // could be 3 byte character
1547 if ((ord(p[1]) and Top2BitsSetMask) = TopBitSetMask)
1548 and ((ord(p[2]) and Top2BitsSetMask) = TopBitSetMask) then
1549 Result:=3
1550 else
1551 Result:=1;
1552 end;
1553 #240..#247: // p^ and %11111000 = %11110000
1554 begin
1555 // could be 4 byte character
1556 if ((ord(p[1]) and Top2BitsSetMask) = TopBitSetMask)
1557 and ((ord(p[2]) and Top2BitsSetMask) = TopBitSetMask)
1558 and ((ord(p[3]) and Top2BitsSetMask) = TopBitSetMask) then
1559 Result:=4
1560 else
1561 Result:=1;
1562 end;
1563 else
1564 Result:=1;
1565 end;
1566 end;
1567
1568 {Returns the byte length of a UTF8 string with a fixed charwidth}
1569
1570 function GetStrLen(p: PAnsiChar; FieldWidth, MaxDataLength: cardinal): integer;
1571 var i: integer;
1572 cplen: integer;
1573 s: AnsiString;
1574 begin
1575 Result := 0;
1576 s := strpas(p);
1577 for i := 1 to FieldWidth do
1578 begin
1579 cplen := UTF8CodepointSizeFull(p);
1580 Inc(p,cplen);
1581 Inc(Result,cplen);
1582 if Result >= MaxDataLength then
1583 begin
1584 Result := MaxDataLength;
1585 Exit;
1586 end;
1587 end;
1588 end;
1589
1590 function TSQLDataItem.GetAsString: AnsiString;
1591 var
1592 sz: PByte;
1593 str_len: Integer;
1594 rs: RawByteString;
1595 aTimeZone: AnsiString;
1596 aDateTime: TDateTime;
1597 dstOffset: smallint;
1598 begin
1599 CheckActive;
1600 result := '';
1601 { Check null, if so return a default string }
1602 if not IsNull then
1603 with FFirebirdClientAPI do
1604 case SQLType of
1605 SQL_BOOLEAN:
1606 if AsBoolean then
1607 Result := sTrue
1608 else
1609 Result := SFalse;
1610
1611 SQL_TEXT, SQL_VARYING:
1612 begin
1613 sz := SQLData;
1614 if (SQLType = SQL_TEXT) then
1615 begin
1616 if GetCodePage = cp_utf8 then
1617 str_len := GetStrLen(PAnsiChar(sz),GetSize div GetCharSetWidth,DataLength)
1618 else
1619 str_len := DataLength
1620 end
1621 else begin
1622 str_len := DecodeInteger(sz, 2);
1623 Inc(sz, 2);
1624 end;
1625 SetString(rs, PAnsiChar(sz), str_len);
1626 SetCodePage(rs,GetCodePage,false);
1627 Result := rs;
1628 end;
1629
1630 SQL_TYPE_DATE:
1631 Result := DateToStr(GetAsDateTime);
1632 SQL_TIMESTAMP:
1633 Result := FBFormatDateTime(GetTimestampFormatStr,GetAsDateTime);
1634 SQL_TYPE_TIME:
1635 Result := FBFormatDateTime(GetTimeFormatStr,GetAsDateTime);
1636 SQL_TIMESTAMP_TZ,
1637 SQL_TIMESTAMP_TZ_EX:
1638 with GetAttachment.GetTimeZoneServices do
1639 begin
1640 if GetTZTextOption = tzGMT then
1641 Result := FBFormatDateTime(GetTimestampFormatStr,GetAsUTCDateTime)
1642 else
1643 begin
1644 GetAsDateTime(aDateTime,dstOffset,aTimeZone);
1645 if GetTZTextOption = tzOffset then
1646 Result := FBFormatDateTime(GetTimestampFormatStr,aDateTime) + ' ' + FormatTimeZoneOffset(dstOffset)
1647 else
1648 Result := FBFormatDateTime(GetTimestampFormatStr,aDateTime) + ' ' + aTimeZone;
1649 end;
1650 end;
1651 SQL_TIME_TZ,
1652 SQL_TIME_TZ_EX:
1653 with GetAttachment.GetTimeZoneServices do
1654 begin
1655 if GetTZTextOption = tzGMT then
1656 Result := FBFormatDateTime(GetTimeFormatStr,GetAsUTCDateTime)
1657 else
1658 begin
1659 GetAsTime(aDateTime,dstOffset,aTimeZone,GetTimeTZDate);
1660 if GetTZTextOption = tzOffset then
1661 Result := FBFormatDateTime(GetTimeFormatStr,aDateTime) + ' ' + FormatTimeZoneOffset(dstOffset)
1662 else
1663 Result := FBFormatDateTime(GetTimeFormatStr,aDateTime) + ' ' + aTimeZone;
1664 end;
1665 end;
1666
1667 SQL_SHORT, SQL_LONG:
1668 if Scale = 0 then
1669 result := IntToStr(AsLong)
1670 else if Scale >= (-4) then
1671 result := CurrToStr(AsCurrency)
1672 else
1673 result := FloatToStr(AsDouble);
1674 SQL_INT64:
1675 if Scale = 0 then
1676 result := IntToStr(AsInt64)
1677 else if Scale >= (-4) then
1678 result := CurrToStr(AsCurrency)
1679 else
1680 result := FloatToStr(AsDouble);
1681 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1682 result := FloatToStr(AsDouble);
1683
1684 SQL_DEC16,
1685 SQL_DEC34:
1686 result := BCDToStr(GetAsBCD);
1687
1688 SQL_DEC_FIXED,
1689 SQL_INT128:
1690 result := Int128ToStr(SQLData,scale);
1691
1692 else
1693 IBError(ibxeInvalidDataConversion, [nil]);
1694 end;
1695 end;
1696
1697 function TSQLDataItem.GetIsNull: Boolean;
1698 begin
1699 CheckActive;
1700 Result := false;
1701 end;
1702
1703 function TSQLDataItem.GetIsNullable: boolean;
1704 begin
1705 CheckActive;
1706 Result := false;
1707 end;
1708
1709 function TSQLDataItem.GetAsVariant: Variant;
1710 var ts: TDateTime;
1711 dstOffset: smallint;
1712 timezone: AnsiString;
1713 begin
1714 CheckActive;
1715 if IsNull then
1716 result := NULL
1717 { Check null, if so return a default string }
1718 else case SQLType of
1719 SQL_ARRAY:
1720 result := '(Array)'; {do not localize}
1721 SQL_BLOB,
1722 SQL_TEXT, SQL_VARYING:
1723 result := AsString;
1724 SQL_TIMESTAMP, SQL_TYPE_DATE, SQL_TYPE_TIME:
1725 result := AsDateTime;
1726 SQL_TIMESTAMP_TZ,
1727 SQL_TIME_TZ,
1728 SQL_TIMESTAMP_TZ_EX,
1729 SQL_TIME_TZ_EX:
1730 begin
1731 GetAsDateTime(ts,dstOffset,timezone);
1732 result := VarArrayOf([ts,dstOffset,timezone]);
1733 end;
1734 SQL_SHORT, SQL_LONG:
1735 if Scale = 0 then
1736 result := AsLong
1737 else if Scale >= (-4) then
1738 result := AsCurrency
1739 else
1740 result := AsDouble;
1741 SQL_INT64:
1742 if Scale = 0 then
1743 result := AsInt64
1744 else if Scale >= (-4) then
1745 result := AsCurrency
1746 else
1747 result := AsDouble;
1748 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1749 result := AsDouble;
1750 SQL_BOOLEAN:
1751 result := AsBoolean;
1752 SQL_DEC_FIXED,
1753 SQL_DEC16,
1754 SQL_DEC34,
1755 SQL_INT128:
1756 result := VarFmtBCDCreate(GetAsBcd);
1757 else
1758 IBError(ibxeInvalidDataConversion, [nil]);
1759 end;
1760 end;
1761
1762 function TSQLDataItem.GetModified: boolean;
1763 begin
1764 Result := false;
1765 end;
1766
1767 function TSQLDataItem.GetDateTimeStrLength(DateTimeFormat: TIBDateTimeFormats
1768 ): integer;
1769 begin
1770 case DateTimeFormat of
1771 dfTimestamp:
1772 Result := Length(GetTimestampFormatStr);
1773 dfDateTime:
1774 Result := Length(GetDateFormatStr(true));
1775 dfTime:
1776 Result := Length(GetTimeFormatStr);
1777 dfTimestampTZ:
1778 Result := Length(GetTimestampFormatStr) + 6; {assume time offset format}
1779 dfTimeTZ:
1780 Result := Length(GetTimeFormatStr)+ 6;
1781 else
1782 Result := 0;
1783 end;end;
1784
1785 function TSQLDataItem.GetAsBCD: tBCD;
1786
1787 begin
1788 CheckActive;
1789 if IsNull then
1790 with Result do
1791 begin
1792 FillChar(Result,sizeof(Result),0);
1793 Precision := 1;
1794 exit;
1795 end;
1796
1797 case SQLType of
1798 SQL_DEC16,
1799 SQL_DEC34:
1800 with FFirebirdClientAPI do
1801 Result := SQLDecFloatDecode(SQLType, SQLData);
1802
1803 SQL_DEC_FIXED,
1804 SQL_INT128:
1805 with FFirebirdClientAPI do
1806 Result := StrToBCD(Int128ToStr(SQLData,scale));
1807 else
1808 if not CurrToBCD(GetAsCurrency,Result) then
1809 IBError(ibxeBadBCDConversion,[]);
1810 end;
1811 end;
1812
1813
1814 procedure TSQLDataItem.SetIsNull(Value: Boolean);
1815 begin
1816 //ignore unless overridden
1817 end;
1818
1819 procedure TSQLDataItem.SetIsNullable(Value: Boolean);
1820 begin
1821 //ignore unless overridden
1822 end;
1823
1824 procedure TSQLDataItem.SetName(aValue: AnsiString);
1825 begin
1826 //ignore unless overridden
1827 end;
1828
1829 procedure TSQLDataItem.SetAsCurrency(Value: Currency);
1830 begin
1831 CheckActive;
1832 if GetSQLDialect < 3 then
1833 AsDouble := Value
1834 else
1835 begin
1836 Changing;
1837 if IsNullable then
1838 IsNull := False;
1839 SQLType := SQL_INT64;
1840 Scale := -4;
1841 DataLength := SizeOf(Int64);
1842 PCurrency(SQLData)^ := Value;
1843 Changed;
1844 end;
1845 end;
1846
1847 procedure TSQLDataItem.SetAsInt64(Value: Int64);
1848 begin
1849 CheckActive;
1850 Changing;
1851 if IsNullable then
1852 IsNull := False;
1853
1854 SQLType := SQL_INT64;
1855 Scale := 0;
1856 DataLength := SizeOf(Int64);
1857 PInt64(SQLData)^ := Value;
1858 Changed;
1859 end;
1860
1861 procedure TSQLDataItem.SetAsDate(Value: TDateTime);
1862 begin
1863 CheckActive;
1864 if GetSQLDialect < 3 then
1865 begin
1866 AsDateTime := Value;
1867 exit;
1868 end;
1869
1870 Changing;
1871 if IsNullable then
1872 IsNull := False;
1873
1874 SQLType := SQL_TYPE_DATE;
1875 DataLength := SizeOf(ISC_DATE);
1876 with FFirebirdClientAPI do
1877 SQLEncodeDate(Value,SQLData);
1878 Changed;
1879 end;
1880
1881 procedure TSQLDataItem.SetAsTime(Value: TDateTime);
1882 begin
1883 CheckActive;
1884 if GetSQLDialect < 3 then
1885 begin
1886 AsDateTime := Value;
1887 exit;
1888 end;
1889
1890 Changing;
1891 if IsNullable then
1892 IsNull := False;
1893
1894 SQLType := SQL_TYPE_TIME;
1895 DataLength := SizeOf(ISC_TIME);
1896 with FFirebirdClientAPI do
1897 SQLEncodeTime(Value,SQLData);
1898 Changed;
1899 end;
1900
1901 procedure TSQLDataItem.SetAsTime(aValue: TDateTime; OnDate: TDateTime; aTimeZoneID: TFBTimeZoneID);
1902 begin
1903 CheckActive;
1904 CheckTZSupport;
1905 if GetSQLDialect < 3 then
1906 begin
1907 AsDateTime := aValue;
1908 exit;
1909 end;
1910
1911 Changing;
1912 if IsNullable then
1913 IsNull := False;
1914
1915 SQLType := SQL_TIME_TZ;
1916 DataLength := SizeOf(ISC_TIME_TZ);
1917 GetTimeZoneServices.EncodeTimeTZ(aValue, aTimeZoneID,OnDate,SQLData);
1918 Changed;
1919 end;
1920
1921 procedure TSQLDataItem.SetAsTime(aValue: TDateTime; OnDate: TDateTime; aTimeZone: AnsiString);
1922 begin
1923 CheckActive;
1924 CheckTZSupport;
1925 if GetSQLDialect < 3 then
1926 begin
1927 AsDateTime := aValue;
1928 exit;
1929 end;
1930
1931 Changing;
1932 if IsNullable then
1933 IsNull := False;
1934
1935 SQLType := SQL_TIME_TZ;
1936 DataLength := SizeOf(ISC_TIME_TZ);
1937 GetTimeZoneServices.EncodeTimeTZ(aValue, aTimeZone,OnDate,SQLData);
1938 Changed;
1939 end;
1940
1941 procedure TSQLDataItem.SetAsDateTime(Value: TDateTime);
1942 begin
1943 CheckActive;
1944 if IsNullable then
1945 IsNull := False;
1946
1947 Changing;
1948 SQLType := SQL_TIMESTAMP;
1949 DataLength := SizeOf(ISC_TIME) + sizeof(ISC_DATE);
1950 with FFirebirdClientAPI do
1951 SQLEncodeDateTime(Value,SQLData);
1952 Changed;
1953 end;
1954
1955 procedure TSQLDataItem.SetAsDateTime(aValue: TDateTime;
1956 aTimeZoneID: TFBTimeZoneID);
1957 begin
1958 CheckActive;
1959 CheckTZSupport;
1960 if IsNullable then
1961 IsNull := False;
1962
1963 Changing;
1964 SQLType := SQL_TIMESTAMP_TZ;
1965 DataLength := SizeOf(ISC_TIMESTAMP_TZ);
1966 GetTimeZoneServices.EncodeTimestampTZ(aValue,aTimeZoneID,SQLData);
1967 Changed;
1968 end;
1969
1970 procedure TSQLDataItem.SetAsDateTime(aValue: TDateTime; aTimeZone: AnsiString
1971 );
1972 begin
1973 CheckActive;
1974 CheckTZSupport;
1975 if IsNullable then
1976 IsNull := False;
1977
1978 Changing;
1979 SQLType := SQL_TIMESTAMP_TZ;
1980 DataLength := SizeOf(ISC_TIMESTAMP_TZ);
1981 GetTimeZoneServices.EncodeTimestampTZ(aValue,aTimeZone,SQLData);
1982 Changed;
1983 end;
1984
1985 procedure TSQLDataItem.SetAsUTCDateTime(aUTCTime: TDateTime);
1986 begin
1987 SetAsDateTime(aUTCTime,TimeZoneID_GMT);
1988 end;
1989
1990 procedure TSQLDataItem.SetAsDouble(Value: Double);
1991 begin
1992 CheckActive;
1993 if IsNullable then
1994 IsNull := False;
1995
1996 Changing;
1997 SQLType := SQL_DOUBLE;
1998 DataLength := SizeOf(Double);
1999 Scale := 0;
2000 PDouble(SQLData)^ := Value;
2001 Changed;
2002 end;
2003
2004 procedure TSQLDataItem.SetAsFloat(Value: Float);
2005 begin
2006 CheckActive;
2007 if IsNullable then
2008 IsNull := False;
2009
2010 Changing;
2011 SQLType := SQL_FLOAT;
2012 DataLength := SizeOf(Float);
2013 Scale := 0;
2014 PSingle(SQLData)^ := Value;
2015 Changed;
2016 end;
2017
2018 procedure TSQLDataItem.SetAsLong(Value: Long);
2019 begin
2020 CheckActive;
2021 if IsNullable then
2022 IsNull := False;
2023
2024 Changing;
2025 SQLType := SQL_LONG;
2026 DataLength := SizeOf(Long);
2027 Scale := 0;
2028 PLong(SQLData)^ := Value;
2029 Changed;
2030 end;
2031
2032 procedure TSQLDataItem.SetAsPointer(Value: Pointer);
2033 begin
2034 CheckActive;
2035 Changing;
2036 if IsNullable and (Value = nil) then
2037 IsNull := True
2038 else
2039 begin
2040 IsNull := False;
2041 SQLType := SQL_TEXT;
2042 Move(Value^, SQLData^, DataLength);
2043 end;
2044 Changed;
2045 end;
2046
2047 procedure TSQLDataItem.SetAsQuad(Value: TISC_QUAD);
2048 begin
2049 CheckActive;
2050 Changing;
2051 if IsNullable then
2052 IsNull := False;
2053 if (SQLType <> SQL_BLOB) and
2054 (SQLType <> SQL_ARRAY) then
2055 IBError(ibxeInvalidDataConversion, [nil]);
2056 DataLength := SizeOf(TISC_QUAD);
2057 PISC_QUAD(SQLData)^ := Value;
2058 Changed;
2059 end;
2060
2061 procedure TSQLDataItem.SetAsShort(Value: short);
2062 begin
2063 CheckActive;
2064 Changing;
2065 if IsNullable then
2066 IsNull := False;
2067
2068 SQLType := SQL_SHORT;
2069 DataLength := SizeOf(Short);
2070 Scale := 0;
2071 PShort(SQLData)^ := Value;
2072 Changed;
2073 end;
2074
2075 procedure TSQLDataItem.SetAsString(Value: AnsiString);
2076 begin
2077 InternalSetAsString(Value);
2078 end;
2079
2080 procedure TSQLDataItem.SetAsVariant(Value: Variant);
2081 begin
2082 CheckActive;
2083 if VarIsNull(Value) then
2084 IsNull := True
2085 else
2086 if VarIsArray(Value) then {must be datetime plus timezone}
2087 SetAsDateTime(Value[0],AnsiString(Value[1]))
2088 else case VarType(Value) of
2089 varEmpty, varNull:
2090 IsNull := True;
2091 varSmallint, varInteger, varByte,
2092 varWord, varShortInt:
2093 AsLong := Value;
2094 varInt64:
2095 AsInt64 := Value;
2096 varSingle, varDouble:
2097 AsDouble := Value;
2098 varCurrency:
2099 AsCurrency := Value;
2100 varBoolean:
2101 AsBoolean := Value;
2102 varDate:
2103 AsDateTime := Value;
2104 varOleStr, varString:
2105 AsString := Value;
2106 varArray:
2107 IBError(ibxeNotSupported, [nil]);
2108 varByRef, varDispatch, varError, varUnknown, varVariant:
2109 IBError(ibxeNotPermitted, [nil]);
2110 else
2111 if VarIsFmtBCD(Value) then
2112 SetAsBCD(VarToBCD(Value))
2113 else
2114 IBError(ibxeNotSupported, [nil]);
2115 end;
2116 end;
2117
2118 procedure TSQLDataItem.SetAsNumeric(Value: Int64; aScale: integer);
2119 begin
2120 CheckActive;
2121 Changing;
2122 if IsNullable then
2123 IsNull := False;
2124
2125 SQLType := SQL_INT64;
2126 Scale := aScale;
2127 DataLength := SizeOf(Int64);
2128 PInt64(SQLData)^ := Value;
2129 Changed;
2130 end;
2131
2132 procedure TSQLDataItem.SetAsBcd(aValue: tBCD);
2133 var C: Currency;
2134 begin
2135 CheckActive;
2136 Changing;
2137 if IsNullable then
2138 IsNull := False;
2139
2140
2141 with FFirebirdClientAPI do
2142 if aValue.Precision <= 16 then
2143 begin
2144 if not HasDecFloatSupport then
2145 IBError(ibxeDecFloatNotSupported,[]);
2146
2147 SQLType := SQL_DEC16;
2148 DataLength := 8;
2149 SQLDecFloatEncode(aValue,SQLType,SQLData);
2150 end
2151 else
2152 if aValue.Precision <= 34 then
2153 begin
2154 if not HasDecFloatSupport then
2155 IBError(ibxeDecFloatNotSupported,[]);
2156
2157 SQLType := SQL_DEC34;
2158 DataLength := 16;
2159 SQLDecFloatEncode(aValue,SQLType,SQLData);
2160 end
2161 else
2162 if aValue.Precision <= 38 then
2163 begin
2164 if not HasInt128Support then
2165 IBError(ibxeInt128NotSupported,[]);
2166
2167 SQLType := SQL_INT128;
2168 DataLength := 16;
2169 StrToInt128(scale,BcdToStr(aValue),SQLData);
2170 end
2171 else
2172 IBError(ibxeBCDOverflow,[BCDToStr(aValue)]);
2173
2174 Changed;
2175 end;
2176
2177 procedure TSQLDataItem.SetAsBoolean(AValue: boolean);
2178 begin
2179 CheckActive;
2180 Changing;
2181 if IsNullable then
2182 IsNull := False;
2183
2184 SQLType := SQL_BOOLEAN;
2185 DataLength := 1;
2186 Scale := 0;
2187 if AValue then
2188 PByte(SQLData)^ := ISC_TRUE
2189 else
2190 PByte(SQLData)^ := ISC_FALSE;
2191 Changed;
2192 end;
2193
2194 {TColumnMetaData}
2195
2196 procedure TColumnMetaData.CheckActive;
2197 begin
2198 if not FIBXSQLVAR.Parent.StateChanged(FChangeSeqNo) then Exit;
2199
2200 if FPrepareSeqNo < FIBXSQLVAR.Parent.GetPrepareSeqNo then
2201 IBError(ibxeInterfaceOutofDate,[nil]);
2202
2203 if not FIBXSQLVAR.Parent.CheckStatementStatus(ssPrepared) then
2204 IBError(ibxeStatementNotPrepared, [nil]);
2205 end;
2206
2207 function TColumnMetaData.GetAttachment: IAttachment;
2208 begin
2209 Result := GetStatement.GetAttachment;
2210 end;
2211
2212 function TColumnMetaData.SQLData: PByte;
2213 begin
2214 Result := FIBXSQLVAR.SQLData;
2215 end;
2216
2217 function TColumnMetaData.GetDataLength: cardinal;
2218 begin
2219 Result := FIBXSQLVAR.DataLength;
2220 end;
2221
2222 function TColumnMetaData.GetCodePage: TSystemCodePage;
2223 begin
2224 Result := FIBXSQLVAR.GetCodePage;
2225 end;
2226
2227 constructor TColumnMetaData.Create(aOwner: IUnknown; aIBXSQLVAR: TSQLVarData);
2228 begin
2229 inherited Create(aIBXSQLVAR.GetStatement.GetAttachment.getFirebirdAPI as TFBClientAPI);
2230 FIBXSQLVAR := aIBXSQLVAR;
2231 FOwner := aOwner;
2232 FPrepareSeqNo := FIBXSQLVAR.Parent.PrepareSeqNo;
2233 FIBXSQLVAR.Parent.StateChanged(FChangeSeqNo)
2234 end;
2235
2236 destructor TColumnMetaData.Destroy;
2237 begin
2238 (FOwner as TInterfaceOwner).Remove(self);
2239 inherited Destroy;
2240 end;
2241
2242
2243 function TColumnMetaData.GetSQLDialect: integer;
2244 begin
2245 Result := FIBXSQLVAR.Statement.GetSQLDialect;
2246 end;
2247
2248 function TColumnMetaData.GetIndex: integer;
2249 begin
2250 Result := FIBXSQLVAR.Index;
2251 end;
2252
2253 function TColumnMetaData.GetSQLType: cardinal;
2254 begin
2255 CheckActive;
2256 result := FIBXSQLVAR.SQLType;
2257 end;
2258
2259 function TColumnMetaData.getSubtype: integer;
2260 begin
2261 CheckActive;
2262 result := FIBXSQLVAR.SQLSubtype;
2263 end;
2264
2265 function TColumnMetaData.getRelationName: AnsiString;
2266 begin
2267 CheckActive;
2268 result := FIBXSQLVAR.RelationName;
2269 end;
2270
2271 function TColumnMetaData.getOwnerName: AnsiString;
2272 begin
2273 CheckActive;
2274 result := FIBXSQLVAR.OwnerName;
2275 end;
2276
2277 function TColumnMetaData.getSQLName: AnsiString;
2278 begin
2279 CheckActive;
2280 result := FIBXSQLVAR.FieldName;
2281 end;
2282
2283 function TColumnMetaData.getAliasName: AnsiString;
2284 begin
2285 CheckActive;
2286 result := FIBXSQLVAR.AliasName;
2287 end;
2288
2289 function TColumnMetaData.GetName: AnsiString;
2290 begin
2291 CheckActive;
2292 Result := FIBXSQLVAR. Name;
2293 end;
2294
2295 function TColumnMetaData.GetScale: integer;
2296 begin
2297 CheckActive;
2298 result := FIBXSQLVAR.Scale;
2299 end;
2300
2301 function TColumnMetaData.getCharSetID: cardinal;
2302 begin
2303 CheckActive;
2304 Result := FIBXSQLVAR.CharSetID;
2305 end;
2306
2307 function TColumnMetaData.GetIsNullable: boolean;
2308 begin
2309 CheckActive;
2310 result := FIBXSQLVAR.IsNullable;
2311 end;
2312
2313 function TColumnMetaData.GetSize: cardinal;
2314 begin
2315 CheckActive;
2316 result := FIBXSQLVAR.GetSize;
2317 end;
2318
2319 function TColumnMetaData.GetCharSetWidth: integer;
2320 begin
2321 CheckActive;
2322 result := FIBXSQLVAR.GetCharSetWidth;
2323 end;
2324
2325 function TColumnMetaData.GetArrayMetaData: IArrayMetaData;
2326 begin
2327 CheckActive;
2328 result := FIBXSQLVAR.GetArrayMetaData;
2329 end;
2330
2331 function TColumnMetaData.GetBlobMetaData: IBlobMetaData;
2332 begin
2333 CheckActive;
2334 result := FIBXSQLVAR.GetBlobMetaData;
2335 end;
2336
2337 function TColumnMetaData.GetStatement: IStatement;
2338 begin
2339 Result := FIBXSQLVAR.GetStatement;
2340 end;
2341
2342 function TColumnMetaData.GetTransaction: ITransaction;
2343 begin
2344 Result := GetStatement.GetTransaction;
2345 end;
2346
2347 { TIBSQLData }
2348
2349 procedure TIBSQLData.CheckActive;
2350 begin
2351 if not FIBXSQLVAR.Parent.StateChanged(FChangeSeqNo) then Exit;
2352
2353 inherited CheckActive;
2354
2355 if not FIBXSQLVAR.Parent.CheckStatementStatus(ssCursorOpen) and
2356 not FIBXSQLVAR.Parent.CheckStatementStatus(ssExecuteResults) then
2357 IBError(ibxeSQLClosed, [nil]);
2358
2359 if FIBXSQLVAR.Parent.CheckStatementStatus(ssEOF) then
2360 IBError(ibxeEOF,[nil]);
2361
2362 if FIBXSQLVAR.Parent.CheckStatementStatus(ssBOF) then
2363 IBError(ibxeBOF,[nil]);
2364 end;
2365
2366 function TIBSQLData.GetTransaction: ITransaction;
2367 begin
2368 if FTransaction = nil then
2369 Result := inherited GetTransaction
2370 else
2371 Result := FTransaction;
2372 end;
2373
2374 function TIBSQLData.GetIsNull: Boolean;
2375 begin
2376 CheckActive;
2377 result := FIBXSQLVAR.IsNull;
2378 end;
2379
2380 function TIBSQLData.GetAsArray: IArray;
2381 begin
2382 CheckActive;
2383 result := FIBXSQLVAR.GetAsArray(AsQuad);
2384 end;
2385
2386 function TIBSQLData.GetAsBlob: IBlob;
2387 begin
2388 CheckActive;
2389 result := FIBXSQLVAR.GetAsBlob(AsQuad,nil);
2390 end;
2391
2392 function TIBSQLData.GetAsBlob(BPB: IBPB): IBlob;
2393 begin
2394 CheckActive;
2395 result := FIBXSQLVAR.GetAsBlob(AsQuad,BPB);
2396 end;
2397
2398 function TIBSQLData.GetAsString: AnsiString;
2399 begin
2400 CheckActive;
2401 Result := '';
2402 { Check null, if so return a default string }
2403 if not IsNull then
2404 case SQLType of
2405 SQL_ARRAY:
2406 result := SArray;
2407 SQL_BLOB:
2408 Result := FIBXSQLVAR.GetAsBlob(AsQuad,nil).GetAsString;
2409 else
2410 Result := inherited GetAsString;
2411 end;
2412 end;
2413
2414 { TSQLParam }
2415
2416 procedure TSQLParam.InternalSetAsString(Value: AnsiString);
2417
2418 procedure DoSetString;
2419 begin
2420 Changing;
2421 FIBXSQLVar.SetString(Transliterate(Value,GetCodePage));
2422 Changed;
2423 end;
2424
2425 var b: IBlob;
2426 dt: TDateTime;
2427 timezone: AnsiString;
2428 FloatValue: Double;
2429 Int64Value: Int64;
2430 BCDValue: TBCD;
2431 aScale: integer;
2432 begin
2433 CheckActive;
2434 if IsNullable then
2435 IsNull := False;
2436 with FFirebirdClientAPI do
2437 case getColMetaData.SQLTYPE of
2438 SQL_BOOLEAN:
2439 if AnsiCompareText(Value,STrue) = 0 then
2440 AsBoolean := true
2441 else
2442 if AnsiCompareText(Value,SFalse) = 0 then
2443 AsBoolean := false
2444 else
2445 IBError(ibxeInvalidDataConversion,[nil]);
2446
2447 SQL_BLOB:
2448 if Length(Value) < GetAttachment.GetInlineBlobLimit then
2449 DoSetString
2450 else
2451 begin
2452 Changing;
2453 b := FIBXSQLVAR.CreateBlob;
2454 b.SetAsString(Value);
2455 AsBlob := b;
2456 Changed;
2457 end;
2458
2459 SQL_VARYING,
2460 SQL_TEXT:
2461 DoSetString;
2462
2463 SQL_SHORT,
2464 SQL_LONG,
2465 SQL_INT64:
2466 {If the string contains an integer then convert and set directly}
2467 if TryStrToInt64(Value,Int64Value) then
2468 SetAsInt64(Int64Value)
2469 else
2470 if getColMetaData.getScale = 0 then {integer expected but non-integer string}
2471 begin
2472 if TryStrToFloat(Value,FloatValue) then
2473 {truncate it if the column is limited to an integer}
2474 SetAsInt64(Trunc(FloatValue))
2475 else
2476 DoSetString;
2477 end
2478 else
2479 if TryStrToFloat(Value,FloatValue) then
2480 begin
2481 aScale := getColMetaData.getScale;
2482 {Set as int64 with adjusted scale}
2483 SetAsNumeric(AdjustScaleFromDouble(FloatValue,aScale),aScale)
2484 end
2485 else
2486 DoSetString;
2487
2488 SQL_DEC_FIXED,
2489 SQL_DEC16,
2490 SQL_DEC34,
2491 SQL_INT128:
2492 if TryStrToBCD(Value,BCDValue) then
2493 SetAsBCD(BCDValue)
2494 else
2495 DoSetString;
2496
2497 SQL_D_FLOAT,
2498 SQL_DOUBLE,
2499 SQL_FLOAT:
2500 if TryStrToFloat(Value,FloatValue) then
2501 SetAsDouble(FloatValue)
2502 else
2503 DoSetString;
2504
2505 SQL_TIMESTAMP:
2506 if TryStrToDateTime(Value,dt) then
2507 SetAsDateTime(dt)
2508 else
2509 DoSetString;
2510
2511 SQL_TYPE_DATE:
2512 if TryStrToDateTime(Value,dt) then
2513 SetAsDate(dt)
2514 else
2515 DoSetString;
2516
2517 SQL_TYPE_TIME:
2518 if TryStrToDateTime(Value,dt) then
2519 SetAsTime(dt)
2520 else
2521 DoSetString;
2522
2523 SQL_TIMESTAMP_TZ,
2524 SQL_TIMESTAMP_TZ_EX:
2525 if ParseDateTimeTZString(value,dt,timezone) then
2526 SetAsDateTime(dt,timezone)
2527 else
2528 DoSetString;
2529
2530 SQL_TIME_TZ,
2531 SQL_TIME_TZ_EX:
2532 if ParseDateTimeTZString(value,dt,timezone,true) then
2533 SetAsTime(dt,GetAttachment.GetTimeZoneServices.GetTimeTZDate,timezone)
2534 else
2535 DoSetString;
2536
2537 else
2538 IBError(ibxeInvalidDataConversion,[GetSQLTypeName(getColMetaData.SQLTYPE)]);
2539 end;
2540 end;
2541
2542 procedure TSQLParam.CheckActive;
2543 begin
2544 if not FIBXSQLVAR.Parent.StateChanged(FChangeSeqNo) then Exit;
2545
2546 if FPrepareSeqNo < FIBXSQLVAR.Parent.GetPrepareSeqNo then
2547 IBError(ibxeInterfaceOutofDate,[nil]);
2548
2549 if not FIBXSQLVAR.Parent.CheckStatementStatus(ssPrepared) then
2550 IBError(ibxeStatementNotPrepared, [nil]);
2551 end;
2552
2553 procedure TSQLParam.SetScale(aValue: integer);
2554 begin
2555 CheckActive;
2556 FIBXSQLVAR.Scale := aValue;
2557 end;
2558
2559 procedure TSQLParam.SetDataLength(len: cardinal);
2560 begin
2561 CheckActive;
2562 FIBXSQLVAR.DataLength := len;
2563 end;
2564
2565 procedure TSQLParam.SetSQLType(aValue: cardinal);
2566 begin
2567 CheckActive;
2568 FIBXSQLVAR.SQLType := aValue;
2569 end;
2570
2571 procedure TSQLParam.Clear;
2572 begin
2573 IsNull := true;
2574 end;
2575
2576 function TSQLParam.getColMetadata: IParamMetaData;
2577 begin
2578 Result := FIBXSQLVAR.getColMetadata;
2579 end;
2580
2581 function TSQLParam.GetModified: boolean;
2582 begin
2583 CheckActive;
2584 Result := FIBXSQLVAR.Modified;
2585 end;
2586
2587 function TSQLParam.GetAsPointer: Pointer;
2588 begin
2589 IsNull := false; {Assume that we get the pointer in order to set a value}
2590 Changed;
2591 Result := inherited GetAsPointer;
2592 end;
2593
2594 function TSQLParam.GetAsString: AnsiString;
2595 var rs: RawByteString;
2596 begin
2597 Result := '';
2598 if (SQLType = SQL_VARYING) and not IsNull then
2599 {SQLData points to start of string - default is to length word}
2600 begin
2601 CheckActive;
2602 SetString(rs,PAnsiChar(SQLData),DataLength);
2603 SetCodePage(rs,GetCodePage,false);
2604 Result := rs;
2605 end
2606 else
2607 Result := inherited GetAsString;
2608 end;
2609
2610 procedure TSQLParam.SetName(Value: AnsiString);
2611 begin
2612 CheckActive;
2613 FIBXSQLVAR.Name := Value;
2614 end;
2615
2616 procedure TSQLParam.SetIsNull(Value: Boolean);
2617 var i: integer;
2618 begin
2619 CheckActive;
2620 if FIBXSQLVAR.UniqueName then
2621 FIBXSQLVAR.IsNull := Value
2622 else
2623 with FIBXSQLVAR.Parent do
2624 begin
2625 for i := 0 to Count - 1 do
2626 if Column[i].Name = Name then
2627 Column[i].IsNull := Value;
2628 end
2629 end;
2630
2631 procedure TSQLParam.SetIsNullable(Value: Boolean);
2632 var i: integer;
2633 begin
2634 CheckActive;
2635 if FIBXSQLVAR.UniqueName then
2636 FIBXSQLVAR.IsNullable := Value
2637 else
2638 with FIBXSQLVAR.Parent do
2639 begin
2640 for i := 0 to Count - 1 do
2641 if Column[i].Name = Name then
2642 Column[i].IsNullable := Value;
2643 end
2644 end;
2645
2646 procedure TSQLParam.SetAsArray(anArray: IArray);
2647 begin
2648 CheckActive;
2649 if GetSQLType <> SQL_ARRAY then
2650 IBError(ibxeInvalidDataConversion,[nil]);
2651
2652 if not FIBXSQLVAR.UniqueName then
2653 IBError(ibxeDuplicateParamName,[FIBXSQLVAR.Name]);
2654
2655 SetAsQuad(AnArray.GetArrayID);
2656 end;
2657
2658 procedure TSQLParam.Changed;
2659 begin
2660 FIBXSQLVAR.Changed;
2661 end;
2662
2663 procedure TSQLParam.SetAsBoolean(AValue: boolean);
2664 var i: integer;
2665 OldSQLVar: TSQLVarData;
2666 begin
2667 if FIBXSQLVAR.UniqueName then
2668 inherited SetAsBoolean(AValue)
2669 else
2670 with FIBXSQLVAR.Parent do
2671 begin
2672 for i := 0 to Count - 1 do
2673 if Column[i].Name = Name then
2674 begin
2675 OldSQLVar := FIBXSQLVAR;
2676 FIBXSQLVAR := Column[i];
2677 try
2678 inherited SetAsBoolean(AValue);
2679 finally
2680 FIBXSQLVAR := OldSQLVar;
2681 end;
2682 end;
2683 end;
2684 end;
2685
2686 procedure TSQLParam.SetAsCurrency(AValue: Currency);
2687 var i: integer;
2688 OldSQLVar: TSQLVarData;
2689 begin
2690 if FIBXSQLVAR.UniqueName then
2691 inherited SetAsCurrency(AValue)
2692 else
2693 with FIBXSQLVAR.Parent do
2694 begin
2695 for i := 0 to Count - 1 do
2696 if Column[i].Name = Name then
2697 begin
2698 OldSQLVar := FIBXSQLVAR;
2699 FIBXSQLVAR := Column[i];
2700 try
2701 inherited SetAsCurrency(AValue);
2702 finally
2703 FIBXSQLVAR := OldSQLVar;
2704 end;
2705 end;
2706 end;
2707 end;
2708
2709 procedure TSQLParam.SetAsInt64(AValue: Int64);
2710 var i: integer;
2711 OldSQLVar: TSQLVarData;
2712 begin
2713 if FIBXSQLVAR.UniqueName then
2714 inherited SetAsInt64(AValue)
2715 else
2716 with FIBXSQLVAR.Parent do
2717 begin
2718 for i := 0 to Count - 1 do
2719 if Column[i].Name = Name then
2720 begin
2721 OldSQLVar := FIBXSQLVAR;
2722 FIBXSQLVAR := Column[i];
2723 try
2724 inherited SetAsInt64(AValue);
2725 finally
2726 FIBXSQLVAR := OldSQLVar;
2727 end;
2728 end;
2729 end;
2730 end;
2731
2732 procedure TSQLParam.SetAsDate(AValue: TDateTime);
2733 var i: integer;
2734 OldSQLVar: TSQLVarData;
2735 begin
2736 if FIBXSQLVAR.UniqueName then
2737 inherited SetAsDate(AValue)
2738 else
2739 with FIBXSQLVAR.Parent do
2740 begin
2741 for i := 0 to Count - 1 do
2742 if Column[i].Name = Name then
2743 begin
2744 OldSQLVar := FIBXSQLVAR;
2745 FIBXSQLVAR := Column[i];
2746 try
2747 inherited SetAsDate(AValue);
2748 finally
2749 FIBXSQLVAR := OldSQLVar;
2750 end;
2751 end;
2752 end;
2753 end;
2754
2755 procedure TSQLParam.SetAsLong(AValue: Long);
2756 var i: integer;
2757 OldSQLVar: TSQLVarData;
2758 begin
2759 if FIBXSQLVAR.UniqueName then
2760 inherited SetAsLong(AValue)
2761 else
2762 with FIBXSQLVAR.Parent do
2763 begin
2764 for i := 0 to Count - 1 do
2765 if Column[i].Name = Name then
2766 begin
2767 OldSQLVar := FIBXSQLVAR;
2768 FIBXSQLVAR := Column[i];
2769 try
2770 inherited SetAsLong(AValue);
2771 finally
2772 FIBXSQLVAR := OldSQLVar;
2773 end;
2774 end;
2775 end;
2776 end;
2777
2778 procedure TSQLParam.SetAsTime(AValue: TDateTime);
2779 var i: integer;
2780 OldSQLVar: TSQLVarData;
2781 begin
2782 if FIBXSQLVAR.UniqueName then
2783 inherited SetAsTime(AValue)
2784 else
2785 with FIBXSQLVAR.Parent do
2786 begin
2787 for i := 0 to Count - 1 do
2788 if Column[i].Name = Name then
2789 begin
2790 OldSQLVar := FIBXSQLVAR;
2791 FIBXSQLVAR := Column[i];
2792 try
2793 inherited SetAsTime(AValue);
2794 finally
2795 FIBXSQLVAR := OldSQLVar;
2796 end;
2797 end;
2798 end;
2799 end;
2800
2801 procedure TSQLParam.SetAsTime(aValue: TDateTime; OnDate: TDateTime; aTimeZoneID: TFBTimeZoneID);
2802 var i: integer;
2803 OldSQLVar: TSQLVarData;
2804 begin
2805 if FIBXSQLVAR.UniqueName then
2806 inherited SetAsTime(AValue,OnDate, aTimeZoneID)
2807 else
2808 with FIBXSQLVAR.Parent do
2809 begin
2810 for i := 0 to Count - 1 do
2811 if Column[i].Name = Name then
2812 begin
2813 OldSQLVar := FIBXSQLVAR;
2814 FIBXSQLVAR := Column[i];
2815 try
2816 inherited SetAsTime(AValue,OnDate, aTimeZoneID);
2817 finally
2818 FIBXSQLVAR := OldSQLVar;
2819 end;
2820 end;
2821 end;
2822 end;
2823
2824 procedure TSQLParam.SetAsTime(aValue: TDateTime; OnDate: TDateTime; aTimeZone: AnsiString);
2825 var i: integer;
2826 OldSQLVar: TSQLVarData;
2827 begin
2828 if FIBXSQLVAR.UniqueName then
2829 inherited SetAsTime(AValue,OnDate,aTimeZone)
2830 else
2831 with FIBXSQLVAR.Parent do
2832 begin
2833 for i := 0 to Count - 1 do
2834 if Column[i].Name = Name then
2835 begin
2836 OldSQLVar := FIBXSQLVAR;
2837 FIBXSQLVAR := Column[i];
2838 try
2839 inherited SetAsTime(AValue,OnDate,aTimeZone);
2840 finally
2841 FIBXSQLVAR := OldSQLVar;
2842 end;
2843 end;
2844 end;
2845 end;
2846
2847 procedure TSQLParam.SetAsTime(aValue: TDateTime; aTimeZoneID: TFBTimeZoneID);
2848 begin
2849 SetAsTime(aValue,GetTimeZoneServices.GetTimeTZDate,aTimeZoneID);
2850 end;
2851
2852 procedure TSQLParam.SetAsTime(aValue: TDateTime; aTimeZone: AnsiString);
2853 begin
2854 SetAsTime(aValue,GetTimeZoneServices.GetTimeTZDate,aTimeZone);
2855 end;
2856
2857 procedure TSQLParam.SetAsDateTime(AValue: TDateTime);
2858 var i: integer;
2859 OldSQLVar: TSQLVarData;
2860 begin
2861 if FIBXSQLVAR.UniqueName then
2862 inherited SetAsDateTime(AValue)
2863 else
2864 with FIBXSQLVAR.Parent do
2865 begin
2866 for i := 0 to Count - 1 do
2867 if Column[i].Name = Name then
2868 begin
2869 OldSQLVar := FIBXSQLVAR;
2870 FIBXSQLVAR := Column[i];
2871 try
2872 inherited SetAsDateTime(AValue);
2873 finally
2874 FIBXSQLVAR := OldSQLVar;
2875 end;
2876 end;
2877 end;
2878 end;
2879
2880 procedure TSQLParam.SetAsDateTime(aValue: TDateTime; aTimeZoneID: TFBTimeZoneID
2881 );
2882 var i: integer;
2883 OldSQLVar: TSQLVarData;
2884 begin
2885 if FIBXSQLVAR.UniqueName then
2886 inherited SetAsDateTime(AValue,aTimeZoneID)
2887 else
2888 with FIBXSQLVAR.Parent do
2889 begin
2890 for i := 0 to Count - 1 do
2891 if Column[i].Name = Name then
2892 begin
2893 OldSQLVar := FIBXSQLVAR;
2894 FIBXSQLVAR := Column[i];
2895 try
2896 inherited SetAsDateTime(AValue,aTimeZoneID);
2897 finally
2898 FIBXSQLVAR := OldSQLVar;
2899 end;
2900 end;
2901 end;
2902 end;
2903
2904 procedure TSQLParam.SetAsDateTime(aValue: TDateTime; aTimeZone: AnsiString);
2905 var i: integer;
2906 OldSQLVar: TSQLVarData;
2907 begin
2908 if FIBXSQLVAR.UniqueName then
2909 inherited SetAsDateTime(AValue,aTimeZone)
2910 else
2911 with FIBXSQLVAR.Parent do
2912 begin
2913 for i := 0 to Count - 1 do
2914 if Column[i].Name = Name then
2915 begin
2916 OldSQLVar := FIBXSQLVAR;
2917 FIBXSQLVAR := Column[i];
2918 try
2919 inherited SetAsDateTime(AValue,aTimeZone);
2920 finally
2921 FIBXSQLVAR := OldSQLVar;
2922 end;
2923 end;
2924 end;
2925 end;
2926
2927 procedure TSQLParam.SetAsDouble(AValue: Double);
2928 var i: integer;
2929 OldSQLVar: TSQLVarData;
2930 begin
2931 if FIBXSQLVAR.UniqueName then
2932 inherited SetAsDouble(AValue)
2933 else
2934 with FIBXSQLVAR.Parent do
2935 begin
2936 for i := 0 to Count - 1 do
2937 if Column[i].Name = Name then
2938 begin
2939 OldSQLVar := FIBXSQLVAR;
2940 FIBXSQLVAR := Column[i];
2941 try
2942 inherited SetAsDouble(AValue);
2943 finally
2944 FIBXSQLVAR := OldSQLVar;
2945 end;
2946 end;
2947 end;
2948 end;
2949
2950 procedure TSQLParam.SetAsFloat(AValue: Float);
2951 var i: integer;
2952 OldSQLVar: TSQLVarData;
2953 begin
2954 if FIBXSQLVAR.UniqueName then
2955 inherited SetAsFloat(AValue)
2956 else
2957 with FIBXSQLVAR.Parent do
2958 begin
2959 for i := 0 to Count - 1 do
2960 if Column[i].Name = Name then
2961 begin
2962 OldSQLVar := FIBXSQLVAR;
2963 FIBXSQLVAR := Column[i];
2964 try
2965 inherited SetAsFloat(AValue);
2966 finally
2967 FIBXSQLVAR := OldSQLVar;
2968 end;
2969 end;
2970 end;
2971 end;
2972
2973 procedure TSQLParam.SetAsPointer(AValue: Pointer);
2974 var i: integer;
2975 OldSQLVar: TSQLVarData;
2976 begin
2977 if FIBXSQLVAR.UniqueName then
2978 inherited SetAsPointer(AValue)
2979 else
2980 with FIBXSQLVAR.Parent do
2981 begin
2982 for i := 0 to Count - 1 do
2983 if Column[i].Name = Name then
2984 begin
2985 OldSQLVar := FIBXSQLVAR;
2986 FIBXSQLVAR := Column[i];
2987 try
2988 inherited SetAsPointer(AValue);
2989 finally
2990 FIBXSQLVAR := OldSQLVar;
2991 end;
2992 end;
2993 end;
2994 end;
2995
2996 procedure TSQLParam.SetAsShort(AValue: Short);
2997 var i: integer;
2998 OldSQLVar: TSQLVarData;
2999 begin
3000 if FIBXSQLVAR.UniqueName then
3001 inherited SetAsShort(AValue)
3002 else
3003 with FIBXSQLVAR.Parent do
3004 begin
3005 for i := 0 to Count - 1 do
3006 if Column[i].Name = Name then
3007 begin
3008 OldSQLVar := FIBXSQLVAR;
3009 FIBXSQLVAR := Column[i];
3010 try
3011 inherited SetAsShort(AValue);
3012 finally
3013 FIBXSQLVAR := OldSQLVar;
3014 end;
3015 end;
3016 end;
3017 end;
3018
3019 procedure TSQLParam.SetAsString(AValue: AnsiString);
3020 var i: integer;
3021 OldSQLVar: TSQLVarData;
3022 begin
3023 if FIBXSQLVAR.UniqueName then
3024 InternalSetAsString(AValue)
3025 else
3026 with FIBXSQLVAR.Parent do
3027 begin
3028 for i := 0 to Count - 1 do
3029 if Column[i].Name = Name then
3030 begin
3031 OldSQLVar := FIBXSQLVAR;
3032 FIBXSQLVAR := Column[i];
3033 try
3034 InternalSetAsString(AValue);
3035 finally
3036 FIBXSQLVAR := OldSQLVar;
3037 end;
3038 end;
3039 end;
3040 end;
3041
3042 procedure TSQLParam.SetAsVariant(AValue: Variant);
3043 var i: integer;
3044 OldSQLVar: TSQLVarData;
3045 begin
3046 if FIBXSQLVAR.UniqueName then
3047 inherited SetAsVariant(AValue)
3048 else
3049 with FIBXSQLVAR.Parent do
3050 begin
3051 for i := 0 to Count - 1 do
3052 if Column[i].Name = Name then
3053 begin
3054 OldSQLVar := FIBXSQLVAR;
3055 FIBXSQLVAR := Column[i];
3056 try
3057 inherited SetAsVariant(AValue);
3058 finally
3059 FIBXSQLVAR := OldSQLVar;
3060 end;
3061 end;
3062 end;
3063 end;
3064
3065 procedure TSQLParam.SetAsBlob(aValue: IBlob);
3066 begin
3067 with FIBXSQLVAR do
3068 if not UniqueName then
3069 IBError(ibxeDuplicateParamName,[Name]);
3070 CheckActive;
3071 Changing;
3072 aValue.Close;
3073 if aValue.GetSubType <> GetSubType then
3074 IBError(ibxeIncompatibleBlob,[GetSubType,aValue.GetSubType]);
3075 AsQuad := aValue.GetBlobID;
3076 Changed;
3077 end;
3078
3079 procedure TSQLParam.SetAsQuad(AValue: TISC_QUAD);
3080 var i: integer;
3081 OldSQLVar: TSQLVarData;
3082 begin
3083 if FIBXSQLVAR.UniqueName then
3084 inherited SetAsQuad(AValue)
3085 else
3086 with FIBXSQLVAR.Parent do
3087 begin
3088 for i := 0 to Count - 1 do
3089 if Column[i].Name = Name then
3090 begin
3091 OldSQLVar := FIBXSQLVAR;
3092 FIBXSQLVAR := Column[i];
3093 try
3094 inherited SetAsQuad(AValue);
3095 finally
3096 FIBXSQLVAR := OldSQLVar;
3097 end;
3098 end;
3099 end;
3100 end;
3101
3102 procedure TSQLParam.SetCharSetID(aValue: cardinal);
3103 begin
3104 FIBXSQLVAR.SetCharSetID(aValue);
3105 end;
3106
3107 procedure TSQLParam.SetAsBcd(aValue: tBCD);
3108 var i: integer;
3109 OldSQLVar: TSQLVarData;
3110 begin
3111 if FIBXSQLVAR.UniqueName then
3112 inherited SetAsBcd(AValue)
3113 else
3114 with FIBXSQLVAR.Parent do
3115 begin
3116 for i := 0 to Count - 1 do
3117 if Column[i].Name = Name then
3118 begin
3119 OldSQLVar := FIBXSQLVAR;
3120 FIBXSQLVAR := Column[i];
3121 try
3122 inherited SetAsBcd(AValue);
3123 finally
3124 FIBXSQLVAR := OldSQLVar;
3125 end;
3126 end;
3127 end;
3128 end;
3129
3130 { TMetaData }
3131
3132 procedure TMetaData.CheckActive;
3133 begin
3134 if FPrepareSeqNo < FMetaData.PrepareSeqNo then
3135 IBError(ibxeInterfaceOutofDate,[nil]);
3136
3137 if not FMetaData.CheckStatementStatus(ssPrepared) then
3138 IBError(ibxeStatementNotPrepared, [nil]);
3139 end;
3140
3141 constructor TMetaData.Create(aMetaData: TSQLDataArea);
3142 begin
3143 inherited Create(aMetaData.Count);
3144 FMetaData := aMetaData;
3145 FStatement := aMetaData.Statement;
3146 FPrepareSeqNo := aMetaData.PrepareSeqNo;
3147 end;
3148
3149 destructor TMetaData.Destroy;
3150 begin
3151 (FStatement as TInterfaceOwner).Remove(self);
3152 inherited Destroy;
3153 end;
3154
3155 function TMetaData.GetUniqueRelationName: AnsiString;
3156 begin
3157 CheckActive;
3158 Result := FMetaData.UniqueRelationName;
3159 end;
3160
3161 function TMetaData.getCount: integer;
3162 begin
3163 CheckActive;
3164 Result := FMetaData.ColumnsInUseCount;
3165 end;
3166
3167 function TMetaData.getColumnMetaData(index: integer): IColumnMetaData;
3168 begin
3169 CheckActive;
3170 if (index < 0) or (index >= getCount) then
3171 IBError(ibxeInvalidColumnIndex,[nil]);
3172
3173 if FMetaData.Count = 0 then
3174 Result := nil
3175 else
3176 begin
3177 if not HasInterface(index) then
3178 AddInterface(index,TColumnMetaData.Create(self,FMetaData.Column[index]));
3179 Result := TColumnMetaData(GetInterface(index));
3180 end;
3181 end;
3182
3183 function TMetaData.ByName(Idx: AnsiString): IColumnMetaData;
3184 var aIBXSQLVAR: TSQLVarData;
3185 begin
3186 CheckActive;
3187 aIBXSQLVAR := FMetaData.ColumnByName(Idx);
3188 if aIBXSQLVAR = nil then
3189 IBError(ibxeFieldNotFound,[Idx]);
3190 Result := getColumnMetaData(aIBXSQLVAR.index);
3191 end;
3192
3193 { TSQLParams }
3194
3195 procedure TSQLParams.CheckActive;
3196 begin
3197 if not FSQLParams.StateChanged(FChangeSeqNo) then Exit;
3198
3199 if FPrepareSeqNo < FSQLParams.PrepareSeqNo then
3200 IBError(ibxeInterfaceOutofDate,[nil]);
3201
3202 if not FSQLParams.CheckStatementStatus(ssPrepared) then
3203 IBError(ibxeStatementNotPrepared, [nil]);
3204 end;
3205
3206 constructor TSQLParams.Create(aSQLParams: TSQLDataArea);
3207 begin
3208 inherited Create(aSQLParams.Count);
3209 FSQLParams := aSQLParams;
3210 FStatement := aSQLParams.Statement;
3211 FPrepareSeqNo := aSQLParams.PrepareSeqNo;
3212 FSQLParams.StateChanged(FChangeSeqNo);
3213 end;
3214
3215 destructor TSQLParams.Destroy;
3216 begin
3217 (FStatement as TInterfaceOwner).Remove(self);
3218 inherited Destroy;
3219 end;
3220
3221 function TSQLParams.getCount: integer;
3222 begin
3223 CheckActive;
3224 Result := FSQLParams.ColumnsInUseCount;
3225 end;
3226
3227 function TSQLParams.getSQLParam(index: integer): ISQLParam;
3228 begin
3229 CheckActive;
3230 if (index < 0) or (index >= getCount) then
3231 IBError(ibxeInvalidColumnIndex,[nil]);
3232
3233 if getCount = 0 then
3234 Result := nil
3235 else
3236 begin
3237 if not HasInterface(index) then
3238 AddInterface(index, TSQLParam.Create(self,FSQLParams.Column[index]));
3239 Result := TSQLParam(GetInterface(index));
3240 end;
3241 end;
3242
3243 function TSQLParams.ByName(Idx: AnsiString): ISQLParam;
3244 var aIBXSQLVAR: TSQLVarData;
3245 begin
3246 CheckActive;
3247 aIBXSQLVAR := FSQLParams.ColumnByName(Idx);
3248 if aIBXSQLVAR = nil then
3249 IBError(ibxeFieldNotFound,[Idx]);
3250 Result := getSQLParam(aIBXSQLVAR.index);
3251 end;
3252
3253 function TSQLParams.GetModified: Boolean;
3254 var
3255 i: Integer;
3256 begin
3257 CheckActive;
3258 result := False;
3259 with FSQLParams do
3260 for i := 0 to Count - 1 do
3261 if Column[i].Modified then
3262 begin
3263 result := True;
3264 exit;
3265 end;
3266 end;
3267
3268 function TSQLParams.GetHasCaseSensitiveParams: Boolean;
3269 begin
3270 Result := FSQLParams.CaseSensitiveParams;
3271 end;
3272
3273 { TResults }
3274
3275 procedure TResults.CheckActive;
3276 begin
3277 if not FResults.StateChanged(FChangeSeqNo) then Exit;
3278
3279 if FPrepareSeqNo < FResults.PrepareSeqNo then
3280 IBError(ibxeInterfaceOutofDate,[nil]);
3281
3282 if not FResults.CheckStatementStatus(ssPrepared) then
3283 IBError(ibxeStatementNotPrepared, [nil]);
3284
3285 with GetTransaction do
3286 if not InTransaction or (FResults.TransactionSeqNo <> FTransactionSeqNo) then
3287 IBError(ibxeInterfaceOutofDate,[nil]);
3288 end;
3289
3290 function TResults.GetISQLData(aIBXSQLVAR: TSQLVarData): ISQLData;
3291 var col: TIBSQLData;
3292 begin
3293 if (aIBXSQLVAR.Index < 0) or (aIBXSQLVAR.Index >= getCount) then
3294 IBError(ibxeInvalidColumnIndex,[nil]);
3295
3296 if not HasInterface(aIBXSQLVAR.Index) then
3297 AddInterface(aIBXSQLVAR.Index, TIBSQLData.Create(self,aIBXSQLVAR));
3298 col := TIBSQLData(GetInterface(aIBXSQLVAR.Index));
3299 col.FTransaction := GetTransaction;
3300 Result := col;
3301 end;
3302
3303 constructor TResults.Create(aResults: TSQLDataArea);
3304 begin
3305 inherited Create(aResults.Count);
3306 FResults := aResults;
3307 FStatement := aResults.Statement;
3308 FPrepareSeqNo := aResults.PrepareSeqNo;
3309 FTransactionSeqNo := aResults.TransactionSeqNo;
3310 FResults.StateChanged(FChangeSeqNo);
3311 end;
3312
3313 function TResults.getCount: integer;
3314 begin
3315 CheckActive;
3316 Result := FResults.Count;
3317 end;
3318
3319 function TResults.ByName(Idx: AnsiString): ISQLData;
3320 var col: TSQLVarData;
3321 begin
3322 Result := nil;
3323 CheckActive;
3324 if FResults.CheckStatementStatus(ssBOF) then
3325 IBError(ibxeBOF,[nil]);
3326 if FResults.CheckStatementStatus(ssEOF) then
3327 IBError(ibxeEOF,[nil]);
3328
3329 if FResults.Count > 0 then
3330 begin
3331 col := FResults.ColumnByName(Idx);
3332 if col <> nil then
3333 Result := GetISQLData(col);
3334 end;
3335 end;
3336
3337 function TResults.getSQLData(index: integer): ISQLData;
3338 begin
3339 CheckActive;
3340 if FResults.CheckStatementStatus(ssBOF) then
3341 IBError(ibxeBOF,[nil]);
3342 if FResults.CheckStatementStatus(ssEOF) then
3343 IBError(ibxeEOF,[nil]);
3344 if (index < 0) or (index >= FResults.Count) then
3345 IBError(ibxeInvalidColumnIndex,[nil]);
3346
3347 Result := GetISQLData(FResults.Column[index]);
3348 end;
3349
3350 procedure TResults.GetData(index: integer; var IsNull: boolean; var len: short;
3351 var data: PByte);
3352 begin
3353 CheckActive;
3354 FResults.GetData(index,IsNull, len,data);
3355 end;
3356
3357 function TResults.GetStatement: IStatement;
3358 begin
3359 Result := FStatement;
3360 end;
3361
3362 function TResults.GetTransaction: ITransaction;
3363 begin
3364 Result := FStatement.GetTransaction;
3365 end;
3366
3367 procedure TResults.SetRetainInterfaces(aValue: boolean);
3368 begin
3369 RetainInterfaces := aValue;
3370 end;
3371
3372 end.
3373