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