ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/fbintf/client/FBSQLData.pas
Revision: 345
Committed: Mon Aug 23 14:22:29 2021 UTC (2 years, 7 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/FBSQLData.pas
File size: 87673 byte(s)
Log Message:
Merged into public release

File Contents

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