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