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