ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/client/FBSQLData.pas
Revision: 270
Committed: Fri Jan 18 11:10:37 2019 UTC (5 years, 2 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/FBSQLData.pas
File size: 64477 byte(s)
Log Message:
Fixes merged

File Contents

# Content
1 (*
2 * Firebird Interface (fbintf). The fbintf components provide a set of
3 * Pascal language bindings for the Firebird API. Although predominantly
4 * a new development they include source code taken from IBX and may be
5 * considered a derived product. This software thus also includes the copyright
6 * notice and license conditions from IBX.
7 *
8 * Except for those parts dervied from IBX, contents of this file are subject
9 * to the Initial Developer's Public License Version 1.0 (the "License"); you
10 * may not use this file except in compliance with the License. You may obtain a
11 * copy of the License here:
12 *
13 * http://www.firebirdsql.org/index.php?op=doc&id=idpl
14 *
15 * Software distributed under the License is distributed on an "AS
16 * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
17 * implied. See the License for the specific language governing rights
18 * and limitations under the License.
19 *
20 * The Initial Developer of the Original Code is Tony Whyman.
21 *
22 * The Original Code is (C) 2016 Tony Whyman, MWA Software
23 * (http://www.mwasoftware.co.uk).
24 *
25 * All Rights Reserved.
26 *
27 * Contributor(s): ______________________________________.
28 *
29 *)
30 {************************************************************************}
31 { }
32 { Borland Delphi Visual Component Library }
33 { InterBase Express core components }
34 { }
35 { Copyright (c) 1998-2000 Inprise Corporation }
36 { }
37 { InterBase Express is based in part on the product }
38 { Free IB Components, written by Gregory H. Deatz for }
39 { Hoagland, Longo, Moran, Dunst & Doukas Company. }
40 { Free IB Components is used under license. }
41 { }
42 { The contents of this file are subject to the InterBase }
43 { Public License Version 1.0 (the "License"); you may not }
44 { use this file except in compliance with the License. You }
45 { may obtain a copy of the License at http://www.Inprise.com/IPL.html }
46 { Software distributed under the License is distributed on }
47 { an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
48 { express or implied. See the License for the specific language }
49 { governing rights and limitations under the License. }
50 { The Original Code was created by InterBase Software Corporation }
51 { and its successors. }
52 { Portions created by Inprise Corporation are Copyright (C) Inprise }
53 { Corporation. All Rights Reserved. }
54 { Contributor(s): Jeff Overcash }
55 { }
56 { IBX For Lazarus (Firebird Express) }
57 { Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
58 { Portions created by MWA Software are copyright McCallum Whyman }
59 { Associates Ltd 2011 - 2015 }
60 { }
61 {************************************************************************}
62 unit FBSQLData;
63 {$IFDEF MSWINDOWS}
64 {$DEFINE WINDOWS}
65 {$ENDIF}
66
67 {$IFDEF FPC}
68 {$mode delphi}
69 {$codepage UTF8}
70 {$interfaces COM}
71 {$ENDIF}
72
73 { This Unit was hacked out of the IBSQL unit and defines a class used as the
74 base for interfaces accessing SQLDAVar data and Array Elements. The abstract
75 methods are used to customise for an SQLDAVar or Array Element. The empty
76 methods are needed for SQL parameters only. The string getters and setters
77 are virtual as SQLVar and Array encodings of string data is different.}
78
79
80 interface
81
82 uses
83 Classes, SysUtils, IBExternals, IBHeader, IB, FBActivityMonitor, FBClientAPI;
84
85 type
86
87 { TSQLDataItem }
88
89 TSQLDataItem = class(TFBInterfacedObject)
90 private
91 FFirebirdClientAPI: TFBClientAPI;
92 function AdjustScale(Value: Int64; aScale: Integer): Double;
93 function AdjustScaleToInt64(Value: Int64; aScale: Integer): Int64;
94 function AdjustScaleToCurrency(Value: Int64; aScale: Integer): Currency;
95 function GetTimestampFormatStr: AnsiString;
96 function GetDateFormatStr(IncludeTime: boolean): AnsiString;
97 function GetTimeFormatStr: AnsiString;
98 procedure SetAsInteger(AValue: Integer);
99 protected
100 function AdjustScaleFromCurrency(Value: Currency; aScale: Integer): Int64;
101 function AdjustScaleFromDouble(Value: Double; aScale: Integer): Int64;
102 procedure CheckActive; virtual;
103 function GetSQLDialect: integer; virtual; abstract;
104 procedure Changed; virtual;
105 procedure Changing; virtual;
106 procedure InternalSetAsString(Value: AnsiString); virtual;
107 function SQLData: PByte; virtual; abstract;
108 function GetDataLength: cardinal; virtual; abstract;
109 function GetCodePage: TSystemCodePage; virtual; abstract;
110 function getCharSetID: cardinal; virtual; abstract;
111 function Transliterate(s: AnsiString; CodePage: TSystemCodePage): RawByteString;
112 procedure SetScale(aValue: integer); virtual;
113 procedure SetDataLength(len: cardinal); virtual;
114 procedure SetSQLType(aValue: cardinal); virtual;
115 property DataLength: cardinal read GetDataLength write SetDataLength;
116
117 public
118 constructor Create(api: TFBClientAPI);
119 function GetSQLType: cardinal; virtual; abstract;
120 function GetSQLTypeName: AnsiString; overload;
121 class function GetSQLTypeName(SQLType: short): AnsiString; overload;
122 function GetName: AnsiString; virtual; abstract;
123 function GetScale: integer; virtual; abstract;
124 function GetAsBoolean: boolean;
125 function GetAsCurrency: Currency;
126 function GetAsInt64: Int64;
127 function GetAsDateTime: TDateTime;
128 function GetAsDouble: Double;
129 function GetAsFloat: Float;
130 function GetAsLong: Long;
131 function GetAsPointer: Pointer;
132 function GetAsQuad: TISC_QUAD;
133 function GetAsShort: short;
134 function GetAsString: AnsiString; virtual;
135 function GetIsNull: Boolean; virtual;
136 function GetIsNullable: boolean; virtual;
137 function GetAsVariant: Variant;
138 function GetModified: boolean; virtual;
139 function GetDateTimeStrLength(DateTimeFormat: TIBDateTimeFormats): integer;
140 procedure SetAsBoolean(AValue: boolean); virtual;
141 procedure SetAsCurrency(Value: Currency); virtual;
142 procedure SetAsInt64(Value: Int64); virtual;
143 procedure SetAsDate(Value: TDateTime); virtual;
144 procedure SetAsLong(Value: Long); virtual;
145 procedure SetAsTime(Value: TDateTime); virtual;
146 procedure SetAsDateTime(Value: TDateTime);
147 procedure SetAsDouble(Value: Double); virtual;
148 procedure SetAsFloat(Value: Float); virtual;
149 procedure SetAsPointer(Value: Pointer);
150 procedure SetAsQuad(Value: TISC_QUAD);
151 procedure SetAsShort(Value: short); virtual;
152 procedure SetAsString(Value: AnsiString); virtual;
153 procedure SetAsVariant(Value: Variant);
154 procedure SetAsNumeric(Value: Int64; aScale: integer);
155 procedure SetIsNull(Value: Boolean); virtual;
156 procedure SetIsNullable(Value: Boolean); virtual;
157 procedure SetName(aValue: AnsiString); virtual;
158 property AsDate: TDateTime read GetAsDateTime write SetAsDate;
159 property AsBoolean:boolean read GetAsBoolean write SetAsBoolean;
160 property AsTime: TDateTime read GetAsDateTime write SetAsTime;
161 property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
162 property AsDouble: Double read GetAsDouble write SetAsDouble;
163 property AsFloat: Float read GetAsFloat write SetAsFloat;
164 property AsCurrency: Currency read GetAsCurrency write SetAsCurrency;
165 property AsInt64: Int64 read GetAsInt64 write SetAsInt64;
166 property AsInteger: Integer read GetAsLong write SetAsInteger;
167 property AsLong: Long read GetAsLong write SetAsLong;
168 property AsPointer: Pointer read GetAsPointer write SetAsPointer;
169 property AsQuad: TISC_QUAD read GetAsQuad write SetAsQuad;
170 property AsShort: short read GetAsShort write SetAsShort;
171 property AsString: AnsiString read GetAsString write SetAsString;
172 property AsVariant: Variant read GetAsVariant write SetAsVariant;
173 property Modified: Boolean read getModified;
174 property IsNull: Boolean read GetIsNull write SetIsNull;
175 property IsNullable: Boolean read GetIsNullable write SetIsNullable;
176 property Scale: integer read GetScale write SetScale;
177 property SQLType: cardinal read GetSQLType write SetSQLType;
178 end;
179
180 TSQLVarData = class;
181
182 TStatementStatus = (ssPrepared, ssExecuteResults, ssCursorOpen, ssBOF, ssEOF);
183
184 { TSQLDataArea }
185
186 TSQLDataArea = class
187 private
188 FCaseSensitiveParams: boolean;
189 function GetColumn(index: integer): TSQLVarData;
190 function GetCount: integer;
191 protected
192 FUniqueRelationName: AnsiString;
193 FColumnList: array of TSQLVarData;
194 function GetStatement: IStatement; virtual; abstract;
195 function GetPrepareSeqNo: integer; virtual; abstract;
196 function GetTransactionSeqNo: integer; virtual; abstract;
197 procedure SetCount(aValue: integer); virtual; abstract;
198 procedure SetUniqueRelationName;
199 public
200 procedure Initialize; virtual;
201 function IsInputDataArea: boolean; virtual; abstract; {Input to Database}
202 procedure PreprocessSQL(sSQL: AnsiString; GenerateParamNames: boolean;
203 var sProcessedSQL: AnsiString);
204 function ColumnsInUseCount: integer; virtual;
205 function ColumnByName(Idx: AnsiString): TSQLVarData;
206 function CheckStatementStatus(Request: TStatementStatus): boolean; virtual; abstract;
207 procedure GetData(index: integer; var IsNull: boolean; var len: short;
208 var data: PByte); virtual;
209 procedure RowChange;
210 function StateChanged(var ChangeSeqNo: integer): boolean; virtual; abstract;
211 property CaseSensitiveParams: boolean read FCaseSensitiveParams
212 write FCaseSensitiveParams; {Only used when IsInputDataArea true}
213 property Count: integer read GetCount;
214 property Column[index: integer]: TSQLVarData read GetColumn;
215 property UniqueRelationName: AnsiString read FUniqueRelationName;
216 property Statement: IStatement read GetStatement;
217 property PrepareSeqNo: integer read GetPrepareSeqNo;
218 property TransactionSeqNo: integer read GetTransactionSeqNo;
219 end;
220
221 { TSQLVarData }
222
223 TSQLVarData = class
224 private
225 FParent: TSQLDataArea;
226 FName: AnsiString;
227 FIndex: integer;
228 FModified: boolean;
229 FUniqueName: boolean;
230 FVarString: RawByteString;
231 function GetStatement: IStatement;
232 procedure SetName(AValue: AnsiString);
233 protected
234 function GetSQLType: cardinal; virtual; abstract;
235 function GetSubtype: integer; virtual; abstract;
236 function GetAliasName: AnsiString; virtual; abstract;
237 function GetFieldName: AnsiString; virtual; abstract;
238 function GetOwnerName: AnsiString; virtual; abstract;
239 function GetRelationName: AnsiString; virtual; abstract;
240 function GetScale: integer; virtual; abstract;
241 function GetCharSetID: cardinal; virtual; abstract;
242 function GetCodePage: TSystemCodePage; virtual; abstract;
243 function GetIsNull: Boolean; virtual; abstract;
244 function GetIsNullable: boolean; virtual; abstract;
245 function GetSQLData: PByte; virtual; abstract;
246 function GetDataLength: cardinal; virtual; abstract;
247 procedure SetIsNull(Value: Boolean); virtual; abstract;
248 procedure SetIsNullable(Value: Boolean); virtual; abstract;
249 procedure SetSQLData(AValue: PByte; len: cardinal); virtual; abstract;
250 procedure SetScale(aValue: integer); virtual; abstract;
251 procedure SetDataLength(len: cardinal); virtual; abstract;
252 procedure SetSQLType(aValue: cardinal); virtual; abstract;
253 procedure SetCharSetID(aValue: cardinal); virtual; abstract;
254 public
255 constructor Create(aParent: TSQLDataArea; aIndex: integer);
256 procedure SetString(aValue: AnsiString);
257 procedure Changed; virtual;
258 procedure RowChange; virtual;
259 function GetAsArray(Array_ID: TISC_QUAD): IArray; virtual; abstract;
260 function GetAsBlob(Blob_ID: TISC_QUAD; BPB: IBPB): IBlob; virtual; abstract;
261 function CreateBlob: IBlob; virtual; abstract;
262 function GetArrayMetaData: IArrayMetaData; virtual; abstract;
263 function GetBlobMetaData: IBlobMetaData; virtual; abstract;
264 procedure Initialize; virtual;
265
266 public
267 property AliasName: AnsiString read GetAliasName;
268 property FieldName: AnsiString read GetFieldName;
269 property OwnerName: AnsiString read GetOwnerName;
270 property RelationName: AnsiString read GetRelationName;
271 property Parent: TSQLDataArea read FParent;
272 property Index: integer read FIndex;
273 property Name: AnsiString read FName write SetName;
274 property CharSetID: cardinal read GetCharSetID write SetCharSetID;
275 property SQLType: cardinal read GetSQLType write SetSQLType;
276 property SQLSubtype: integer read GetSubtype;
277 property SQLData: PByte read GetSQLData;
278 property DataLength: cardinal read GetDataLength write SetDataLength;
279 property IsNull: Boolean read GetIsNull write SetIsNull;
280 property IsNullable: Boolean read GetIsNullable write SetIsNullable;
281 property Scale: integer read GetScale write SetScale;
282 public
283 property Modified: Boolean read FModified;
284 property Statement: IStatement read GetStatement;
285 property UniqueName: boolean read FUniqueName write FUniqueName;
286 end;
287
288 { TColumnMetaData }
289
290 TColumnMetaData = class(TSQLDataItem,IColumnMetaData)
291 private
292 FIBXSQLVAR: TSQLVarData;
293 FOwner: IUnknown; {Keep reference to ensure Metadata/statement not discarded}
294 FPrepareSeqNo: integer;
295 FStatement: IStatement;
296 FChangeSeqNo: integer;
297 protected
298 procedure CheckActive; override;
299 function SQLData: PByte; override;
300 function GetDataLength: cardinal; override;
301 function GetCodePage: TSystemCodePage; override;
302
303 public
304 constructor Create(aOwner: IUnknown; aIBXSQLVAR: TSQLVarData);
305 destructor Destroy; override;
306 function GetSQLDialect: integer; override;
307 property Statement: IStatement read FStatement;
308
309 public
310 {IColumnMetaData}
311 function GetIndex: integer;
312 function GetSQLType: cardinal; override;
313 function getSubtype: integer;
314 function getRelationName: AnsiString;
315 function getOwnerName: AnsiString;
316 function getSQLName: AnsiString; {Name of the column}
317 function getAliasName: AnsiString; {Alias Name of column or Column Name if not alias}
318 function GetName: AnsiString; override; {Disambiguated uppercase Field Name}
319 function GetScale: integer; override;
320 function getCharSetID: cardinal; override;
321 function GetIsNullable: boolean; override;
322 function GetSize: cardinal;
323 function GetArrayMetaData: IArrayMetaData;
324 function GetBlobMetaData: IBlobMetaData;
325 property Name: AnsiString read GetName;
326 property Size: cardinal read GetSize;
327 property CharSetID: cardinal read getCharSetID;
328 property SQLSubtype: integer read getSubtype;
329 property IsNullable: Boolean read GetIsNullable;
330 end;
331
332 { TIBSQLData }
333
334 TIBSQLData = class(TColumnMetaData,ISQLData)
335 protected
336 procedure CheckActive; override;
337 public
338 function GetIsNull: Boolean; override;
339 function GetAsArray: IArray;
340 function GetAsBlob: IBlob; overload;
341 function GetAsBlob(BPB: IBPB): IBlob; overload;
342 function GetAsString: AnsiString; override;
343 property AsBlob: IBlob read GetAsBlob;
344 end;
345
346 { TSQLParam }
347
348 TSQLParam = class(TIBSQLData,ISQLParam)
349 protected
350 procedure CheckActive; override;
351 procedure Changed; override;
352 procedure InternalSetAsString(Value: AnsiString); override;
353 procedure SetScale(aValue: integer); override;
354 procedure SetDataLength(len: cardinal); override;
355 procedure SetSQLType(aValue: cardinal); override;
356 public
357 procedure Clear;
358 function GetModified: boolean; override;
359 function GetAsPointer: Pointer;
360 procedure SetName(Value: AnsiString); override;
361 procedure SetIsNull(Value: Boolean); override;
362 procedure SetIsNullable(Value: Boolean); override;
363 procedure SetAsArray(anArray: IArray);
364
365 {overrides}
366 procedure SetAsBoolean(AValue: boolean);
367 procedure SetAsCurrency(AValue: Currency);
368 procedure SetAsInt64(AValue: Int64);
369 procedure SetAsDate(AValue: TDateTime);
370 procedure SetAsLong(AValue: Long);
371 procedure SetAsTime(AValue: TDateTime);
372 procedure SetAsDateTime(AValue: TDateTime);
373 procedure SetAsDouble(AValue: Double);
374 procedure SetAsFloat(AValue: Float);
375 procedure SetAsPointer(AValue: Pointer);
376 procedure SetAsShort(AValue: Short);
377 procedure SetAsString(AValue: AnsiString); override;
378 procedure SetAsVariant(AValue: Variant);
379 procedure SetAsBlob(aValue: IBlob);
380 procedure SetAsQuad(AValue: TISC_QUAD);
381 procedure SetCharSetID(aValue: cardinal);
382
383 property AsBlob: IBlob read GetAsBlob write SetAsBlob;
384 property IsNullable: Boolean read GetIsNullable write SetIsNullable;
385 end;
386
387 { TMetaData }
388
389 TMetaData = class(TInterfaceOwner,IMetaData)
390 private
391 FPrepareSeqNo: integer;
392 FMetaData: TSQLDataArea;
393 FStatement: IStatement; {ensure FStatement not destroyed until no longer needed}
394 procedure CheckActive;
395 public
396 constructor Create(aMetaData: TSQLDataArea);
397 destructor Destroy; override;
398 public
399 {IMetaData}
400 function GetUniqueRelationName: AnsiString;
401 function getCount: integer;
402 function getColumnMetaData(index: integer): IColumnMetaData;
403 function ByName(Idx: AnsiString): IColumnMetaData;
404 end;
405
406 { TSQLParams }
407
408 TSQLParams = class(TInterfaceOwner,ISQLParams)
409 private
410 FPrepareSeqNo: integer;
411 FChangeSeqNo: integer;
412 FSQLParams: TSQLDataArea;
413 FStatement: IStatement; {ensure FStatement not destroyed until no longer needed}
414 procedure CheckActive;
415 public
416 constructor Create(aSQLParams: TSQLDataArea);
417 destructor Destroy; override;
418 public
419 {ISQLParams}
420 function getCount: integer;
421 function getSQLParam(index: integer): ISQLParam;
422 function ByName(Idx: AnsiString): ISQLParam ;
423 function GetModified: Boolean;
424 end;
425
426 { TResults }
427
428 TResults = class(TInterfaceOwner,IResults)
429 private
430 FPrepareSeqNo: integer;
431 FTransactionSeqNo: integer;
432 FChangeSeqNo: integer;
433 FResults: TSQLDataArea;
434 FStatement: IStatement; {ensure FStatement not destroyed until no longer needed}
435 function GetISQLData(aIBXSQLVAR: TSQLVarData): ISQLData;
436 protected
437 procedure CheckActive;
438 public
439 constructor Create(aResults: TSQLDataArea);
440 {IResults}
441 function getCount: integer;
442 function ByName(Idx: AnsiString): ISQLData;
443 function getSQLData(index: integer): ISQLData;
444 procedure GetData(index: integer; var IsNull:boolean; var len: short; var data: PByte);
445 function GetTransaction: ITransaction; virtual;
446 procedure SetRetainInterfaces(aValue: boolean);
447 end;
448
449 implementation
450
451 uses FBMessages, variants, IBUtils, FBTransaction, DateUtils;
452
453 { TSQLDataArea }
454
455 function TSQLDataArea.GetColumn(index: integer): TSQLVarData;
456 begin
457 if (index < 0) or (index >= Count) then
458 IBError(ibxeInvalidColumnIndex,[nil]);
459 Result := FColumnList[index];
460 end;
461
462 function TSQLDataArea.GetCount: integer;
463 begin
464 Result := Length(FColumnList);
465 end;
466
467 procedure TSQLDataArea.SetUniqueRelationName;
468 var
469 i: Integer;
470 bUnique: Boolean;
471 RelationName: AnsiString;
472 begin
473 bUnique := True;
474 for i := 0 to ColumnsInUseCount - 1 do
475 begin
476 RelationName := Column[i].RelationName;
477
478 {First get the unique relation name, if any}
479
480 if bUnique and (RelationName <> '') then
481 begin
482 if FUniqueRelationName = '' then
483 FUniqueRelationName := RelationName
484 else
485 if RelationName <> FUniqueRelationName then
486 begin
487 FUniqueRelationName := '';
488 bUnique := False;
489 end;
490 end;
491 end;
492 end;
493
494 procedure TSQLDataArea.Initialize;
495 var
496 i: Integer;
497 begin
498 for i := 0 to ColumnsInUseCount - 1 do
499 Column[i].Initialize;
500 end;
501
502 procedure TSQLDataArea.PreprocessSQL(sSQL: AnsiString; GenerateParamNames: boolean;
503 var sProcessedSQL: AnsiString);
504
505 var slNames: TStrings;
506
507 procedure SetColumnNames(slNames: TStrings);
508 var i, j: integer;
509 found: boolean;
510 begin
511 found := false;
512 SetCount(slNames.Count);
513 for i := 0 to slNames.Count - 1 do
514 begin
515 Column[i].Name := slNames[i];
516 Column[i].UniqueName := (slNames.Objects[i] <> nil);
517 end;
518 for i := 0 to Count - 1 do
519 begin
520 if not Column[i].UniqueName then
521 begin
522 found := false;
523 for j := i + 1 to Count - 1 do
524 if Column[i].Name = Column[j].Name then
525 begin
526 found := true;
527 break;
528 end;
529 Column[i].UniqueName := not found;
530 end;
531 end;
532 end;
533
534 begin
535 if not IsInputDataArea then
536 IBError(ibxeNotPermitted,[nil]);
537
538 slNames := TStringList.Create;
539 try
540 sProcessedSQL := TSQLParamProcessor.Execute(sSQL,GenerateParamNames,slNames);
541 SetColumnNames(slNames);
542 finally
543 slNames.Free;
544 end;
545 end;
546
547 function TSQLDataArea.ColumnsInUseCount: integer;
548 begin
549 Result := Count;
550 end;
551
552 function TSQLDataArea.ColumnByName(Idx: AnsiString): TSQLVarData;
553 var
554 s: AnsiString;
555 i: Integer;
556 begin
557 if not IsInputDataArea or not CaseSensitiveParams then
558 s := AnsiUpperCase(Idx)
559 else
560 s := Idx;
561
562 for i := 0 to Count - 1 do
563 if Column[i].Name = s then
564 begin
565 Result := Column[i];
566 Exit;
567 end;
568 Result := nil;
569 end;
570
571 procedure TSQLDataArea.GetData(index: integer; var IsNull: boolean;
572 var len: short; var data: PByte);
573 begin
574 //Do Nothing
575 end;
576
577 procedure TSQLDataArea.RowChange;
578 var i: integer;
579 begin
580 for i := 0 to Count - 1 do
581 Column[i].RowChange;
582 end;
583
584 {TSQLVarData}
585
586 function TSQLVarData.GetStatement: IStatement;
587 begin
588 Result := FParent.Statement;
589 end;
590
591 procedure TSQLVarData.SetName(AValue: AnsiString);
592 begin
593 if not Parent.IsInputDataArea or not Parent.CaseSensitiveParams then
594 FName := AnsiUpperCase(AValue)
595 else
596 FName := AValue;
597 end;
598
599 constructor TSQLVarData.Create(aParent: TSQLDataArea; aIndex: integer);
600 begin
601 inherited Create;
602 FParent := aParent;
603 FIndex := aIndex;
604 FUniqueName := true;
605 end;
606
607 procedure TSQLVarData.SetString(aValue: AnsiString);
608 begin
609 {we take full advantage here of reference counted strings. When setting a string
610 value, a reference is kept in FVarString and a pointer to it placed in the
611 SQLVar. This avoids string copies. Note that PAnsiChar is guaranteed to point to
612 a zero byte when the string is empty, neatly avoiding a nil pointer error.}
613
614 FVarString := aValue;
615 SQLType := SQL_TEXT;
616 Scale := 0;
617 SetSQLData(PByte(PAnsiChar(FVarString)),Length(aValue));
618 end;
619
620 procedure TSQLVarData.Changed;
621 begin
622 FModified := true;
623 end;
624
625 procedure TSQLVarData.RowChange;
626 begin
627 FModified := false;
628 FVarString := '';
629 end;
630
631 procedure TSQLVarData.Initialize;
632
633 function FindVarByName(idx: AnsiString; limit: integer): TSQLVarData;
634 var
635 k: integer;
636 begin
637 for k := 0 to limit do
638 if Parent.Column[k].Name = idx then
639 begin
640 Result := Parent.Column[k];
641 Exit;
642 end;
643 Result := nil;
644 end;
645
646 var
647 j, j_len: Integer;
648 st: AnsiString;
649 sBaseName: AnsiString;
650 begin
651 RowChange;
652
653 {If an output SQLDA then copy the aliasname to the FName. Ensure
654 that they are all upper case only and disambiguated.
655 }
656
657 if not Parent.IsInputDataArea then
658 begin
659 st := Space2Underscore(AnsiUppercase(AliasName));
660 if st = '' then
661 begin
662 sBaseName := 'F_'; {do not localize}
663 j := 1; j_len := 1;
664 st := sBaseName + IntToStr(j);
665 end
666 else
667 begin
668 j := 0; j_len := 0;
669 sBaseName := st;
670 end;
671
672 {Look for other columns with the same name and make unique}
673
674 while FindVarByName(st,Index-1) <> nil do
675 begin
676 Inc(j);
677 j_len := Length(IntToStr(j));
678 if j_len + Length(sBaseName) > 31 then
679 st := system.Copy(sBaseName, 1, 31 - j_len) + IntToStr(j)
680 else
681 st := sBaseName + IntToStr(j);
682 end;
683
684 Name := st;
685 end;
686 end;
687
688 {TSQLDataItem}
689
690 function TSQLDataItem.AdjustScale(Value: Int64; aScale: Integer): Double;
691 var
692 Scaling : Int64;
693 i: Integer;
694 Val: Double;
695 begin
696 Scaling := 1; Val := Value;
697 if aScale > 0 then
698 begin
699 for i := 1 to aScale do
700 Scaling := Scaling * 10;
701 result := Val * Scaling;
702 end
703 else
704 if aScale < 0 then
705 begin
706 for i := -1 downto aScale do
707 Scaling := Scaling * 10;
708 result := Val / Scaling;
709 end
710 else
711 result := Val;
712 end;
713
714 function TSQLDataItem.AdjustScaleToInt64(Value: Int64; aScale: Integer): Int64;
715 var
716 Scaling : Int64;
717 i: Integer;
718 Val: Int64;
719 begin
720 Scaling := 1; Val := Value;
721 if aScale > 0 then begin
722 for i := 1 to aScale do Scaling := Scaling * 10;
723 result := Val * Scaling;
724 end else if aScale < 0 then begin
725 for i := -1 downto aScale do Scaling := Scaling * 10;
726 result := Val div Scaling;
727 end else
728 result := Val;
729 end;
730
731 function TSQLDataItem.AdjustScaleToCurrency(Value: Int64; aScale: Integer
732 ): Currency;
733 var
734 Scaling : Int64;
735 i : Integer;
736 FractionText, PadText, CurrText: AnsiString;
737 begin
738 Result := 0;
739 Scaling := 1;
740 PadText := '';
741 if aScale > 0 then
742 begin
743 for i := 1 to aScale do
744 Scaling := Scaling * 10;
745 result := Value * Scaling;
746 end
747 else
748 if aScale < 0 then
749 begin
750 for i := -1 downto aScale do
751 Scaling := Scaling * 10;
752 FractionText := IntToStr(abs(Value mod Scaling));
753 for i := Length(FractionText) to -aScale -1 do
754 PadText := '0' + PadText;
755 {$IF declared(DefaultFormatSettings)}
756 with DefaultFormatSettings do
757 {$ELSE}
758 {$IF declared(FormatSettings)}
759 with FormatSettings do
760 {$IFEND}
761 {$IFEND}
762 if Value < 0 then
763 CurrText := '-' + IntToStr(Abs(Value div Scaling)) + DecimalSeparator + PadText + FractionText
764 else
765 CurrText := IntToStr(Abs(Value div Scaling)) + DecimalSeparator + PadText + FractionText;
766 try
767 result := StrToCurr(CurrText);
768 except
769 on E: Exception do
770 IBError(ibxeInvalidDataConversion, [nil]);
771 end;
772 end
773 else
774 result := Value;
775 end;
776
777 function TSQLDataItem.GetDateFormatStr(IncludeTime: boolean): AnsiString;
778 begin
779 {$IF declared(DefaultFormatSettings)}
780 with DefaultFormatSettings do
781 {$ELSE}
782 {$IF declared(FormatSettings)}
783 with FormatSettings do
784 {$IFEND}
785 {$IFEND}
786 case GetSQLDialect of
787 1:
788 if IncludeTime then
789 result := ShortDateFormat + ' ' + LongTimeFormat
790 else
791 result := ShortDateFormat;
792 3:
793 result := ShortDateFormat;
794 end;
795 end;
796
797 function TSQLDataItem.GetTimeFormatStr: AnsiString;
798 begin
799 {$IF declared(DefaultFormatSettings)}
800 with DefaultFormatSettings do
801 {$ELSE}
802 {$IF declared(FormatSettings)}
803 with FormatSettings do
804 {$IFEND}
805 {$IFEND}
806 Result := LongTimeFormat;
807 end;
808
809 function TSQLDataItem.GetTimestampFormatStr: AnsiString;
810 begin
811 {$IF declared(DefaultFormatSettings)}
812 with DefaultFormatSettings do
813 {$ELSE}
814 {$IF declared(FormatSettings)}
815 with FormatSettings do
816 {$IFEND}
817 {$IFEND}
818 Result := ShortDateFormat + ' ' + LongTimeFormat + '.zzz';
819 end;
820
821 procedure TSQLDataItem.SetAsInteger(AValue: Integer);
822 begin
823 SetAsLong(aValue);
824 end;
825
826 function TSQLDataItem.AdjustScaleFromCurrency(Value: Currency; aScale: Integer
827 ): Int64;
828 var
829 Scaling : Int64;
830 i : Integer;
831 begin
832 Result := 0;
833 Scaling := 1;
834 if aScale < 0 then
835 begin
836 for i := -1 downto aScale do
837 Scaling := Scaling * 10;
838 result := trunc(Value * Scaling);
839 end
840 else
841 if aScale > 0 then
842 begin
843 for i := 1 to aScale do
844 Scaling := Scaling * 10;
845 result := trunc(Value / Scaling);
846 end
847 else
848 result := trunc(Value);
849 end;
850
851 function TSQLDataItem.AdjustScaleFromDouble(Value: Double; aScale: Integer
852 ): Int64;
853 var
854 Scaling : Int64;
855 i : Integer;
856 begin
857 Result := 0;
858 Scaling := 1;
859 if aScale < 0 then
860 begin
861 for i := -1 downto aScale do
862 Scaling := Scaling * 10;
863 result := trunc(Value * Scaling);
864 end
865 else
866 if aScale > 0 then
867 begin
868 for i := 1 to aScale do
869 Scaling := Scaling * 10;
870 result := trunc(Value / Scaling);
871 end
872 else
873 result := trunc(Value);
874 end;
875
876 procedure TSQLDataItem.CheckActive;
877 begin
878 //Do nothing by default
879 end;
880
881 procedure TSQLDataItem.Changed;
882 begin
883 //Do nothing by default
884 end;
885
886 procedure TSQLDataItem.Changing;
887 begin
888 //Do nothing by default
889 end;
890
891 procedure TSQLDataItem.InternalSetAsString(Value: AnsiString);
892 begin
893 //Do nothing by default
894 end;
895
896 function TSQLDataItem.Transliterate(s: AnsiString; CodePage: TSystemCodePage
897 ): RawByteString;
898 begin
899 Result := s;
900 if StringCodePage(Result) <> CodePage then
901 SetCodePage(Result,CodePage,CodePage <> CP_NONE);
902 end;
903
904 procedure TSQLDataItem.SetScale(aValue: integer);
905 begin
906 //Do nothing by default
907 end;
908
909 procedure TSQLDataItem.SetDataLength(len: cardinal);
910 begin
911 //Do nothing by default
912 end;
913
914 procedure TSQLDataItem.SetSQLType(aValue: cardinal);
915 begin
916 //Do nothing by default
917 end;
918
919 constructor TSQLDataItem.Create(api: TFBClientAPI);
920 begin
921 inherited Create;
922 FFirebirdClientAPI := api;
923 end;
924
925 function TSQLDataItem.GetSQLTypeName: AnsiString;
926 begin
927 Result := GetSQLTypeName(GetSQLType);
928 end;
929
930 class function TSQLDataItem.GetSQLTypeName(SQLType: short): AnsiString;
931 begin
932 Result := 'Unknown';
933 case SQLType of
934 SQL_VARYING: Result := 'SQL_VARYING';
935 SQL_TEXT: Result := 'SQL_TEXT';
936 SQL_DOUBLE: Result := 'SQL_DOUBLE';
937 SQL_FLOAT: Result := 'SQL_FLOAT';
938 SQL_LONG: Result := 'SQL_LONG';
939 SQL_SHORT: Result := 'SQL_SHORT';
940 SQL_TIMESTAMP: Result := 'SQL_TIMESTAMP';
941 SQL_BLOB: Result := 'SQL_BLOB';
942 SQL_D_FLOAT: Result := 'SQL_D_FLOAT';
943 SQL_ARRAY: Result := 'SQL_ARRAY';
944 SQL_QUAD: Result := 'SQL_QUAD';
945 SQL_TYPE_TIME: Result := 'SQL_TYPE_TIME';
946 SQL_TYPE_DATE: Result := 'SQL_TYPE_DATE';
947 SQL_INT64: Result := 'SQL_INT64';
948 end;
949 end;
950
951 function TSQLDataItem.GetAsBoolean: boolean;
952 begin
953 CheckActive;
954 result := false;
955 if not IsNull then
956 begin
957 if SQLType = SQL_BOOLEAN then
958 result := PByte(SQLData)^ = ISC_TRUE
959 else
960 IBError(ibxeInvalidDataConversion, [nil]);
961 end
962 end;
963
964 function TSQLDataItem.GetAsCurrency: Currency;
965 begin
966 CheckActive;
967 result := 0;
968 if GetSQLDialect < 3 then
969 result := GetAsDouble
970 else begin
971 if not IsNull then
972 case SQLType of
973 SQL_TEXT, SQL_VARYING: begin
974 try
975 result := StrtoCurr(AsString);
976 except
977 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
978 end;
979 end;
980 SQL_SHORT:
981 result := AdjustScaleToCurrency(Int64(PShort(SQLData)^),
982 Scale);
983 SQL_LONG:
984 result := AdjustScaleToCurrency(Int64(PLong(SQLData)^),
985 Scale);
986 SQL_INT64:
987 result := AdjustScaleToCurrency(PInt64(SQLData)^,
988 Scale);
989 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
990 result := Trunc(AsDouble);
991 else
992 IBError(ibxeInvalidDataConversion, [nil]);
993 end;
994 end;
995 end;
996
997 function TSQLDataItem.GetAsInt64: Int64;
998 begin
999 CheckActive;
1000 result := 0;
1001 if not IsNull then
1002 case SQLType of
1003 SQL_TEXT, SQL_VARYING: begin
1004 try
1005 result := StrToInt64(AsString);
1006 except
1007 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
1008 end;
1009 end;
1010 SQL_SHORT:
1011 result := AdjustScaleToInt64(Int64(PShort(SQLData)^),
1012 Scale);
1013 SQL_LONG:
1014 result := AdjustScaleToInt64(Int64(PLong(SQLData)^),
1015 Scale);
1016 SQL_INT64:
1017 result := AdjustScaleToInt64(PInt64(SQLData)^,
1018 Scale);
1019 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1020 result := Trunc(AsDouble);
1021 else
1022 IBError(ibxeInvalidDataConversion, [nil]);
1023 end;
1024 end;
1025
1026 function TSQLDataItem.GetAsDateTime: TDateTime;
1027 begin
1028 CheckActive;
1029 result := 0;
1030 if not IsNull then
1031 with FFirebirdClientAPI do
1032 case SQLType of
1033 SQL_TEXT, SQL_VARYING: begin
1034 try
1035 result := StrToDate(AsString);
1036 except
1037 on E: EConvertError do IBError(ibxeInvalidDataConversion, [nil]);
1038 end;
1039 end;
1040 SQL_TYPE_DATE:
1041 result := SQLDecodeDate(SQLData);
1042 SQL_TYPE_TIME:
1043 result := SQLDecodeTime(SQLData);
1044 SQL_TIMESTAMP:
1045 result := SQLDecodeDateTime(SQLData);
1046 else
1047 IBError(ibxeInvalidDataConversion, [nil]);
1048 end;
1049 end;
1050
1051 function TSQLDataItem.GetAsDouble: Double;
1052 begin
1053 CheckActive;
1054 result := 0;
1055 if not IsNull then begin
1056 case SQLType of
1057 SQL_TEXT, SQL_VARYING: begin
1058 try
1059 result := StrToFloat(AsString);
1060 except
1061 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
1062 end;
1063 end;
1064 SQL_SHORT:
1065 result := AdjustScale(Int64(PShort(SQLData)^),
1066 Scale);
1067 SQL_LONG:
1068 result := AdjustScale(Int64(PLong(SQLData)^),
1069 Scale);
1070 SQL_INT64:
1071 result := AdjustScale(PInt64(SQLData)^, Scale);
1072 SQL_FLOAT:
1073 result := PFloat(SQLData)^;
1074 SQL_DOUBLE, SQL_D_FLOAT:
1075 result := PDouble(SQLData)^;
1076 else
1077 IBError(ibxeInvalidDataConversion, [nil]);
1078 end;
1079 if Scale <> 0 then
1080 result :=
1081 StrToFloat(FloatToStrF(result, fffixed, 15,
1082 Abs(Scale) ));
1083 end;
1084 end;
1085
1086 function TSQLDataItem.GetAsFloat: Float;
1087 begin
1088 CheckActive;
1089 result := 0;
1090 try
1091 result := AsDouble;
1092 except
1093 on E: EOverflow do
1094 IBError(ibxeInvalidDataConversion, [nil]);
1095 end;
1096 end;
1097
1098 function TSQLDataItem.GetAsLong: Long;
1099 begin
1100 CheckActive;
1101 result := 0;
1102 if not IsNull then
1103 case SQLType of
1104 SQL_TEXT, SQL_VARYING: begin
1105 try
1106 result := StrToInt(AsString);
1107 except
1108 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
1109 end;
1110 end;
1111 SQL_SHORT:
1112 result := Trunc(AdjustScale(Int64(PShort(SQLData)^),
1113 Scale));
1114 SQL_LONG:
1115 result := Trunc(AdjustScale(Int64(PLong(SQLData)^),
1116 Scale));
1117 SQL_INT64:
1118 result := Trunc(AdjustScale(PInt64(SQLData)^, Scale));
1119 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1120 result := Trunc(AsDouble);
1121 else
1122 IBError(ibxeInvalidDataConversion, [nil]);
1123 end;
1124 end;
1125
1126 function TSQLDataItem.GetAsPointer: Pointer;
1127 begin
1128 CheckActive;
1129 if not IsNull then
1130 result := SQLData
1131 else
1132 result := nil;
1133 end;
1134
1135 function TSQLDataItem.GetAsQuad: TISC_QUAD;
1136 begin
1137 CheckActive;
1138 result.gds_quad_high := 0;
1139 result.gds_quad_low := 0;
1140 if not IsNull then
1141 case SQLType of
1142 SQL_BLOB, SQL_ARRAY, SQL_QUAD:
1143 result := PISC_QUAD(SQLData)^;
1144 else
1145 IBError(ibxeInvalidDataConversion, [nil]);
1146 end;
1147 end;
1148
1149 function TSQLDataItem.GetAsShort: short;
1150 begin
1151 CheckActive;
1152 result := 0;
1153 try
1154 result := AsLong;
1155 except
1156 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
1157 end;
1158 end;
1159
1160
1161 function TSQLDataItem.GetAsString: AnsiString;
1162 var
1163 sz: PByte;
1164 str_len: Integer;
1165 rs: RawByteString;
1166 begin
1167 CheckActive;
1168 result := '';
1169 { Check null, if so return a default string }
1170 if not IsNull then
1171 with FFirebirdClientAPI do
1172 case SQLType of
1173 SQL_BOOLEAN:
1174 if AsBoolean then
1175 Result := sTrue
1176 else
1177 Result := SFalse;
1178
1179 SQL_TEXT, SQL_VARYING:
1180 begin
1181 sz := SQLData;
1182 if (SQLType = SQL_TEXT) then
1183 str_len := DataLength
1184 else begin
1185 str_len := DecodeInteger(SQLData, 2);
1186 Inc(sz, 2);
1187 end;
1188 SetString(rs, PAnsiChar(sz), str_len);
1189 SetCodePage(rs,GetCodePage,false);
1190 if (SQLType = SQL_TEXT) and (GetCharSetID <> 1) then
1191 Result := TrimRight(rs)
1192 else
1193 Result := rs
1194 end;
1195 SQL_TYPE_DATE:
1196 result := FormatDateTime(GetDateFormatStr(TimeOf(AsDateTime)<>0),AsDateTime);
1197 SQL_TYPE_TIME :
1198 result := FormatDateTime(GetTimeFormatStr,AsDateTime);
1199 SQL_TIMESTAMP:
1200 result := FormatDateTime(GetTimestampFormatStr,AsDateTime);
1201 SQL_SHORT, SQL_LONG:
1202 if Scale = 0 then
1203 result := IntToStr(AsLong)
1204 else if Scale >= (-4) then
1205 result := CurrToStr(AsCurrency)
1206 else
1207 result := FloatToStr(AsDouble);
1208 SQL_INT64:
1209 if Scale = 0 then
1210 result := IntToStr(AsInt64)
1211 else if Scale >= (-4) then
1212 result := CurrToStr(AsCurrency)
1213 else
1214 result := FloatToStr(AsDouble);
1215 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1216 result := FloatToStr(AsDouble);
1217 else
1218 IBError(ibxeInvalidDataConversion, [nil]);
1219 end;
1220 end;
1221
1222 function TSQLDataItem.GetIsNull: Boolean;
1223 begin
1224 CheckActive;
1225 Result := false;
1226 end;
1227
1228 function TSQLDataItem.GetIsNullable: boolean;
1229 begin
1230 CheckActive;
1231 Result := false;
1232 end;
1233
1234 function TSQLDataItem.GetAsVariant: Variant;
1235 begin
1236 CheckActive;
1237 if IsNull then
1238 result := NULL
1239 { Check null, if so return a default string }
1240 else case SQLType of
1241 SQL_ARRAY:
1242 result := '(Array)'; {do not localize}
1243 SQL_BLOB,
1244 SQL_TEXT, SQL_VARYING:
1245 result := AsString;
1246 SQL_TIMESTAMP, SQL_TYPE_DATE, SQL_TYPE_TIME:
1247 result := AsDateTime;
1248 SQL_SHORT, SQL_LONG:
1249 if Scale = 0 then
1250 result := AsLong
1251 else if Scale >= (-4) then
1252 result := AsCurrency
1253 else
1254 result := AsDouble;
1255 SQL_INT64:
1256 if Scale = 0 then
1257 result := AsInt64
1258 else if Scale >= (-4) then
1259 result := AsCurrency
1260 else
1261 result := AsDouble;
1262 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1263 result := AsDouble;
1264 SQL_BOOLEAN:
1265 result := AsBoolean;
1266 else
1267 IBError(ibxeInvalidDataConversion, [nil]);
1268 end;
1269 end;
1270
1271 function TSQLDataItem.GetModified: boolean;
1272 begin
1273 Result := false;
1274 end;
1275
1276 function TSQLDataItem.GetDateTimeStrLength(DateTimeFormat: TIBDateTimeFormats
1277 ): integer;
1278 begin
1279 case DateTimeFormat of
1280 dfTimestamp:
1281 Result := Length(GetTimestampFormatStr);
1282 dfDateTime:
1283 Result := Length(GetDateFormatStr(true));
1284 dfTime:
1285 Result := Length(GetTimeFormatStr);
1286 else
1287 Result := 0;
1288 end;
1289 end;
1290
1291
1292 procedure TSQLDataItem.SetIsNull(Value: Boolean);
1293 begin
1294 //ignore unless overridden
1295 end;
1296
1297 procedure TSQLDataItem.SetIsNullable(Value: Boolean);
1298 begin
1299 //ignore unless overridden
1300 end;
1301
1302 procedure TSQLDataItem.SetName(aValue: AnsiString);
1303 begin
1304 //ignore unless overridden
1305 end;
1306
1307 procedure TSQLDataItem.SetAsCurrency(Value: Currency);
1308 begin
1309 CheckActive;
1310 if GetSQLDialect < 3 then
1311 AsDouble := Value
1312 else
1313 begin
1314 Changing;
1315 if IsNullable then
1316 IsNull := False;
1317 SQLType := SQL_INT64;
1318 Scale := -4;
1319 DataLength := SizeOf(Int64);
1320 PCurrency(SQLData)^ := Value;
1321 Changed;
1322 end;
1323 end;
1324
1325 procedure TSQLDataItem.SetAsInt64(Value: Int64);
1326 begin
1327 CheckActive;
1328 Changing;
1329 if IsNullable then
1330 IsNull := False;
1331
1332 SQLType := SQL_INT64;
1333 Scale := 0;
1334 DataLength := SizeOf(Int64);
1335 PInt64(SQLData)^ := Value;
1336 Changed;
1337 end;
1338
1339 procedure TSQLDataItem.SetAsDate(Value: TDateTime);
1340 begin
1341 CheckActive;
1342 if GetSQLDialect < 3 then
1343 begin
1344 AsDateTime := Value;
1345 exit;
1346 end;
1347
1348 Changing;
1349 if IsNullable then
1350 IsNull := False;
1351
1352 SQLType := SQL_TYPE_DATE;
1353 DataLength := SizeOf(ISC_DATE);
1354 with FFirebirdClientAPI do
1355 SQLEncodeDate(Value,SQLData);
1356 Changed;
1357 end;
1358
1359 procedure TSQLDataItem.SetAsTime(Value: TDateTime);
1360 begin
1361 CheckActive;
1362 if GetSQLDialect < 3 then
1363 begin
1364 AsDateTime := Value;
1365 exit;
1366 end;
1367
1368 Changing;
1369 if IsNullable then
1370 IsNull := False;
1371
1372 SQLType := SQL_TYPE_TIME;
1373 DataLength := SizeOf(ISC_TIME);
1374 with FFirebirdClientAPI do
1375 SQLEncodeTime(Value,SQLData);
1376 Changed;
1377 end;
1378
1379 procedure TSQLDataItem.SetAsDateTime(Value: TDateTime);
1380 begin
1381 CheckActive;
1382 if IsNullable then
1383 IsNull := False;
1384
1385 Changing;
1386 SQLType := SQL_TIMESTAMP;
1387 DataLength := SizeOf(ISC_TIME) + sizeof(ISC_DATE);
1388 with FFirebirdClientAPI do
1389 SQLEncodeDateTime(Value,SQLData);
1390 Changed;
1391 end;
1392
1393 procedure TSQLDataItem.SetAsDouble(Value: Double);
1394 begin
1395 CheckActive;
1396 if IsNullable then
1397 IsNull := False;
1398
1399 Changing;
1400 SQLType := SQL_DOUBLE;
1401 DataLength := SizeOf(Double);
1402 Scale := 0;
1403 PDouble(SQLData)^ := Value;
1404 Changed;
1405 end;
1406
1407 procedure TSQLDataItem.SetAsFloat(Value: Float);
1408 begin
1409 CheckActive;
1410 if IsNullable then
1411 IsNull := False;
1412
1413 Changing;
1414 SQLType := SQL_FLOAT;
1415 DataLength := SizeOf(Float);
1416 Scale := 0;
1417 PSingle(SQLData)^ := Value;
1418 Changed;
1419 end;
1420
1421 procedure TSQLDataItem.SetAsLong(Value: Long);
1422 begin
1423 CheckActive;
1424 if IsNullable then
1425 IsNull := False;
1426
1427 Changing;
1428 SQLType := SQL_LONG;
1429 DataLength := SizeOf(Long);
1430 Scale := 0;
1431 PLong(SQLData)^ := Value;
1432 Changed;
1433 end;
1434
1435 procedure TSQLDataItem.SetAsPointer(Value: Pointer);
1436 begin
1437 CheckActive;
1438 Changing;
1439 if IsNullable and (Value = nil) then
1440 IsNull := True
1441 else
1442 begin
1443 IsNull := False;
1444 SQLType := SQL_TEXT;
1445 Move(Value^, SQLData^, DataLength);
1446 end;
1447 Changed;
1448 end;
1449
1450 procedure TSQLDataItem.SetAsQuad(Value: TISC_QUAD);
1451 begin
1452 CheckActive;
1453 Changing;
1454 if IsNullable then
1455 IsNull := False;
1456 if (SQLType <> SQL_BLOB) and
1457 (SQLType <> SQL_ARRAY) then
1458 IBError(ibxeInvalidDataConversion, [nil]);
1459 DataLength := SizeOf(TISC_QUAD);
1460 PISC_QUAD(SQLData)^ := Value;
1461 Changed;
1462 end;
1463
1464 procedure TSQLDataItem.SetAsShort(Value: short);
1465 begin
1466 CheckActive;
1467 Changing;
1468 if IsNullable then
1469 IsNull := False;
1470
1471 SQLType := SQL_SHORT;
1472 DataLength := SizeOf(Short);
1473 Scale := 0;
1474 PShort(SQLData)^ := Value;
1475 Changed;
1476 end;
1477
1478 procedure TSQLDataItem.SetAsString(Value: AnsiString);
1479 begin
1480 InternalSetAsString(Value);
1481 end;
1482
1483 procedure TSQLDataItem.SetAsVariant(Value: Variant);
1484 begin
1485 CheckActive;
1486 if VarIsNull(Value) then
1487 IsNull := True
1488 else case VarType(Value) of
1489 varEmpty, varNull:
1490 IsNull := True;
1491 varSmallint, varInteger, varByte,
1492 varWord, varShortInt:
1493 AsLong := Value;
1494 varInt64:
1495 AsInt64 := Value;
1496 varSingle, varDouble:
1497 AsDouble := Value;
1498 varCurrency:
1499 AsCurrency := Value;
1500 varBoolean:
1501 AsBoolean := Value;
1502 varDate:
1503 AsDateTime := Value;
1504 varOleStr, varString:
1505 AsString := Value;
1506 varArray:
1507 IBError(ibxeNotSupported, [nil]);
1508 varByRef, varDispatch, varError, varUnknown, varVariant:
1509 IBError(ibxeNotPermitted, [nil]);
1510 end;
1511 end;
1512
1513 procedure TSQLDataItem.SetAsNumeric(Value: Int64; aScale: integer);
1514 begin
1515 CheckActive;
1516 Changing;
1517 if IsNullable then
1518 IsNull := False;
1519
1520 SQLType := SQL_INT64;
1521 Scale := aScale;
1522 DataLength := SizeOf(Int64);
1523 PInt64(SQLData)^ := Value;
1524 Changed;
1525 end;
1526
1527 procedure TSQLDataItem.SetAsBoolean(AValue: boolean);
1528 begin
1529 CheckActive;
1530 Changing;
1531 if IsNullable then
1532 IsNull := False;
1533
1534 SQLType := SQL_BOOLEAN;
1535 DataLength := 1;
1536 Scale := 0;
1537 if AValue then
1538 PByte(SQLData)^ := ISC_TRUE
1539 else
1540 PByte(SQLData)^ := ISC_FALSE;
1541 Changed;
1542 end;
1543
1544 {TColumnMetaData}
1545
1546 procedure TColumnMetaData.CheckActive;
1547 begin
1548 if not FIBXSQLVAR.Parent.StateChanged(FChangeSeqNo) then Exit;
1549
1550 if FPrepareSeqNo < FIBXSQLVAR.Parent.GetPrepareSeqNo then
1551 IBError(ibxeInterfaceOutofDate,[nil]);
1552
1553 if not FIBXSQLVAR.Parent.CheckStatementStatus(ssPrepared) then
1554 IBError(ibxeStatementNotPrepared, [nil]);
1555 end;
1556
1557 function TColumnMetaData.SQLData: PByte;
1558 begin
1559 Result := FIBXSQLVAR.SQLData;
1560 end;
1561
1562 function TColumnMetaData.GetDataLength: cardinal;
1563 begin
1564 Result := FIBXSQLVAR.DataLength;
1565 end;
1566
1567 function TColumnMetaData.GetCodePage: TSystemCodePage;
1568 begin
1569 Result := FIBXSQLVAR.GetCodePage;
1570 end;
1571
1572 constructor TColumnMetaData.Create(aOwner: IUnknown; aIBXSQLVAR: TSQLVarData);
1573 begin
1574 inherited Create(aIBXSQLVAR.GetStatement.GetAttachment.getFirebirdAPI as TFBClientAPI);
1575 FIBXSQLVAR := aIBXSQLVAR;
1576 FOwner := aOwner;
1577 FPrepareSeqNo := FIBXSQLVAR.Parent.PrepareSeqNo;
1578 FIBXSQLVAR.Parent.StateChanged(FChangeSeqNo)
1579 end;
1580
1581 destructor TColumnMetaData.Destroy;
1582 begin
1583 (FOwner as TInterfaceOwner).Remove(self);
1584 inherited Destroy;
1585 end;
1586
1587
1588 function TColumnMetaData.GetSQLDialect: integer;
1589 begin
1590 Result := FIBXSQLVAR.Statement.GetSQLDialect;
1591 end;
1592
1593 function TColumnMetaData.GetIndex: integer;
1594 begin
1595 Result := FIBXSQLVAR.Index;
1596 end;
1597
1598 function TColumnMetaData.GetSQLType: cardinal;
1599 begin
1600 CheckActive;
1601 result := FIBXSQLVAR.SQLType;
1602 end;
1603
1604 function TColumnMetaData.getSubtype: integer;
1605 begin
1606 CheckActive;
1607 result := FIBXSQLVAR.SQLSubtype;
1608 end;
1609
1610 function TColumnMetaData.getRelationName: AnsiString;
1611 begin
1612 CheckActive;
1613 result := FIBXSQLVAR.RelationName;
1614 end;
1615
1616 function TColumnMetaData.getOwnerName: AnsiString;
1617 begin
1618 CheckActive;
1619 result := FIBXSQLVAR.OwnerName;
1620 end;
1621
1622 function TColumnMetaData.getSQLName: AnsiString;
1623 begin
1624 CheckActive;
1625 result := FIBXSQLVAR.FieldName;
1626 end;
1627
1628 function TColumnMetaData.getAliasName: AnsiString;
1629 begin
1630 CheckActive;
1631 result := FIBXSQLVAR.AliasName;
1632 end;
1633
1634 function TColumnMetaData.GetName: AnsiString;
1635 begin
1636 CheckActive;
1637 Result := FIBXSQLVAR. Name;
1638 end;
1639
1640 function TColumnMetaData.GetScale: integer;
1641 begin
1642 CheckActive;
1643 result := FIBXSQLVAR.Scale;
1644 end;
1645
1646 function TColumnMetaData.getCharSetID: cardinal;
1647 begin
1648 CheckActive;
1649 Result := FIBXSQLVAR.CharSetID;
1650 end;
1651
1652 function TColumnMetaData.GetIsNullable: boolean;
1653 begin
1654 CheckActive;
1655 result := FIBXSQLVAR.IsNullable;
1656 end;
1657
1658 function TColumnMetaData.GetSize: cardinal;
1659 begin
1660 CheckActive;
1661 result := FIBXSQLVAR.DataLength;
1662 end;
1663
1664 function TColumnMetaData.GetArrayMetaData: IArrayMetaData;
1665 begin
1666 CheckActive;
1667 result := FIBXSQLVAR.GetArrayMetaData;
1668 end;
1669
1670 function TColumnMetaData.GetBlobMetaData: IBlobMetaData;
1671 begin
1672 CheckActive;
1673 result := FIBXSQLVAR.GetBlobMetaData;
1674 end;
1675
1676 { TIBSQLData }
1677
1678 procedure TIBSQLData.CheckActive;
1679 begin
1680 if not FIBXSQLVAR.Parent.StateChanged(FChangeSeqNo) then Exit;
1681
1682 inherited CheckActive;
1683
1684 if not FIBXSQLVAR.Parent.CheckStatementStatus(ssCursorOpen) and
1685 not FIBXSQLVAR.Parent.CheckStatementStatus(ssExecuteResults) then
1686 IBError(ibxeSQLClosed, [nil]);
1687
1688 if FIBXSQLVAR.Parent.CheckStatementStatus(ssEOF) then
1689 IBError(ibxeEOF,[nil]);
1690
1691 if FIBXSQLVAR.Parent.CheckStatementStatus(ssBOF) then
1692 IBError(ibxeBOF,[nil]);
1693 end;
1694
1695 function TIBSQLData.GetIsNull: Boolean;
1696 begin
1697 CheckActive;
1698 result := FIBXSQLVAR.IsNull;
1699 end;
1700
1701 function TIBSQLData.GetAsArray: IArray;
1702 begin
1703 CheckActive;
1704 result := FIBXSQLVAR.GetAsArray(AsQuad);
1705 end;
1706
1707 function TIBSQLData.GetAsBlob: IBlob;
1708 begin
1709 CheckActive;
1710 result := FIBXSQLVAR.GetAsBlob(AsQuad,nil);
1711 end;
1712
1713 function TIBSQLData.GetAsBlob(BPB: IBPB): IBlob;
1714 begin
1715 CheckActive;
1716 result := FIBXSQLVAR.GetAsBlob(AsQuad,BPB);
1717 end;
1718
1719 function TIBSQLData.GetAsString: AnsiString;
1720 begin
1721 CheckActive;
1722 Result := '';
1723 { Check null, if so return a default string }
1724 if not IsNull then
1725 case SQLType of
1726 SQL_ARRAY:
1727 result := SArray;
1728 SQL_BLOB:
1729 Result := FIBXSQLVAR.GetAsBlob(AsQuad,nil).GetAsString;
1730 else
1731 Result := inherited GetAsString;
1732 end;
1733 end;
1734
1735 { TSQLParam }
1736
1737 procedure TSQLParam.InternalSetAsString(Value: AnsiString);
1738
1739 procedure DoSetString;
1740 begin
1741 Changing;
1742 FIBXSQLVar.SetString(Transliterate(Value,GetCodePage));
1743 Changed;
1744 end;
1745
1746 var b: IBlob;
1747 dt: TDateTime;
1748 CurrValue: Currency;
1749 FloatValue: single;
1750 begin
1751 CheckActive;
1752 if IsNullable then
1753 IsNull := False;
1754 case SQLTYPE of
1755 SQL_BOOLEAN:
1756 if AnsiCompareText(Value,STrue) = 0 then
1757 AsBoolean := true
1758 else
1759 if AnsiCompareText(Value,SFalse) = 0 then
1760 AsBoolean := false
1761 else
1762 IBError(ibxeInvalidDataConversion,[nil]);
1763
1764 SQL_BLOB:
1765 begin
1766 Changing;
1767 b := FIBXSQLVAR.CreateBlob;
1768 b.SetAsString(Value);
1769 AsBlob := b;
1770 Changed;
1771 end;
1772
1773 SQL_VARYING,
1774 SQL_TEXT:
1775 DoSetString;
1776
1777 SQL_SHORT,
1778 SQL_LONG,
1779 SQL_INT64:
1780 if TryStrToCurr(Value,CurrValue) then
1781 SetAsNumeric(AdjustScaleFromCurrency(CurrValue,GetScale),GetScale)
1782 else
1783 DoSetString;
1784
1785 SQL_D_FLOAT,
1786 SQL_DOUBLE,
1787 SQL_FLOAT:
1788 if TryStrToFloat(Value,FloatValue) then
1789 SetAsDouble(FloatValue)
1790 else
1791 DoSetString;
1792
1793 SQL_TIMESTAMP:
1794 if TryStrToDateTime(Value,dt) then
1795 SetAsDateTime(dt)
1796 else
1797 DoSetString;
1798
1799 SQL_TYPE_DATE:
1800 if TryStrToDateTime(Value,dt) then
1801 SetAsDate(dt)
1802 else
1803 DoSetString;
1804
1805 SQL_TYPE_TIME:
1806 if TryStrToDateTime(Value,dt) then
1807 SetAsTime(dt)
1808 else
1809 DoSetString;
1810
1811 else
1812 IBError(ibxeInvalidDataConversion,[nil]);
1813 end;
1814 end;
1815
1816 procedure TSQLParam.CheckActive;
1817 begin
1818 if not FIBXSQLVAR.Parent.StateChanged(FChangeSeqNo) then Exit;
1819
1820 if FPrepareSeqNo < FIBXSQLVAR.Parent.GetPrepareSeqNo then
1821 IBError(ibxeInterfaceOutofDate,[nil]);
1822
1823 if not FIBXSQLVAR.Parent.CheckStatementStatus(ssPrepared) then
1824 IBError(ibxeStatementNotPrepared, [nil]);
1825 end;
1826
1827 procedure TSQLParam.SetScale(aValue: integer);
1828 begin
1829 CheckActive;
1830 FIBXSQLVAR.Scale := aValue;
1831 end;
1832
1833 procedure TSQLParam.SetDataLength(len: cardinal);
1834 begin
1835 CheckActive;
1836 FIBXSQLVAR.DataLength := len;
1837 end;
1838
1839 procedure TSQLParam.SetSQLType(aValue: cardinal);
1840 begin
1841 CheckActive;
1842 FIBXSQLVAR.SQLType := aValue;
1843 end;
1844
1845 procedure TSQLParam.Clear;
1846 begin
1847 IsNull := true;
1848 end;
1849
1850 function TSQLParam.GetModified: boolean;
1851 begin
1852 CheckActive;
1853 Result := FIBXSQLVAR.Modified;
1854 end;
1855
1856 function TSQLParam.GetAsPointer: Pointer;
1857 begin
1858 IsNull := false; {Assume that we get the pointer in order to set a value}
1859 Changed;
1860 Result := inherited GetAsPointer;
1861 end;
1862
1863 procedure TSQLParam.SetName(Value: AnsiString);
1864 begin
1865 CheckActive;
1866 FIBXSQLVAR.Name := Value;
1867 end;
1868
1869 procedure TSQLParam.SetIsNull(Value: Boolean);
1870 var i: integer;
1871 begin
1872 CheckActive;
1873 if FIBXSQLVAR.UniqueName then
1874 FIBXSQLVAR.IsNull := Value
1875 else
1876 with FIBXSQLVAR.Parent do
1877 begin
1878 for i := 0 to Count - 1 do
1879 if Column[i].Name = Name then
1880 Column[i].IsNull := Value;
1881 end
1882 end;
1883
1884 procedure TSQLParam.SetIsNullable(Value: Boolean);
1885 var i: integer;
1886 begin
1887 CheckActive;
1888 if FIBXSQLVAR.UniqueName then
1889 FIBXSQLVAR.IsNullable := Value
1890 else
1891 with FIBXSQLVAR.Parent do
1892 begin
1893 for i := 0 to Count - 1 do
1894 if Column[i].Name = Name then
1895 Column[i].IsNullable := Value;
1896 end
1897 end;
1898
1899 procedure TSQLParam.SetAsArray(anArray: IArray);
1900 begin
1901 CheckActive;
1902 if GetSQLType <> SQL_ARRAY then
1903 IBError(ibxeInvalidDataConversion,[nil]);
1904
1905 if not FIBXSQLVAR.UniqueName then
1906 IBError(ibxeDuplicateParamName,[FIBXSQLVAR.Name]);
1907
1908 SetAsQuad(AnArray.GetArrayID);
1909 end;
1910
1911 procedure TSQLParam.Changed;
1912 begin
1913 FIBXSQLVAR.Changed;
1914 end;
1915
1916 procedure TSQLParam.SetAsBoolean(AValue: boolean);
1917 var i: integer;
1918 OldSQLVar: TSQLVarData;
1919 begin
1920 if FIBXSQLVAR.UniqueName then
1921 inherited SetAsBoolean(AValue)
1922 else
1923 with FIBXSQLVAR.Parent do
1924 begin
1925 for i := 0 to Count - 1 do
1926 if Column[i].Name = Name then
1927 begin
1928 OldSQLVar := FIBXSQLVAR;
1929 FIBXSQLVAR := Column[i];
1930 try
1931 inherited SetAsBoolean(AValue);
1932 finally
1933 FIBXSQLVAR := OldSQLVar;
1934 end;
1935 end;
1936 end;
1937 end;
1938
1939 procedure TSQLParam.SetAsCurrency(AValue: Currency);
1940 var i: integer;
1941 OldSQLVar: TSQLVarData;
1942 begin
1943 if FIBXSQLVAR.UniqueName then
1944 inherited SetAsCurrency(AValue)
1945 else
1946 with FIBXSQLVAR.Parent do
1947 begin
1948 for i := 0 to Count - 1 do
1949 if Column[i].Name = Name then
1950 begin
1951 OldSQLVar := FIBXSQLVAR;
1952 FIBXSQLVAR := Column[i];
1953 try
1954 inherited SetAsCurrency(AValue);
1955 finally
1956 FIBXSQLVAR := OldSQLVar;
1957 end;
1958 end;
1959 end;
1960 end;
1961
1962 procedure TSQLParam.SetAsInt64(AValue: Int64);
1963 var i: integer;
1964 OldSQLVar: TSQLVarData;
1965 begin
1966 if FIBXSQLVAR.UniqueName then
1967 inherited SetAsInt64(AValue)
1968 else
1969 with FIBXSQLVAR.Parent do
1970 begin
1971 for i := 0 to Count - 1 do
1972 if Column[i].Name = Name then
1973 begin
1974 OldSQLVar := FIBXSQLVAR;
1975 FIBXSQLVAR := Column[i];
1976 try
1977 inherited SetAsInt64(AValue);
1978 finally
1979 FIBXSQLVAR := OldSQLVar;
1980 end;
1981 end;
1982 end;
1983 end;
1984
1985 procedure TSQLParam.SetAsDate(AValue: TDateTime);
1986 var i: integer;
1987 OldSQLVar: TSQLVarData;
1988 begin
1989 if FIBXSQLVAR.UniqueName then
1990 inherited SetAsDate(AValue)
1991 else
1992 with FIBXSQLVAR.Parent do
1993 begin
1994 for i := 0 to Count - 1 do
1995 if Column[i].Name = Name then
1996 begin
1997 OldSQLVar := FIBXSQLVAR;
1998 FIBXSQLVAR := Column[i];
1999 try
2000 inherited SetAsDate(AValue);
2001 finally
2002 FIBXSQLVAR := OldSQLVar;
2003 end;
2004 end;
2005 end;
2006 end;
2007
2008 procedure TSQLParam.SetAsLong(AValue: Long);
2009 var i: integer;
2010 OldSQLVar: TSQLVarData;
2011 begin
2012 if FIBXSQLVAR.UniqueName then
2013 inherited SetAsLong(AValue)
2014 else
2015 with FIBXSQLVAR.Parent do
2016 begin
2017 for i := 0 to Count - 1 do
2018 if Column[i].Name = Name then
2019 begin
2020 OldSQLVar := FIBXSQLVAR;
2021 FIBXSQLVAR := Column[i];
2022 try
2023 inherited SetAsLong(AValue);
2024 finally
2025 FIBXSQLVAR := OldSQLVar;
2026 end;
2027 end;
2028 end;
2029 end;
2030
2031 procedure TSQLParam.SetAsTime(AValue: TDateTime);
2032 var i: integer;
2033 OldSQLVar: TSQLVarData;
2034 begin
2035 if FIBXSQLVAR.UniqueName then
2036 inherited SetAsTime(AValue)
2037 else
2038 with FIBXSQLVAR.Parent do
2039 begin
2040 for i := 0 to Count - 1 do
2041 if Column[i].Name = Name then
2042 begin
2043 OldSQLVar := FIBXSQLVAR;
2044 FIBXSQLVAR := Column[i];
2045 try
2046 inherited SetAsTime(AValue);
2047 finally
2048 FIBXSQLVAR := OldSQLVar;
2049 end;
2050 end;
2051 end;
2052 end;
2053
2054 procedure TSQLParam.SetAsDateTime(AValue: TDateTime);
2055 var i: integer;
2056 OldSQLVar: TSQLVarData;
2057 begin
2058 if FIBXSQLVAR.UniqueName then
2059 inherited SetAsDateTime(AValue)
2060 else
2061 with FIBXSQLVAR.Parent do
2062 begin
2063 for i := 0 to Count - 1 do
2064 if Column[i].Name = Name then
2065 begin
2066 OldSQLVar := FIBXSQLVAR;
2067 FIBXSQLVAR := Column[i];
2068 try
2069 inherited SetAsDateTime(AValue);
2070 finally
2071 FIBXSQLVAR := OldSQLVar;
2072 end;
2073 end;
2074 end;
2075 end;
2076
2077 procedure TSQLParam.SetAsDouble(AValue: Double);
2078 var i: integer;
2079 OldSQLVar: TSQLVarData;
2080 begin
2081 if FIBXSQLVAR.UniqueName then
2082 inherited SetAsDouble(AValue)
2083 else
2084 with FIBXSQLVAR.Parent do
2085 begin
2086 for i := 0 to Count - 1 do
2087 if Column[i].Name = Name then
2088 begin
2089 OldSQLVar := FIBXSQLVAR;
2090 FIBXSQLVAR := Column[i];
2091 try
2092 inherited SetAsDouble(AValue);
2093 finally
2094 FIBXSQLVAR := OldSQLVar;
2095 end;
2096 end;
2097 end;
2098 end;
2099
2100 procedure TSQLParam.SetAsFloat(AValue: Float);
2101 var i: integer;
2102 OldSQLVar: TSQLVarData;
2103 begin
2104 if FIBXSQLVAR.UniqueName then
2105 inherited SetAsFloat(AValue)
2106 else
2107 with FIBXSQLVAR.Parent do
2108 begin
2109 for i := 0 to Count - 1 do
2110 if Column[i].Name = Name then
2111 begin
2112 OldSQLVar := FIBXSQLVAR;
2113 FIBXSQLVAR := Column[i];
2114 try
2115 inherited SetAsFloat(AValue);
2116 finally
2117 FIBXSQLVAR := OldSQLVar;
2118 end;
2119 end;
2120 end;
2121 end;
2122
2123 procedure TSQLParam.SetAsPointer(AValue: Pointer);
2124 var i: integer;
2125 OldSQLVar: TSQLVarData;
2126 begin
2127 if FIBXSQLVAR.UniqueName then
2128 inherited SetAsPointer(AValue)
2129 else
2130 with FIBXSQLVAR.Parent do
2131 begin
2132 for i := 0 to Count - 1 do
2133 if Column[i].Name = Name then
2134 begin
2135 OldSQLVar := FIBXSQLVAR;
2136 FIBXSQLVAR := Column[i];
2137 try
2138 inherited SetAsPointer(AValue);
2139 finally
2140 FIBXSQLVAR := OldSQLVar;
2141 end;
2142 end;
2143 end;
2144 end;
2145
2146 procedure TSQLParam.SetAsShort(AValue: Short);
2147 var i: integer;
2148 OldSQLVar: TSQLVarData;
2149 begin
2150 if FIBXSQLVAR.UniqueName then
2151 inherited SetAsShort(AValue)
2152 else
2153 with FIBXSQLVAR.Parent do
2154 begin
2155 for i := 0 to Count - 1 do
2156 if Column[i].Name = Name then
2157 begin
2158 OldSQLVar := FIBXSQLVAR;
2159 FIBXSQLVAR := Column[i];
2160 try
2161 inherited SetAsShort(AValue);
2162 finally
2163 FIBXSQLVAR := OldSQLVar;
2164 end;
2165 end;
2166 end;
2167 end;
2168
2169 procedure TSQLParam.SetAsString(AValue: AnsiString);
2170 var i: integer;
2171 OldSQLVar: TSQLVarData;
2172 begin
2173 if FIBXSQLVAR.UniqueName then
2174 InternalSetAsString(AValue)
2175 else
2176 with FIBXSQLVAR.Parent do
2177 begin
2178 for i := 0 to Count - 1 do
2179 if Column[i].Name = Name then
2180 begin
2181 OldSQLVar := FIBXSQLVAR;
2182 FIBXSQLVAR := Column[i];
2183 try
2184 InternalSetAsString(AValue);
2185 finally
2186 FIBXSQLVAR := OldSQLVar;
2187 end;
2188 end;
2189 end;
2190 end;
2191
2192 procedure TSQLParam.SetAsVariant(AValue: Variant);
2193 var i: integer;
2194 OldSQLVar: TSQLVarData;
2195 begin
2196 if FIBXSQLVAR.UniqueName then
2197 inherited SetAsVariant(AValue)
2198 else
2199 with FIBXSQLVAR.Parent do
2200 begin
2201 for i := 0 to Count - 1 do
2202 if Column[i].Name = Name then
2203 begin
2204 OldSQLVar := FIBXSQLVAR;
2205 FIBXSQLVAR := Column[i];
2206 try
2207 inherited SetAsVariant(AValue);
2208 finally
2209 FIBXSQLVAR := OldSQLVar;
2210 end;
2211 end;
2212 end;
2213 end;
2214
2215 procedure TSQLParam.SetAsBlob(aValue: IBlob);
2216 begin
2217 with FIBXSQLVAR do
2218 if not UniqueName then
2219 IBError(ibxeDuplicateParamName,[Name]);
2220 CheckActive;
2221 Changing;
2222 aValue.Close;
2223 if aValue.GetSubType <> GetSubType then
2224 IBError(ibxeIncompatibleBlob,[GetSubType,aValue.GetSubType]);
2225 AsQuad := aValue.GetBlobID;
2226 Changed;
2227 end;
2228
2229 procedure TSQLParam.SetAsQuad(AValue: TISC_QUAD);
2230 var i: integer;
2231 OldSQLVar: TSQLVarData;
2232 begin
2233 if FIBXSQLVAR.UniqueName then
2234 inherited SetAsQuad(AValue)
2235 else
2236 with FIBXSQLVAR.Parent do
2237 begin
2238 for i := 0 to Count - 1 do
2239 if Column[i].Name = Name then
2240 begin
2241 OldSQLVar := FIBXSQLVAR;
2242 FIBXSQLVAR := Column[i];
2243 try
2244 inherited SetAsQuad(AValue);
2245 finally
2246 FIBXSQLVAR := OldSQLVar;
2247 end;
2248 end;
2249 end;
2250 end;
2251
2252 procedure TSQLParam.SetCharSetID(aValue: cardinal);
2253 begin
2254 FIBXSQLVAR.SetCharSetID(aValue);
2255 end;
2256
2257 { TMetaData }
2258
2259 procedure TMetaData.CheckActive;
2260 begin
2261 if FPrepareSeqNo < FMetaData.PrepareSeqNo then
2262 IBError(ibxeInterfaceOutofDate,[nil]);
2263
2264 if not FMetaData.CheckStatementStatus(ssPrepared) then
2265 IBError(ibxeStatementNotPrepared, [nil]);
2266 end;
2267
2268 constructor TMetaData.Create(aMetaData: TSQLDataArea);
2269 begin
2270 inherited Create(aMetaData.Count);
2271 FMetaData := aMetaData;
2272 FStatement := aMetaData.Statement;
2273 FPrepareSeqNo := aMetaData.PrepareSeqNo;
2274 end;
2275
2276 destructor TMetaData.Destroy;
2277 begin
2278 (FStatement as TInterfaceOwner).Remove(self);
2279 inherited Destroy;
2280 end;
2281
2282 function TMetaData.GetUniqueRelationName: AnsiString;
2283 begin
2284 CheckActive;
2285 Result := FMetaData.UniqueRelationName;
2286 end;
2287
2288 function TMetaData.getCount: integer;
2289 begin
2290 CheckActive;
2291 Result := FMetaData.ColumnsInUseCount;
2292 end;
2293
2294 function TMetaData.getColumnMetaData(index: integer): IColumnMetaData;
2295 begin
2296 CheckActive;
2297 if (index < 0) or (index >= getCount) then
2298 IBError(ibxeInvalidColumnIndex,[nil]);
2299
2300 if FMetaData.Count = 0 then
2301 Result := nil
2302 else
2303 begin
2304 if not HasInterface(index) then
2305 AddInterface(index,TColumnMetaData.Create(self,FMetaData.Column[index]));
2306 Result := TColumnMetaData(GetInterface(index));
2307 end;
2308 end;
2309
2310 function TMetaData.ByName(Idx: AnsiString): IColumnMetaData;
2311 var aIBXSQLVAR: TSQLVarData;
2312 begin
2313 CheckActive;
2314 aIBXSQLVAR := FMetaData.ColumnByName(Idx);
2315 if aIBXSQLVAR = nil then
2316 IBError(ibxeFieldNotFound,[Idx]);
2317 Result := getColumnMetaData(aIBXSQLVAR.index);
2318 end;
2319
2320 { TSQLParams }
2321
2322 procedure TSQLParams.CheckActive;
2323 begin
2324 if not FSQLParams.StateChanged(FChangeSeqNo) then Exit;
2325
2326 if FPrepareSeqNo < FSQLParams.PrepareSeqNo then
2327 IBError(ibxeInterfaceOutofDate,[nil]);
2328
2329 if not FSQLParams.CheckStatementStatus(ssPrepared) then
2330 IBError(ibxeStatementNotPrepared, [nil]);
2331 end;
2332
2333 constructor TSQLParams.Create(aSQLParams: TSQLDataArea);
2334 begin
2335 inherited Create(aSQLParams.Count);
2336 FSQLParams := aSQLParams;
2337 FStatement := aSQLParams.Statement;
2338 FPrepareSeqNo := aSQLParams.PrepareSeqNo;
2339 FSQLParams.StateChanged(FChangeSeqNo);
2340 end;
2341
2342 destructor TSQLParams.Destroy;
2343 begin
2344 (FStatement as TInterfaceOwner).Remove(self);
2345 inherited Destroy;
2346 end;
2347
2348 function TSQLParams.getCount: integer;
2349 begin
2350 CheckActive;
2351 Result := FSQLParams.ColumnsInUseCount;
2352 end;
2353
2354 function TSQLParams.getSQLParam(index: integer): ISQLParam;
2355 begin
2356 CheckActive;
2357 if (index < 0) or (index >= getCount) then
2358 IBError(ibxeInvalidColumnIndex,[nil]);
2359
2360 if getCount = 0 then
2361 Result := nil
2362 else
2363 begin
2364 if not HasInterface(index) then
2365 AddInterface(index, TSQLParam.Create(self,FSQLParams.Column[index]));
2366 Result := TSQLParam(GetInterface(index));
2367 end;
2368 end;
2369
2370 function TSQLParams.ByName(Idx: AnsiString): ISQLParam;
2371 var aIBXSQLVAR: TSQLVarData;
2372 begin
2373 CheckActive;
2374 aIBXSQLVAR := FSQLParams.ColumnByName(Idx);
2375 if aIBXSQLVAR = nil then
2376 IBError(ibxeFieldNotFound,[Idx]);
2377 Result := getSQLParam(aIBXSQLVAR.index);
2378 end;
2379
2380 function TSQLParams.GetModified: Boolean;
2381 var
2382 i: Integer;
2383 begin
2384 CheckActive;
2385 result := False;
2386 with FSQLParams do
2387 for i := 0 to Count - 1 do
2388 if Column[i].Modified then
2389 begin
2390 result := True;
2391 exit;
2392 end;
2393 end;
2394
2395 { TResults }
2396
2397 procedure TResults.CheckActive;
2398 begin
2399 if not FResults.StateChanged(FChangeSeqNo) then Exit;
2400
2401 if FPrepareSeqNo < FResults.PrepareSeqNo then
2402 IBError(ibxeInterfaceOutofDate,[nil]);
2403
2404 if not FResults.CheckStatementStatus(ssPrepared) then
2405 IBError(ibxeStatementNotPrepared, [nil]);
2406
2407 with GetTransaction as TFBTransaction do
2408 if not InTransaction or (FResults.TransactionSeqNo <> FTransactionSeqNo) then
2409 IBError(ibxeInterfaceOutofDate,[nil]);
2410 end;
2411
2412 function TResults.GetISQLData(aIBXSQLVAR: TSQLVarData): ISQLData;
2413 begin
2414 if (aIBXSQLVAR.Index < 0) or (aIBXSQLVAR.Index >= getCount) then
2415 IBError(ibxeInvalidColumnIndex,[nil]);
2416
2417 if not HasInterface(aIBXSQLVAR.Index) then
2418 AddInterface(aIBXSQLVAR.Index, TIBSQLData.Create(self,aIBXSQLVAR));
2419 Result := TIBSQLData(GetInterface(aIBXSQLVAR.Index));
2420 end;
2421
2422 constructor TResults.Create(aResults: TSQLDataArea);
2423 begin
2424 inherited Create(aResults.Count);
2425 FResults := aResults;
2426 FStatement := aResults.Statement;
2427 FPrepareSeqNo := aResults.PrepareSeqNo;
2428 FTransactionSeqNo := aResults.TransactionSeqNo;
2429 FResults.StateChanged(FChangeSeqNo);
2430 end;
2431
2432 function TResults.getCount: integer;
2433 begin
2434 CheckActive;
2435 Result := FResults.Count;
2436 end;
2437
2438 function TResults.ByName(Idx: AnsiString): ISQLData;
2439 var col: TSQLVarData;
2440 begin
2441 Result := nil;
2442 CheckActive;
2443 if FResults.CheckStatementStatus(ssBOF) then
2444 IBError(ibxeBOF,[nil]);
2445 if FResults.CheckStatementStatus(ssEOF) then
2446 IBError(ibxeEOF,[nil]);
2447
2448 if FResults.Count > 0 then
2449 begin
2450 col := FResults.ColumnByName(Idx);
2451 if col <> nil then
2452 Result := GetISQLData(col);
2453 end;
2454 end;
2455
2456 function TResults.getSQLData(index: integer): ISQLData;
2457 begin
2458 CheckActive;
2459 if FResults.CheckStatementStatus(ssBOF) then
2460 IBError(ibxeBOF,[nil]);
2461 if FResults.CheckStatementStatus(ssEOF) then
2462 IBError(ibxeEOF,[nil]);
2463 if (index < 0) or (index >= FResults.Count) then
2464 IBError(ibxeInvalidColumnIndex,[nil]);
2465
2466 Result := GetISQLData(FResults.Column[index]);
2467 end;
2468
2469 procedure TResults.GetData(index: integer; var IsNull: boolean; var len: short;
2470 var data: PByte);
2471 begin
2472 CheckActive;
2473 FResults.GetData(index,IsNull, len,data);
2474 end;
2475
2476 function TResults.GetTransaction: ITransaction;
2477 begin
2478 Result := FStatement.GetTransaction;
2479 end;
2480
2481 procedure TResults.SetRetainInterfaces(aValue: boolean);
2482 begin
2483 RetainInterfaces := aValue;
2484 end;
2485
2486 end.
2487