ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/client/FBSQLData.pas
Revision: 287
Committed: Thu Apr 11 08:51:23 2019 UTC (5 years, 7 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/FBSQLData.pas
File size: 64638 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 function GetHasCaseSensitiveParams: Boolean;
425 end;
426
427 { TResults }
428
429 TResults = class(TInterfaceOwner,IResults)
430 private
431 FPrepareSeqNo: integer;
432 FTransactionSeqNo: integer;
433 FChangeSeqNo: integer;
434 FResults: TSQLDataArea;
435 FStatement: IStatement; {ensure FStatement not destroyed until no longer needed}
436 function GetISQLData(aIBXSQLVAR: TSQLVarData): ISQLData;
437 protected
438 procedure CheckActive;
439 public
440 constructor Create(aResults: TSQLDataArea);
441 {IResults}
442 function getCount: integer;
443 function ByName(Idx: AnsiString): ISQLData;
444 function getSQLData(index: integer): ISQLData;
445 procedure GetData(index: integer; var IsNull:boolean; var len: short; var data: PByte);
446 function GetTransaction: ITransaction; virtual;
447 procedure SetRetainInterfaces(aValue: boolean);
448 end;
449
450 implementation
451
452 uses FBMessages, variants, IBUtils, FBTransaction, DateUtils;
453
454 { TSQLDataArea }
455
456 function TSQLDataArea.GetColumn(index: integer): TSQLVarData;
457 begin
458 if (index < 0) or (index >= Count) then
459 IBError(ibxeInvalidColumnIndex,[nil]);
460 Result := FColumnList[index];
461 end;
462
463 function TSQLDataArea.GetCount: integer;
464 begin
465 Result := Length(FColumnList);
466 end;
467
468 procedure TSQLDataArea.SetUniqueRelationName;
469 var
470 i: Integer;
471 bUnique: Boolean;
472 RelationName: AnsiString;
473 begin
474 bUnique := True;
475 for i := 0 to ColumnsInUseCount - 1 do
476 begin
477 RelationName := Column[i].RelationName;
478
479 {First get the unique relation name, if any}
480
481 if bUnique and (RelationName <> '') then
482 begin
483 if FUniqueRelationName = '' then
484 FUniqueRelationName := RelationName
485 else
486 if RelationName <> FUniqueRelationName then
487 begin
488 FUniqueRelationName := '';
489 bUnique := False;
490 end;
491 end;
492 end;
493 end;
494
495 procedure TSQLDataArea.Initialize;
496 var
497 i: Integer;
498 begin
499 for i := 0 to ColumnsInUseCount - 1 do
500 Column[i].Initialize;
501 end;
502
503 procedure TSQLDataArea.PreprocessSQL(sSQL: AnsiString; GenerateParamNames: boolean;
504 var sProcessedSQL: AnsiString);
505
506 var slNames: TStrings;
507
508 procedure SetColumnNames(slNames: TStrings);
509 var i, j: integer;
510 found: boolean;
511 begin
512 found := false;
513 SetCount(slNames.Count);
514 for i := 0 to slNames.Count - 1 do
515 begin
516 Column[i].Name := slNames[i];
517 Column[i].UniqueName := (slNames.Objects[i] <> nil);
518 end;
519 for i := 0 to Count - 1 do
520 begin
521 if not Column[i].UniqueName then
522 begin
523 found := false;
524 for j := i + 1 to Count - 1 do
525 if Column[i].Name = Column[j].Name then
526 begin
527 found := true;
528 break;
529 end;
530 Column[i].UniqueName := not found;
531 end;
532 end;
533 end;
534
535 begin
536 if not IsInputDataArea then
537 IBError(ibxeNotPermitted,[nil]);
538
539 slNames := TStringList.Create;
540 try
541 sProcessedSQL := TSQLParamProcessor.Execute(sSQL,GenerateParamNames,slNames);
542 SetColumnNames(slNames);
543 finally
544 slNames.Free;
545 end;
546 end;
547
548 function TSQLDataArea.ColumnsInUseCount: integer;
549 begin
550 Result := Count;
551 end;
552
553 function TSQLDataArea.ColumnByName(Idx: AnsiString): TSQLVarData;
554 var
555 s: AnsiString;
556 i: Integer;
557 begin
558 if not IsInputDataArea or not CaseSensitiveParams then
559 s := AnsiUpperCase(Idx)
560 else
561 s := Idx;
562
563 for i := 0 to Count - 1 do
564 if Column[i].Name = s then
565 begin
566 Result := Column[i];
567 Exit;
568 end;
569 Result := nil;
570 end;
571
572 procedure TSQLDataArea.GetData(index: integer; var IsNull: boolean;
573 var len: short; var data: PByte);
574 begin
575 //Do Nothing
576 end;
577
578 procedure TSQLDataArea.RowChange;
579 var i: integer;
580 begin
581 for i := 0 to Count - 1 do
582 Column[i].RowChange;
583 end;
584
585 {TSQLVarData}
586
587 function TSQLVarData.GetStatement: IStatement;
588 begin
589 Result := FParent.Statement;
590 end;
591
592 procedure TSQLVarData.SetName(AValue: AnsiString);
593 begin
594 if not Parent.IsInputDataArea or not Parent.CaseSensitiveParams then
595 FName := AnsiUpperCase(AValue)
596 else
597 FName := AValue;
598 end;
599
600 constructor TSQLVarData.Create(aParent: TSQLDataArea; aIndex: integer);
601 begin
602 inherited Create;
603 FParent := aParent;
604 FIndex := aIndex;
605 FUniqueName := true;
606 end;
607
608 procedure TSQLVarData.SetString(aValue: AnsiString);
609 begin
610 {we take full advantage here of reference counted strings. When setting a string
611 value, a reference is kept in FVarString and a pointer to it placed in the
612 SQLVar. This avoids string copies. Note that PAnsiChar is guaranteed to point to
613 a zero byte when the string is empty, neatly avoiding a nil pointer error.}
614
615 FVarString := aValue;
616 SQLType := SQL_TEXT;
617 Scale := 0;
618 SetSQLData(PByte(PAnsiChar(FVarString)),Length(aValue));
619 end;
620
621 procedure TSQLVarData.Changed;
622 begin
623 FModified := true;
624 end;
625
626 procedure TSQLVarData.RowChange;
627 begin
628 FModified := false;
629 FVarString := '';
630 end;
631
632 procedure TSQLVarData.Initialize;
633
634 function FindVarByName(idx: AnsiString; limit: integer): TSQLVarData;
635 var
636 k: integer;
637 begin
638 for k := 0 to limit do
639 if Parent.Column[k].Name = idx then
640 begin
641 Result := Parent.Column[k];
642 Exit;
643 end;
644 Result := nil;
645 end;
646
647 var
648 j, j_len: Integer;
649 st: AnsiString;
650 sBaseName: AnsiString;
651 begin
652 RowChange;
653
654 {If an output SQLDA then copy the aliasname to the FName. Ensure
655 that they are all upper case only and disambiguated.
656 }
657
658 if not Parent.IsInputDataArea then
659 begin
660 st := Space2Underscore(AnsiUppercase(AliasName));
661 if st = '' then
662 begin
663 sBaseName := 'F_'; {do not localize}
664 j := 1; j_len := 1;
665 st := sBaseName + IntToStr(j);
666 end
667 else
668 begin
669 j := 0; j_len := 0;
670 sBaseName := st;
671 end;
672
673 {Look for other columns with the same name and make unique}
674
675 while FindVarByName(st,Index-1) <> nil do
676 begin
677 Inc(j);
678 j_len := Length(IntToStr(j));
679 if j_len + Length(sBaseName) > 31 then
680 st := system.Copy(sBaseName, 1, 31 - j_len) + IntToStr(j)
681 else
682 st := sBaseName + IntToStr(j);
683 end;
684
685 Name := st;
686 end;
687 end;
688
689 {TSQLDataItem}
690
691 function TSQLDataItem.AdjustScale(Value: Int64; aScale: Integer): Double;
692 var
693 Scaling : Int64;
694 i: Integer;
695 Val: Double;
696 begin
697 Scaling := 1; Val := Value;
698 if aScale > 0 then
699 begin
700 for i := 1 to aScale do
701 Scaling := Scaling * 10;
702 result := Val * Scaling;
703 end
704 else
705 if aScale < 0 then
706 begin
707 for i := -1 downto aScale do
708 Scaling := Scaling * 10;
709 result := Val / Scaling;
710 end
711 else
712 result := Val;
713 end;
714
715 function TSQLDataItem.AdjustScaleToInt64(Value: Int64; aScale: Integer): Int64;
716 var
717 Scaling : Int64;
718 i: Integer;
719 Val: Int64;
720 begin
721 Scaling := 1; Val := Value;
722 if aScale > 0 then begin
723 for i := 1 to aScale do Scaling := Scaling * 10;
724 result := Val * Scaling;
725 end else if aScale < 0 then begin
726 for i := -1 downto aScale do Scaling := Scaling * 10;
727 result := Val div Scaling;
728 end else
729 result := Val;
730 end;
731
732 function TSQLDataItem.AdjustScaleToCurrency(Value: Int64; aScale: Integer
733 ): Currency;
734 var
735 Scaling : Int64;
736 i : Integer;
737 FractionText, PadText, CurrText: AnsiString;
738 begin
739 Result := 0;
740 Scaling := 1;
741 PadText := '';
742 if aScale > 0 then
743 begin
744 for i := 1 to aScale do
745 Scaling := Scaling * 10;
746 result := Value * Scaling;
747 end
748 else
749 if aScale < 0 then
750 begin
751 for i := -1 downto aScale do
752 Scaling := Scaling * 10;
753 FractionText := IntToStr(abs(Value mod Scaling));
754 for i := Length(FractionText) to -aScale -1 do
755 PadText := '0' + PadText;
756 {$IF declared(DefaultFormatSettings)}
757 with DefaultFormatSettings do
758 {$ELSE}
759 {$IF declared(FormatSettings)}
760 with FormatSettings do
761 {$IFEND}
762 {$IFEND}
763 if Value < 0 then
764 CurrText := '-' + IntToStr(Abs(Value div Scaling)) + DecimalSeparator + PadText + FractionText
765 else
766 CurrText := IntToStr(Abs(Value div Scaling)) + DecimalSeparator + PadText + FractionText;
767 try
768 result := StrToCurr(CurrText);
769 except
770 on E: Exception do
771 IBError(ibxeInvalidDataConversion, [nil]);
772 end;
773 end
774 else
775 result := Value;
776 end;
777
778 function TSQLDataItem.GetDateFormatStr(IncludeTime: boolean): AnsiString;
779 begin
780 {$IF declared(DefaultFormatSettings)}
781 with DefaultFormatSettings do
782 {$ELSE}
783 {$IF declared(FormatSettings)}
784 with FormatSettings do
785 {$IFEND}
786 {$IFEND}
787 case GetSQLDialect of
788 1:
789 if IncludeTime then
790 result := ShortDateFormat + ' ' + LongTimeFormat
791 else
792 result := ShortDateFormat;
793 3:
794 result := ShortDateFormat;
795 end;
796 end;
797
798 function TSQLDataItem.GetTimeFormatStr: AnsiString;
799 begin
800 {$IF declared(DefaultFormatSettings)}
801 with DefaultFormatSettings do
802 {$ELSE}
803 {$IF declared(FormatSettings)}
804 with FormatSettings do
805 {$IFEND}
806 {$IFEND}
807 Result := LongTimeFormat;
808 end;
809
810 function TSQLDataItem.GetTimestampFormatStr: AnsiString;
811 begin
812 {$IF declared(DefaultFormatSettings)}
813 with DefaultFormatSettings do
814 {$ELSE}
815 {$IF declared(FormatSettings)}
816 with FormatSettings do
817 {$IFEND}
818 {$IFEND}
819 Result := ShortDateFormat + ' ' + LongTimeFormat + '.zzz';
820 end;
821
822 procedure TSQLDataItem.SetAsInteger(AValue: Integer);
823 begin
824 SetAsLong(aValue);
825 end;
826
827 function TSQLDataItem.AdjustScaleFromCurrency(Value: Currency; aScale: Integer
828 ): Int64;
829 var
830 Scaling : Int64;
831 i : Integer;
832 begin
833 Result := 0;
834 Scaling := 1;
835 if aScale < 0 then
836 begin
837 for i := -1 downto aScale do
838 Scaling := Scaling * 10;
839 result := trunc(Value * Scaling);
840 end
841 else
842 if aScale > 0 then
843 begin
844 for i := 1 to aScale do
845 Scaling := Scaling * 10;
846 result := trunc(Value / Scaling);
847 end
848 else
849 result := trunc(Value);
850 end;
851
852 function TSQLDataItem.AdjustScaleFromDouble(Value: Double; aScale: Integer
853 ): Int64;
854 var
855 Scaling : Int64;
856 i : Integer;
857 begin
858 Result := 0;
859 Scaling := 1;
860 if aScale < 0 then
861 begin
862 for i := -1 downto aScale do
863 Scaling := Scaling * 10;
864 result := trunc(Value * Scaling);
865 end
866 else
867 if aScale > 0 then
868 begin
869 for i := 1 to aScale do
870 Scaling := Scaling * 10;
871 result := trunc(Value / Scaling);
872 end
873 else
874 result := trunc(Value);
875 end;
876
877 procedure TSQLDataItem.CheckActive;
878 begin
879 //Do nothing by default
880 end;
881
882 procedure TSQLDataItem.Changed;
883 begin
884 //Do nothing by default
885 end;
886
887 procedure TSQLDataItem.Changing;
888 begin
889 //Do nothing by default
890 end;
891
892 procedure TSQLDataItem.InternalSetAsString(Value: AnsiString);
893 begin
894 //Do nothing by default
895 end;
896
897 function TSQLDataItem.Transliterate(s: AnsiString; CodePage: TSystemCodePage
898 ): RawByteString;
899 begin
900 Result := s;
901 if StringCodePage(Result) <> CodePage then
902 SetCodePage(Result,CodePage,CodePage <> CP_NONE);
903 end;
904
905 procedure TSQLDataItem.SetScale(aValue: integer);
906 begin
907 //Do nothing by default
908 end;
909
910 procedure TSQLDataItem.SetDataLength(len: cardinal);
911 begin
912 //Do nothing by default
913 end;
914
915 procedure TSQLDataItem.SetSQLType(aValue: cardinal);
916 begin
917 //Do nothing by default
918 end;
919
920 constructor TSQLDataItem.Create(api: TFBClientAPI);
921 begin
922 inherited Create;
923 FFirebirdClientAPI := api;
924 end;
925
926 function TSQLDataItem.GetSQLTypeName: AnsiString;
927 begin
928 Result := GetSQLTypeName(GetSQLType);
929 end;
930
931 class function TSQLDataItem.GetSQLTypeName(SQLType: short): AnsiString;
932 begin
933 Result := 'Unknown';
934 case SQLType of
935 SQL_VARYING: Result := 'SQL_VARYING';
936 SQL_TEXT: Result := 'SQL_TEXT';
937 SQL_DOUBLE: Result := 'SQL_DOUBLE';
938 SQL_FLOAT: Result := 'SQL_FLOAT';
939 SQL_LONG: Result := 'SQL_LONG';
940 SQL_SHORT: Result := 'SQL_SHORT';
941 SQL_TIMESTAMP: Result := 'SQL_TIMESTAMP';
942 SQL_BLOB: Result := 'SQL_BLOB';
943 SQL_D_FLOAT: Result := 'SQL_D_FLOAT';
944 SQL_ARRAY: Result := 'SQL_ARRAY';
945 SQL_QUAD: Result := 'SQL_QUAD';
946 SQL_TYPE_TIME: Result := 'SQL_TYPE_TIME';
947 SQL_TYPE_DATE: Result := 'SQL_TYPE_DATE';
948 SQL_INT64: Result := 'SQL_INT64';
949 end;
950 end;
951
952 function TSQLDataItem.GetAsBoolean: boolean;
953 begin
954 CheckActive;
955 result := false;
956 if not IsNull then
957 begin
958 if SQLType = SQL_BOOLEAN then
959 result := PByte(SQLData)^ = ISC_TRUE
960 else
961 IBError(ibxeInvalidDataConversion, [nil]);
962 end
963 end;
964
965 function TSQLDataItem.GetAsCurrency: Currency;
966 begin
967 CheckActive;
968 result := 0;
969 if GetSQLDialect < 3 then
970 result := GetAsDouble
971 else begin
972 if not IsNull then
973 case SQLType of
974 SQL_TEXT, SQL_VARYING: begin
975 try
976 result := StrtoCurr(AsString);
977 except
978 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
979 end;
980 end;
981 SQL_SHORT:
982 result := AdjustScaleToCurrency(Int64(PShort(SQLData)^),
983 Scale);
984 SQL_LONG:
985 result := AdjustScaleToCurrency(Int64(PLong(SQLData)^),
986 Scale);
987 SQL_INT64:
988 result := AdjustScaleToCurrency(PInt64(SQLData)^,
989 Scale);
990 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
991 result := Trunc(AsDouble);
992 else
993 IBError(ibxeInvalidDataConversion, [nil]);
994 end;
995 end;
996 end;
997
998 function TSQLDataItem.GetAsInt64: Int64;
999 begin
1000 CheckActive;
1001 result := 0;
1002 if not IsNull then
1003 case SQLType of
1004 SQL_TEXT, SQL_VARYING: begin
1005 try
1006 result := StrToInt64(AsString);
1007 except
1008 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
1009 end;
1010 end;
1011 SQL_SHORT:
1012 result := AdjustScaleToInt64(Int64(PShort(SQLData)^),
1013 Scale);
1014 SQL_LONG:
1015 result := AdjustScaleToInt64(Int64(PLong(SQLData)^),
1016 Scale);
1017 SQL_INT64:
1018 result := AdjustScaleToInt64(PInt64(SQLData)^,
1019 Scale);
1020 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1021 result := Trunc(AsDouble);
1022 else
1023 IBError(ibxeInvalidDataConversion, [nil]);
1024 end;
1025 end;
1026
1027 function TSQLDataItem.GetAsDateTime: TDateTime;
1028 begin
1029 CheckActive;
1030 result := 0;
1031 if not IsNull then
1032 with FFirebirdClientAPI do
1033 case SQLType of
1034 SQL_TEXT, SQL_VARYING: begin
1035 try
1036 result := StrToDate(AsString);
1037 except
1038 on E: EConvertError do IBError(ibxeInvalidDataConversion, [nil]);
1039 end;
1040 end;
1041 SQL_TYPE_DATE:
1042 result := SQLDecodeDate(SQLData);
1043 SQL_TYPE_TIME:
1044 result := SQLDecodeTime(SQLData);
1045 SQL_TIMESTAMP:
1046 result := SQLDecodeDateTime(SQLData);
1047 else
1048 IBError(ibxeInvalidDataConversion, [nil]);
1049 end;
1050 end;
1051
1052 function TSQLDataItem.GetAsDouble: Double;
1053 begin
1054 CheckActive;
1055 result := 0;
1056 if not IsNull then begin
1057 case SQLType of
1058 SQL_TEXT, SQL_VARYING: begin
1059 try
1060 result := StrToFloat(AsString);
1061 except
1062 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
1063 end;
1064 end;
1065 SQL_SHORT:
1066 result := AdjustScale(Int64(PShort(SQLData)^),
1067 Scale);
1068 SQL_LONG:
1069 result := AdjustScale(Int64(PLong(SQLData)^),
1070 Scale);
1071 SQL_INT64:
1072 result := AdjustScale(PInt64(SQLData)^, Scale);
1073 SQL_FLOAT:
1074 result := PFloat(SQLData)^;
1075 SQL_DOUBLE, SQL_D_FLOAT:
1076 result := PDouble(SQLData)^;
1077 else
1078 IBError(ibxeInvalidDataConversion, [nil]);
1079 end;
1080 if Scale <> 0 then
1081 result :=
1082 StrToFloat(FloatToStrF(result, fffixed, 15,
1083 Abs(Scale) ));
1084 end;
1085 end;
1086
1087 function TSQLDataItem.GetAsFloat: Float;
1088 begin
1089 CheckActive;
1090 result := 0;
1091 try
1092 result := AsDouble;
1093 except
1094 on E: EOverflow do
1095 IBError(ibxeInvalidDataConversion, [nil]);
1096 end;
1097 end;
1098
1099 function TSQLDataItem.GetAsLong: Long;
1100 begin
1101 CheckActive;
1102 result := 0;
1103 if not IsNull then
1104 case SQLType of
1105 SQL_TEXT, SQL_VARYING: begin
1106 try
1107 result := StrToInt(AsString);
1108 except
1109 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
1110 end;
1111 end;
1112 SQL_SHORT:
1113 result := Trunc(AdjustScale(Int64(PShort(SQLData)^),
1114 Scale));
1115 SQL_LONG:
1116 result := Trunc(AdjustScale(Int64(PLong(SQLData)^),
1117 Scale));
1118 SQL_INT64:
1119 result := Trunc(AdjustScale(PInt64(SQLData)^, Scale));
1120 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1121 result := Trunc(AsDouble);
1122 else
1123 IBError(ibxeInvalidDataConversion, [nil]);
1124 end;
1125 end;
1126
1127 function TSQLDataItem.GetAsPointer: Pointer;
1128 begin
1129 CheckActive;
1130 if not IsNull then
1131 result := SQLData
1132 else
1133 result := nil;
1134 end;
1135
1136 function TSQLDataItem.GetAsQuad: TISC_QUAD;
1137 begin
1138 CheckActive;
1139 result.gds_quad_high := 0;
1140 result.gds_quad_low := 0;
1141 if not IsNull then
1142 case SQLType of
1143 SQL_BLOB, SQL_ARRAY, SQL_QUAD:
1144 result := PISC_QUAD(SQLData)^;
1145 else
1146 IBError(ibxeInvalidDataConversion, [nil]);
1147 end;
1148 end;
1149
1150 function TSQLDataItem.GetAsShort: short;
1151 begin
1152 CheckActive;
1153 result := 0;
1154 try
1155 result := AsLong;
1156 except
1157 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
1158 end;
1159 end;
1160
1161
1162 function TSQLDataItem.GetAsString: AnsiString;
1163 var
1164 sz: PByte;
1165 str_len: Integer;
1166 rs: RawByteString;
1167 begin
1168 CheckActive;
1169 result := '';
1170 { Check null, if so return a default string }
1171 if not IsNull then
1172 with FFirebirdClientAPI do
1173 case SQLType of
1174 SQL_BOOLEAN:
1175 if AsBoolean then
1176 Result := sTrue
1177 else
1178 Result := SFalse;
1179
1180 SQL_TEXT, SQL_VARYING:
1181 begin
1182 sz := SQLData;
1183 if (SQLType = SQL_TEXT) then
1184 str_len := DataLength
1185 else begin
1186 str_len := DecodeInteger(SQLData, 2);
1187 Inc(sz, 2);
1188 end;
1189 SetString(rs, PAnsiChar(sz), str_len);
1190 SetCodePage(rs,GetCodePage,false);
1191 if (SQLType = SQL_TEXT) and (GetCharSetID <> 1) then
1192 Result := TrimRight(rs)
1193 else
1194 Result := rs
1195 end;
1196 SQL_TYPE_DATE:
1197 result := FormatDateTime(GetDateFormatStr(TimeOf(AsDateTime)<>0),AsDateTime);
1198 SQL_TYPE_TIME :
1199 result := FormatDateTime(GetTimeFormatStr,AsDateTime);
1200 SQL_TIMESTAMP:
1201 result := FormatDateTime(GetTimestampFormatStr,AsDateTime);
1202 SQL_SHORT, SQL_LONG:
1203 if Scale = 0 then
1204 result := IntToStr(AsLong)
1205 else if Scale >= (-4) then
1206 result := CurrToStr(AsCurrency)
1207 else
1208 result := FloatToStr(AsDouble);
1209 SQL_INT64:
1210 if Scale = 0 then
1211 result := IntToStr(AsInt64)
1212 else if Scale >= (-4) then
1213 result := CurrToStr(AsCurrency)
1214 else
1215 result := FloatToStr(AsDouble);
1216 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1217 result := FloatToStr(AsDouble);
1218 else
1219 IBError(ibxeInvalidDataConversion, [nil]);
1220 end;
1221 end;
1222
1223 function TSQLDataItem.GetIsNull: Boolean;
1224 begin
1225 CheckActive;
1226 Result := false;
1227 end;
1228
1229 function TSQLDataItem.GetIsNullable: boolean;
1230 begin
1231 CheckActive;
1232 Result := false;
1233 end;
1234
1235 function TSQLDataItem.GetAsVariant: Variant;
1236 begin
1237 CheckActive;
1238 if IsNull then
1239 result := NULL
1240 { Check null, if so return a default string }
1241 else case SQLType of
1242 SQL_ARRAY:
1243 result := '(Array)'; {do not localize}
1244 SQL_BLOB,
1245 SQL_TEXT, SQL_VARYING:
1246 result := AsString;
1247 SQL_TIMESTAMP, SQL_TYPE_DATE, SQL_TYPE_TIME:
1248 result := AsDateTime;
1249 SQL_SHORT, SQL_LONG:
1250 if Scale = 0 then
1251 result := AsLong
1252 else if Scale >= (-4) then
1253 result := AsCurrency
1254 else
1255 result := AsDouble;
1256 SQL_INT64:
1257 if Scale = 0 then
1258 result := AsInt64
1259 else if Scale >= (-4) then
1260 result := AsCurrency
1261 else
1262 result := AsDouble;
1263 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1264 result := AsDouble;
1265 SQL_BOOLEAN:
1266 result := AsBoolean;
1267 else
1268 IBError(ibxeInvalidDataConversion, [nil]);
1269 end;
1270 end;
1271
1272 function TSQLDataItem.GetModified: boolean;
1273 begin
1274 Result := false;
1275 end;
1276
1277 function TSQLDataItem.GetDateTimeStrLength(DateTimeFormat: TIBDateTimeFormats
1278 ): integer;
1279 begin
1280 case DateTimeFormat of
1281 dfTimestamp:
1282 Result := Length(GetTimestampFormatStr);
1283 dfDateTime:
1284 Result := Length(GetDateFormatStr(true));
1285 dfTime:
1286 Result := Length(GetTimeFormatStr);
1287 else
1288 Result := 0;
1289 end;
1290 end;
1291
1292
1293 procedure TSQLDataItem.SetIsNull(Value: Boolean);
1294 begin
1295 //ignore unless overridden
1296 end;
1297
1298 procedure TSQLDataItem.SetIsNullable(Value: Boolean);
1299 begin
1300 //ignore unless overridden
1301 end;
1302
1303 procedure TSQLDataItem.SetName(aValue: AnsiString);
1304 begin
1305 //ignore unless overridden
1306 end;
1307
1308 procedure TSQLDataItem.SetAsCurrency(Value: Currency);
1309 begin
1310 CheckActive;
1311 if GetSQLDialect < 3 then
1312 AsDouble := Value
1313 else
1314 begin
1315 Changing;
1316 if IsNullable then
1317 IsNull := False;
1318 SQLType := SQL_INT64;
1319 Scale := -4;
1320 DataLength := SizeOf(Int64);
1321 PCurrency(SQLData)^ := Value;
1322 Changed;
1323 end;
1324 end;
1325
1326 procedure TSQLDataItem.SetAsInt64(Value: Int64);
1327 begin
1328 CheckActive;
1329 Changing;
1330 if IsNullable then
1331 IsNull := False;
1332
1333 SQLType := SQL_INT64;
1334 Scale := 0;
1335 DataLength := SizeOf(Int64);
1336 PInt64(SQLData)^ := Value;
1337 Changed;
1338 end;
1339
1340 procedure TSQLDataItem.SetAsDate(Value: TDateTime);
1341 begin
1342 CheckActive;
1343 if GetSQLDialect < 3 then
1344 begin
1345 AsDateTime := Value;
1346 exit;
1347 end;
1348
1349 Changing;
1350 if IsNullable then
1351 IsNull := False;
1352
1353 SQLType := SQL_TYPE_DATE;
1354 DataLength := SizeOf(ISC_DATE);
1355 with FFirebirdClientAPI do
1356 SQLEncodeDate(Value,SQLData);
1357 Changed;
1358 end;
1359
1360 procedure TSQLDataItem.SetAsTime(Value: TDateTime);
1361 begin
1362 CheckActive;
1363 if GetSQLDialect < 3 then
1364 begin
1365 AsDateTime := Value;
1366 exit;
1367 end;
1368
1369 Changing;
1370 if IsNullable then
1371 IsNull := False;
1372
1373 SQLType := SQL_TYPE_TIME;
1374 DataLength := SizeOf(ISC_TIME);
1375 with FFirebirdClientAPI do
1376 SQLEncodeTime(Value,SQLData);
1377 Changed;
1378 end;
1379
1380 procedure TSQLDataItem.SetAsDateTime(Value: TDateTime);
1381 begin
1382 CheckActive;
1383 if IsNullable then
1384 IsNull := False;
1385
1386 Changing;
1387 SQLType := SQL_TIMESTAMP;
1388 DataLength := SizeOf(ISC_TIME) + sizeof(ISC_DATE);
1389 with FFirebirdClientAPI do
1390 SQLEncodeDateTime(Value,SQLData);
1391 Changed;
1392 end;
1393
1394 procedure TSQLDataItem.SetAsDouble(Value: Double);
1395 begin
1396 CheckActive;
1397 if IsNullable then
1398 IsNull := False;
1399
1400 Changing;
1401 SQLType := SQL_DOUBLE;
1402 DataLength := SizeOf(Double);
1403 Scale := 0;
1404 PDouble(SQLData)^ := Value;
1405 Changed;
1406 end;
1407
1408 procedure TSQLDataItem.SetAsFloat(Value: Float);
1409 begin
1410 CheckActive;
1411 if IsNullable then
1412 IsNull := False;
1413
1414 Changing;
1415 SQLType := SQL_FLOAT;
1416 DataLength := SizeOf(Float);
1417 Scale := 0;
1418 PSingle(SQLData)^ := Value;
1419 Changed;
1420 end;
1421
1422 procedure TSQLDataItem.SetAsLong(Value: Long);
1423 begin
1424 CheckActive;
1425 if IsNullable then
1426 IsNull := False;
1427
1428 Changing;
1429 SQLType := SQL_LONG;
1430 DataLength := SizeOf(Long);
1431 Scale := 0;
1432 PLong(SQLData)^ := Value;
1433 Changed;
1434 end;
1435
1436 procedure TSQLDataItem.SetAsPointer(Value: Pointer);
1437 begin
1438 CheckActive;
1439 Changing;
1440 if IsNullable and (Value = nil) then
1441 IsNull := True
1442 else
1443 begin
1444 IsNull := False;
1445 SQLType := SQL_TEXT;
1446 Move(Value^, SQLData^, DataLength);
1447 end;
1448 Changed;
1449 end;
1450
1451 procedure TSQLDataItem.SetAsQuad(Value: TISC_QUAD);
1452 begin
1453 CheckActive;
1454 Changing;
1455 if IsNullable then
1456 IsNull := False;
1457 if (SQLType <> SQL_BLOB) and
1458 (SQLType <> SQL_ARRAY) then
1459 IBError(ibxeInvalidDataConversion, [nil]);
1460 DataLength := SizeOf(TISC_QUAD);
1461 PISC_QUAD(SQLData)^ := Value;
1462 Changed;
1463 end;
1464
1465 procedure TSQLDataItem.SetAsShort(Value: short);
1466 begin
1467 CheckActive;
1468 Changing;
1469 if IsNullable then
1470 IsNull := False;
1471
1472 SQLType := SQL_SHORT;
1473 DataLength := SizeOf(Short);
1474 Scale := 0;
1475 PShort(SQLData)^ := Value;
1476 Changed;
1477 end;
1478
1479 procedure TSQLDataItem.SetAsString(Value: AnsiString);
1480 begin
1481 InternalSetAsString(Value);
1482 end;
1483
1484 procedure TSQLDataItem.SetAsVariant(Value: Variant);
1485 begin
1486 CheckActive;
1487 if VarIsNull(Value) then
1488 IsNull := True
1489 else case VarType(Value) of
1490 varEmpty, varNull:
1491 IsNull := True;
1492 varSmallint, varInteger, varByte,
1493 varWord, varShortInt:
1494 AsLong := Value;
1495 varInt64:
1496 AsInt64 := Value;
1497 varSingle, varDouble:
1498 AsDouble := Value;
1499 varCurrency:
1500 AsCurrency := Value;
1501 varBoolean:
1502 AsBoolean := Value;
1503 varDate:
1504 AsDateTime := Value;
1505 varOleStr, varString:
1506 AsString := Value;
1507 varArray:
1508 IBError(ibxeNotSupported, [nil]);
1509 varByRef, varDispatch, varError, varUnknown, varVariant:
1510 IBError(ibxeNotPermitted, [nil]);
1511 end;
1512 end;
1513
1514 procedure TSQLDataItem.SetAsNumeric(Value: Int64; aScale: integer);
1515 begin
1516 CheckActive;
1517 Changing;
1518 if IsNullable then
1519 IsNull := False;
1520
1521 SQLType := SQL_INT64;
1522 Scale := aScale;
1523 DataLength := SizeOf(Int64);
1524 PInt64(SQLData)^ := Value;
1525 Changed;
1526 end;
1527
1528 procedure TSQLDataItem.SetAsBoolean(AValue: boolean);
1529 begin
1530 CheckActive;
1531 Changing;
1532 if IsNullable then
1533 IsNull := False;
1534
1535 SQLType := SQL_BOOLEAN;
1536 DataLength := 1;
1537 Scale := 0;
1538 if AValue then
1539 PByte(SQLData)^ := ISC_TRUE
1540 else
1541 PByte(SQLData)^ := ISC_FALSE;
1542 Changed;
1543 end;
1544
1545 {TColumnMetaData}
1546
1547 procedure TColumnMetaData.CheckActive;
1548 begin
1549 if not FIBXSQLVAR.Parent.StateChanged(FChangeSeqNo) then Exit;
1550
1551 if FPrepareSeqNo < FIBXSQLVAR.Parent.GetPrepareSeqNo then
1552 IBError(ibxeInterfaceOutofDate,[nil]);
1553
1554 if not FIBXSQLVAR.Parent.CheckStatementStatus(ssPrepared) then
1555 IBError(ibxeStatementNotPrepared, [nil]);
1556 end;
1557
1558 function TColumnMetaData.SQLData: PByte;
1559 begin
1560 Result := FIBXSQLVAR.SQLData;
1561 end;
1562
1563 function TColumnMetaData.GetDataLength: cardinal;
1564 begin
1565 Result := FIBXSQLVAR.DataLength;
1566 end;
1567
1568 function TColumnMetaData.GetCodePage: TSystemCodePage;
1569 begin
1570 Result := FIBXSQLVAR.GetCodePage;
1571 end;
1572
1573 constructor TColumnMetaData.Create(aOwner: IUnknown; aIBXSQLVAR: TSQLVarData);
1574 begin
1575 inherited Create(aIBXSQLVAR.GetStatement.GetAttachment.getFirebirdAPI as TFBClientAPI);
1576 FIBXSQLVAR := aIBXSQLVAR;
1577 FOwner := aOwner;
1578 FPrepareSeqNo := FIBXSQLVAR.Parent.PrepareSeqNo;
1579 FIBXSQLVAR.Parent.StateChanged(FChangeSeqNo)
1580 end;
1581
1582 destructor TColumnMetaData.Destroy;
1583 begin
1584 (FOwner as TInterfaceOwner).Remove(self);
1585 inherited Destroy;
1586 end;
1587
1588
1589 function TColumnMetaData.GetSQLDialect: integer;
1590 begin
1591 Result := FIBXSQLVAR.Statement.GetSQLDialect;
1592 end;
1593
1594 function TColumnMetaData.GetIndex: integer;
1595 begin
1596 Result := FIBXSQLVAR.Index;
1597 end;
1598
1599 function TColumnMetaData.GetSQLType: cardinal;
1600 begin
1601 CheckActive;
1602 result := FIBXSQLVAR.SQLType;
1603 end;
1604
1605 function TColumnMetaData.getSubtype: integer;
1606 begin
1607 CheckActive;
1608 result := FIBXSQLVAR.SQLSubtype;
1609 end;
1610
1611 function TColumnMetaData.getRelationName: AnsiString;
1612 begin
1613 CheckActive;
1614 result := FIBXSQLVAR.RelationName;
1615 end;
1616
1617 function TColumnMetaData.getOwnerName: AnsiString;
1618 begin
1619 CheckActive;
1620 result := FIBXSQLVAR.OwnerName;
1621 end;
1622
1623 function TColumnMetaData.getSQLName: AnsiString;
1624 begin
1625 CheckActive;
1626 result := FIBXSQLVAR.FieldName;
1627 end;
1628
1629 function TColumnMetaData.getAliasName: AnsiString;
1630 begin
1631 CheckActive;
1632 result := FIBXSQLVAR.AliasName;
1633 end;
1634
1635 function TColumnMetaData.GetName: AnsiString;
1636 begin
1637 CheckActive;
1638 Result := FIBXSQLVAR. Name;
1639 end;
1640
1641 function TColumnMetaData.GetScale: integer;
1642 begin
1643 CheckActive;
1644 result := FIBXSQLVAR.Scale;
1645 end;
1646
1647 function TColumnMetaData.getCharSetID: cardinal;
1648 begin
1649 CheckActive;
1650 Result := FIBXSQLVAR.CharSetID;
1651 end;
1652
1653 function TColumnMetaData.GetIsNullable: boolean;
1654 begin
1655 CheckActive;
1656 result := FIBXSQLVAR.IsNullable;
1657 end;
1658
1659 function TColumnMetaData.GetSize: cardinal;
1660 begin
1661 CheckActive;
1662 result := FIBXSQLVAR.DataLength;
1663 end;
1664
1665 function TColumnMetaData.GetArrayMetaData: IArrayMetaData;
1666 begin
1667 CheckActive;
1668 result := FIBXSQLVAR.GetArrayMetaData;
1669 end;
1670
1671 function TColumnMetaData.GetBlobMetaData: IBlobMetaData;
1672 begin
1673 CheckActive;
1674 result := FIBXSQLVAR.GetBlobMetaData;
1675 end;
1676
1677 { TIBSQLData }
1678
1679 procedure TIBSQLData.CheckActive;
1680 begin
1681 if not FIBXSQLVAR.Parent.StateChanged(FChangeSeqNo) then Exit;
1682
1683 inherited CheckActive;
1684
1685 if not FIBXSQLVAR.Parent.CheckStatementStatus(ssCursorOpen) and
1686 not FIBXSQLVAR.Parent.CheckStatementStatus(ssExecuteResults) then
1687 IBError(ibxeSQLClosed, [nil]);
1688
1689 if FIBXSQLVAR.Parent.CheckStatementStatus(ssEOF) then
1690 IBError(ibxeEOF,[nil]);
1691
1692 if FIBXSQLVAR.Parent.CheckStatementStatus(ssBOF) then
1693 IBError(ibxeBOF,[nil]);
1694 end;
1695
1696 function TIBSQLData.GetIsNull: Boolean;
1697 begin
1698 CheckActive;
1699 result := FIBXSQLVAR.IsNull;
1700 end;
1701
1702 function TIBSQLData.GetAsArray: IArray;
1703 begin
1704 CheckActive;
1705 result := FIBXSQLVAR.GetAsArray(AsQuad);
1706 end;
1707
1708 function TIBSQLData.GetAsBlob: IBlob;
1709 begin
1710 CheckActive;
1711 result := FIBXSQLVAR.GetAsBlob(AsQuad,nil);
1712 end;
1713
1714 function TIBSQLData.GetAsBlob(BPB: IBPB): IBlob;
1715 begin
1716 CheckActive;
1717 result := FIBXSQLVAR.GetAsBlob(AsQuad,BPB);
1718 end;
1719
1720 function TIBSQLData.GetAsString: AnsiString;
1721 begin
1722 CheckActive;
1723 Result := '';
1724 { Check null, if so return a default string }
1725 if not IsNull then
1726 case SQLType of
1727 SQL_ARRAY:
1728 result := SArray;
1729 SQL_BLOB:
1730 Result := FIBXSQLVAR.GetAsBlob(AsQuad,nil).GetAsString;
1731 else
1732 Result := inherited GetAsString;
1733 end;
1734 end;
1735
1736 { TSQLParam }
1737
1738 procedure TSQLParam.InternalSetAsString(Value: AnsiString);
1739
1740 procedure DoSetString;
1741 begin
1742 Changing;
1743 FIBXSQLVar.SetString(Transliterate(Value,GetCodePage));
1744 Changed;
1745 end;
1746
1747 var b: IBlob;
1748 dt: TDateTime;
1749 CurrValue: Currency;
1750 FloatValue: single;
1751 begin
1752 CheckActive;
1753 if IsNullable then
1754 IsNull := False;
1755 case SQLTYPE of
1756 SQL_BOOLEAN:
1757 if AnsiCompareText(Value,STrue) = 0 then
1758 AsBoolean := true
1759 else
1760 if AnsiCompareText(Value,SFalse) = 0 then
1761 AsBoolean := false
1762 else
1763 IBError(ibxeInvalidDataConversion,[nil]);
1764
1765 SQL_BLOB:
1766 begin
1767 Changing;
1768 b := FIBXSQLVAR.CreateBlob;
1769 b.SetAsString(Value);
1770 AsBlob := b;
1771 Changed;
1772 end;
1773
1774 SQL_VARYING,
1775 SQL_TEXT:
1776 DoSetString;
1777
1778 SQL_SHORT,
1779 SQL_LONG,
1780 SQL_INT64:
1781 if TryStrToCurr(Value,CurrValue) then
1782 SetAsNumeric(AdjustScaleFromCurrency(CurrValue,GetScale),GetScale)
1783 else
1784 DoSetString;
1785
1786 SQL_D_FLOAT,
1787 SQL_DOUBLE,
1788 SQL_FLOAT:
1789 if TryStrToFloat(Value,FloatValue) then
1790 SetAsDouble(FloatValue)
1791 else
1792 DoSetString;
1793
1794 SQL_TIMESTAMP:
1795 if TryStrToDateTime(Value,dt) then
1796 SetAsDateTime(dt)
1797 else
1798 DoSetString;
1799
1800 SQL_TYPE_DATE:
1801 if TryStrToDateTime(Value,dt) then
1802 SetAsDate(dt)
1803 else
1804 DoSetString;
1805
1806 SQL_TYPE_TIME:
1807 if TryStrToDateTime(Value,dt) then
1808 SetAsTime(dt)
1809 else
1810 DoSetString;
1811
1812 else
1813 IBError(ibxeInvalidDataConversion,[nil]);
1814 end;
1815 end;
1816
1817 procedure TSQLParam.CheckActive;
1818 begin
1819 if not FIBXSQLVAR.Parent.StateChanged(FChangeSeqNo) then Exit;
1820
1821 if FPrepareSeqNo < FIBXSQLVAR.Parent.GetPrepareSeqNo then
1822 IBError(ibxeInterfaceOutofDate,[nil]);
1823
1824 if not FIBXSQLVAR.Parent.CheckStatementStatus(ssPrepared) then
1825 IBError(ibxeStatementNotPrepared, [nil]);
1826 end;
1827
1828 procedure TSQLParam.SetScale(aValue: integer);
1829 begin
1830 CheckActive;
1831 FIBXSQLVAR.Scale := aValue;
1832 end;
1833
1834 procedure TSQLParam.SetDataLength(len: cardinal);
1835 begin
1836 CheckActive;
1837 FIBXSQLVAR.DataLength := len;
1838 end;
1839
1840 procedure TSQLParam.SetSQLType(aValue: cardinal);
1841 begin
1842 CheckActive;
1843 FIBXSQLVAR.SQLType := aValue;
1844 end;
1845
1846 procedure TSQLParam.Clear;
1847 begin
1848 IsNull := true;
1849 end;
1850
1851 function TSQLParam.GetModified: boolean;
1852 begin
1853 CheckActive;
1854 Result := FIBXSQLVAR.Modified;
1855 end;
1856
1857 function TSQLParam.GetAsPointer: Pointer;
1858 begin
1859 IsNull := false; {Assume that we get the pointer in order to set a value}
1860 Changed;
1861 Result := inherited GetAsPointer;
1862 end;
1863
1864 procedure TSQLParam.SetName(Value: AnsiString);
1865 begin
1866 CheckActive;
1867 FIBXSQLVAR.Name := Value;
1868 end;
1869
1870 procedure TSQLParam.SetIsNull(Value: Boolean);
1871 var i: integer;
1872 begin
1873 CheckActive;
1874 if FIBXSQLVAR.UniqueName then
1875 FIBXSQLVAR.IsNull := Value
1876 else
1877 with FIBXSQLVAR.Parent do
1878 begin
1879 for i := 0 to Count - 1 do
1880 if Column[i].Name = Name then
1881 Column[i].IsNull := Value;
1882 end
1883 end;
1884
1885 procedure TSQLParam.SetIsNullable(Value: Boolean);
1886 var i: integer;
1887 begin
1888 CheckActive;
1889 if FIBXSQLVAR.UniqueName then
1890 FIBXSQLVAR.IsNullable := Value
1891 else
1892 with FIBXSQLVAR.Parent do
1893 begin
1894 for i := 0 to Count - 1 do
1895 if Column[i].Name = Name then
1896 Column[i].IsNullable := Value;
1897 end
1898 end;
1899
1900 procedure TSQLParam.SetAsArray(anArray: IArray);
1901 begin
1902 CheckActive;
1903 if GetSQLType <> SQL_ARRAY then
1904 IBError(ibxeInvalidDataConversion,[nil]);
1905
1906 if not FIBXSQLVAR.UniqueName then
1907 IBError(ibxeDuplicateParamName,[FIBXSQLVAR.Name]);
1908
1909 SetAsQuad(AnArray.GetArrayID);
1910 end;
1911
1912 procedure TSQLParam.Changed;
1913 begin
1914 FIBXSQLVAR.Changed;
1915 end;
1916
1917 procedure TSQLParam.SetAsBoolean(AValue: boolean);
1918 var i: integer;
1919 OldSQLVar: TSQLVarData;
1920 begin
1921 if FIBXSQLVAR.UniqueName then
1922 inherited SetAsBoolean(AValue)
1923 else
1924 with FIBXSQLVAR.Parent do
1925 begin
1926 for i := 0 to Count - 1 do
1927 if Column[i].Name = Name then
1928 begin
1929 OldSQLVar := FIBXSQLVAR;
1930 FIBXSQLVAR := Column[i];
1931 try
1932 inherited SetAsBoolean(AValue);
1933 finally
1934 FIBXSQLVAR := OldSQLVar;
1935 end;
1936 end;
1937 end;
1938 end;
1939
1940 procedure TSQLParam.SetAsCurrency(AValue: Currency);
1941 var i: integer;
1942 OldSQLVar: TSQLVarData;
1943 begin
1944 if FIBXSQLVAR.UniqueName then
1945 inherited SetAsCurrency(AValue)
1946 else
1947 with FIBXSQLVAR.Parent do
1948 begin
1949 for i := 0 to Count - 1 do
1950 if Column[i].Name = Name then
1951 begin
1952 OldSQLVar := FIBXSQLVAR;
1953 FIBXSQLVAR := Column[i];
1954 try
1955 inherited SetAsCurrency(AValue);
1956 finally
1957 FIBXSQLVAR := OldSQLVar;
1958 end;
1959 end;
1960 end;
1961 end;
1962
1963 procedure TSQLParam.SetAsInt64(AValue: Int64);
1964 var i: integer;
1965 OldSQLVar: TSQLVarData;
1966 begin
1967 if FIBXSQLVAR.UniqueName then
1968 inherited SetAsInt64(AValue)
1969 else
1970 with FIBXSQLVAR.Parent do
1971 begin
1972 for i := 0 to Count - 1 do
1973 if Column[i].Name = Name then
1974 begin
1975 OldSQLVar := FIBXSQLVAR;
1976 FIBXSQLVAR := Column[i];
1977 try
1978 inherited SetAsInt64(AValue);
1979 finally
1980 FIBXSQLVAR := OldSQLVar;
1981 end;
1982 end;
1983 end;
1984 end;
1985
1986 procedure TSQLParam.SetAsDate(AValue: TDateTime);
1987 var i: integer;
1988 OldSQLVar: TSQLVarData;
1989 begin
1990 if FIBXSQLVAR.UniqueName then
1991 inherited SetAsDate(AValue)
1992 else
1993 with FIBXSQLVAR.Parent do
1994 begin
1995 for i := 0 to Count - 1 do
1996 if Column[i].Name = Name then
1997 begin
1998 OldSQLVar := FIBXSQLVAR;
1999 FIBXSQLVAR := Column[i];
2000 try
2001 inherited SetAsDate(AValue);
2002 finally
2003 FIBXSQLVAR := OldSQLVar;
2004 end;
2005 end;
2006 end;
2007 end;
2008
2009 procedure TSQLParam.SetAsLong(AValue: Long);
2010 var i: integer;
2011 OldSQLVar: TSQLVarData;
2012 begin
2013 if FIBXSQLVAR.UniqueName then
2014 inherited SetAsLong(AValue)
2015 else
2016 with FIBXSQLVAR.Parent do
2017 begin
2018 for i := 0 to Count - 1 do
2019 if Column[i].Name = Name then
2020 begin
2021 OldSQLVar := FIBXSQLVAR;
2022 FIBXSQLVAR := Column[i];
2023 try
2024 inherited SetAsLong(AValue);
2025 finally
2026 FIBXSQLVAR := OldSQLVar;
2027 end;
2028 end;
2029 end;
2030 end;
2031
2032 procedure TSQLParam.SetAsTime(AValue: TDateTime);
2033 var i: integer;
2034 OldSQLVar: TSQLVarData;
2035 begin
2036 if FIBXSQLVAR.UniqueName then
2037 inherited SetAsTime(AValue)
2038 else
2039 with FIBXSQLVAR.Parent do
2040 begin
2041 for i := 0 to Count - 1 do
2042 if Column[i].Name = Name then
2043 begin
2044 OldSQLVar := FIBXSQLVAR;
2045 FIBXSQLVAR := Column[i];
2046 try
2047 inherited SetAsTime(AValue);
2048 finally
2049 FIBXSQLVAR := OldSQLVar;
2050 end;
2051 end;
2052 end;
2053 end;
2054
2055 procedure TSQLParam.SetAsDateTime(AValue: TDateTime);
2056 var i: integer;
2057 OldSQLVar: TSQLVarData;
2058 begin
2059 if FIBXSQLVAR.UniqueName then
2060 inherited SetAsDateTime(AValue)
2061 else
2062 with FIBXSQLVAR.Parent do
2063 begin
2064 for i := 0 to Count - 1 do
2065 if Column[i].Name = Name then
2066 begin
2067 OldSQLVar := FIBXSQLVAR;
2068 FIBXSQLVAR := Column[i];
2069 try
2070 inherited SetAsDateTime(AValue);
2071 finally
2072 FIBXSQLVAR := OldSQLVar;
2073 end;
2074 end;
2075 end;
2076 end;
2077
2078 procedure TSQLParam.SetAsDouble(AValue: Double);
2079 var i: integer;
2080 OldSQLVar: TSQLVarData;
2081 begin
2082 if FIBXSQLVAR.UniqueName then
2083 inherited SetAsDouble(AValue)
2084 else
2085 with FIBXSQLVAR.Parent do
2086 begin
2087 for i := 0 to Count - 1 do
2088 if Column[i].Name = Name then
2089 begin
2090 OldSQLVar := FIBXSQLVAR;
2091 FIBXSQLVAR := Column[i];
2092 try
2093 inherited SetAsDouble(AValue);
2094 finally
2095 FIBXSQLVAR := OldSQLVar;
2096 end;
2097 end;
2098 end;
2099 end;
2100
2101 procedure TSQLParam.SetAsFloat(AValue: Float);
2102 var i: integer;
2103 OldSQLVar: TSQLVarData;
2104 begin
2105 if FIBXSQLVAR.UniqueName then
2106 inherited SetAsFloat(AValue)
2107 else
2108 with FIBXSQLVAR.Parent do
2109 begin
2110 for i := 0 to Count - 1 do
2111 if Column[i].Name = Name then
2112 begin
2113 OldSQLVar := FIBXSQLVAR;
2114 FIBXSQLVAR := Column[i];
2115 try
2116 inherited SetAsFloat(AValue);
2117 finally
2118 FIBXSQLVAR := OldSQLVar;
2119 end;
2120 end;
2121 end;
2122 end;
2123
2124 procedure TSQLParam.SetAsPointer(AValue: Pointer);
2125 var i: integer;
2126 OldSQLVar: TSQLVarData;
2127 begin
2128 if FIBXSQLVAR.UniqueName then
2129 inherited SetAsPointer(AValue)
2130 else
2131 with FIBXSQLVAR.Parent do
2132 begin
2133 for i := 0 to Count - 1 do
2134 if Column[i].Name = Name then
2135 begin
2136 OldSQLVar := FIBXSQLVAR;
2137 FIBXSQLVAR := Column[i];
2138 try
2139 inherited SetAsPointer(AValue);
2140 finally
2141 FIBXSQLVAR := OldSQLVar;
2142 end;
2143 end;
2144 end;
2145 end;
2146
2147 procedure TSQLParam.SetAsShort(AValue: Short);
2148 var i: integer;
2149 OldSQLVar: TSQLVarData;
2150 begin
2151 if FIBXSQLVAR.UniqueName then
2152 inherited SetAsShort(AValue)
2153 else
2154 with FIBXSQLVAR.Parent do
2155 begin
2156 for i := 0 to Count - 1 do
2157 if Column[i].Name = Name then
2158 begin
2159 OldSQLVar := FIBXSQLVAR;
2160 FIBXSQLVAR := Column[i];
2161 try
2162 inherited SetAsShort(AValue);
2163 finally
2164 FIBXSQLVAR := OldSQLVar;
2165 end;
2166 end;
2167 end;
2168 end;
2169
2170 procedure TSQLParam.SetAsString(AValue: AnsiString);
2171 var i: integer;
2172 OldSQLVar: TSQLVarData;
2173 begin
2174 if FIBXSQLVAR.UniqueName then
2175 InternalSetAsString(AValue)
2176 else
2177 with FIBXSQLVAR.Parent do
2178 begin
2179 for i := 0 to Count - 1 do
2180 if Column[i].Name = Name then
2181 begin
2182 OldSQLVar := FIBXSQLVAR;
2183 FIBXSQLVAR := Column[i];
2184 try
2185 InternalSetAsString(AValue);
2186 finally
2187 FIBXSQLVAR := OldSQLVar;
2188 end;
2189 end;
2190 end;
2191 end;
2192
2193 procedure TSQLParam.SetAsVariant(AValue: Variant);
2194 var i: integer;
2195 OldSQLVar: TSQLVarData;
2196 begin
2197 if FIBXSQLVAR.UniqueName then
2198 inherited SetAsVariant(AValue)
2199 else
2200 with FIBXSQLVAR.Parent do
2201 begin
2202 for i := 0 to Count - 1 do
2203 if Column[i].Name = Name then
2204 begin
2205 OldSQLVar := FIBXSQLVAR;
2206 FIBXSQLVAR := Column[i];
2207 try
2208 inherited SetAsVariant(AValue);
2209 finally
2210 FIBXSQLVAR := OldSQLVar;
2211 end;
2212 end;
2213 end;
2214 end;
2215
2216 procedure TSQLParam.SetAsBlob(aValue: IBlob);
2217 begin
2218 with FIBXSQLVAR do
2219 if not UniqueName then
2220 IBError(ibxeDuplicateParamName,[Name]);
2221 CheckActive;
2222 Changing;
2223 aValue.Close;
2224 if aValue.GetSubType <> GetSubType then
2225 IBError(ibxeIncompatibleBlob,[GetSubType,aValue.GetSubType]);
2226 AsQuad := aValue.GetBlobID;
2227 Changed;
2228 end;
2229
2230 procedure TSQLParam.SetAsQuad(AValue: TISC_QUAD);
2231 var i: integer;
2232 OldSQLVar: TSQLVarData;
2233 begin
2234 if FIBXSQLVAR.UniqueName then
2235 inherited SetAsQuad(AValue)
2236 else
2237 with FIBXSQLVAR.Parent do
2238 begin
2239 for i := 0 to Count - 1 do
2240 if Column[i].Name = Name then
2241 begin
2242 OldSQLVar := FIBXSQLVAR;
2243 FIBXSQLVAR := Column[i];
2244 try
2245 inherited SetAsQuad(AValue);
2246 finally
2247 FIBXSQLVAR := OldSQLVar;
2248 end;
2249 end;
2250 end;
2251 end;
2252
2253 procedure TSQLParam.SetCharSetID(aValue: cardinal);
2254 begin
2255 FIBXSQLVAR.SetCharSetID(aValue);
2256 end;
2257
2258 { TMetaData }
2259
2260 procedure TMetaData.CheckActive;
2261 begin
2262 if FPrepareSeqNo < FMetaData.PrepareSeqNo then
2263 IBError(ibxeInterfaceOutofDate,[nil]);
2264
2265 if not FMetaData.CheckStatementStatus(ssPrepared) then
2266 IBError(ibxeStatementNotPrepared, [nil]);
2267 end;
2268
2269 constructor TMetaData.Create(aMetaData: TSQLDataArea);
2270 begin
2271 inherited Create(aMetaData.Count);
2272 FMetaData := aMetaData;
2273 FStatement := aMetaData.Statement;
2274 FPrepareSeqNo := aMetaData.PrepareSeqNo;
2275 end;
2276
2277 destructor TMetaData.Destroy;
2278 begin
2279 (FStatement as TInterfaceOwner).Remove(self);
2280 inherited Destroy;
2281 end;
2282
2283 function TMetaData.GetUniqueRelationName: AnsiString;
2284 begin
2285 CheckActive;
2286 Result := FMetaData.UniqueRelationName;
2287 end;
2288
2289 function TMetaData.getCount: integer;
2290 begin
2291 CheckActive;
2292 Result := FMetaData.ColumnsInUseCount;
2293 end;
2294
2295 function TMetaData.getColumnMetaData(index: integer): IColumnMetaData;
2296 begin
2297 CheckActive;
2298 if (index < 0) or (index >= getCount) then
2299 IBError(ibxeInvalidColumnIndex,[nil]);
2300
2301 if FMetaData.Count = 0 then
2302 Result := nil
2303 else
2304 begin
2305 if not HasInterface(index) then
2306 AddInterface(index,TColumnMetaData.Create(self,FMetaData.Column[index]));
2307 Result := TColumnMetaData(GetInterface(index));
2308 end;
2309 end;
2310
2311 function TMetaData.ByName(Idx: AnsiString): IColumnMetaData;
2312 var aIBXSQLVAR: TSQLVarData;
2313 begin
2314 CheckActive;
2315 aIBXSQLVAR := FMetaData.ColumnByName(Idx);
2316 if aIBXSQLVAR = nil then
2317 IBError(ibxeFieldNotFound,[Idx]);
2318 Result := getColumnMetaData(aIBXSQLVAR.index);
2319 end;
2320
2321 { TSQLParams }
2322
2323 procedure TSQLParams.CheckActive;
2324 begin
2325 if not FSQLParams.StateChanged(FChangeSeqNo) then Exit;
2326
2327 if FPrepareSeqNo < FSQLParams.PrepareSeqNo then
2328 IBError(ibxeInterfaceOutofDate,[nil]);
2329
2330 if not FSQLParams.CheckStatementStatus(ssPrepared) then
2331 IBError(ibxeStatementNotPrepared, [nil]);
2332 end;
2333
2334 constructor TSQLParams.Create(aSQLParams: TSQLDataArea);
2335 begin
2336 inherited Create(aSQLParams.Count);
2337 FSQLParams := aSQLParams;
2338 FStatement := aSQLParams.Statement;
2339 FPrepareSeqNo := aSQLParams.PrepareSeqNo;
2340 FSQLParams.StateChanged(FChangeSeqNo);
2341 end;
2342
2343 destructor TSQLParams.Destroy;
2344 begin
2345 (FStatement as TInterfaceOwner).Remove(self);
2346 inherited Destroy;
2347 end;
2348
2349 function TSQLParams.getCount: integer;
2350 begin
2351 CheckActive;
2352 Result := FSQLParams.ColumnsInUseCount;
2353 end;
2354
2355 function TSQLParams.getSQLParam(index: integer): ISQLParam;
2356 begin
2357 CheckActive;
2358 if (index < 0) or (index >= getCount) then
2359 IBError(ibxeInvalidColumnIndex,[nil]);
2360
2361 if getCount = 0 then
2362 Result := nil
2363 else
2364 begin
2365 if not HasInterface(index) then
2366 AddInterface(index, TSQLParam.Create(self,FSQLParams.Column[index]));
2367 Result := TSQLParam(GetInterface(index));
2368 end;
2369 end;
2370
2371 function TSQLParams.ByName(Idx: AnsiString): ISQLParam;
2372 var aIBXSQLVAR: TSQLVarData;
2373 begin
2374 CheckActive;
2375 aIBXSQLVAR := FSQLParams.ColumnByName(Idx);
2376 if aIBXSQLVAR = nil then
2377 IBError(ibxeFieldNotFound,[Idx]);
2378 Result := getSQLParam(aIBXSQLVAR.index);
2379 end;
2380
2381 function TSQLParams.GetModified: Boolean;
2382 var
2383 i: Integer;
2384 begin
2385 CheckActive;
2386 result := False;
2387 with FSQLParams do
2388 for i := 0 to Count - 1 do
2389 if Column[i].Modified then
2390 begin
2391 result := True;
2392 exit;
2393 end;
2394 end;
2395
2396 function TSQLParams.GetHasCaseSensitiveParams: Boolean;
2397 begin
2398 Result := FSQLParams.CaseSensitiveParams;
2399 end;
2400
2401 { TResults }
2402
2403 procedure TResults.CheckActive;
2404 begin
2405 if not FResults.StateChanged(FChangeSeqNo) then Exit;
2406
2407 if FPrepareSeqNo < FResults.PrepareSeqNo then
2408 IBError(ibxeInterfaceOutofDate,[nil]);
2409
2410 if not FResults.CheckStatementStatus(ssPrepared) then
2411 IBError(ibxeStatementNotPrepared, [nil]);
2412
2413 with GetTransaction as TFBTransaction do
2414 if not InTransaction or (FResults.TransactionSeqNo <> FTransactionSeqNo) then
2415 IBError(ibxeInterfaceOutofDate,[nil]);
2416 end;
2417
2418 function TResults.GetISQLData(aIBXSQLVAR: TSQLVarData): ISQLData;
2419 begin
2420 if (aIBXSQLVAR.Index < 0) or (aIBXSQLVAR.Index >= getCount) then
2421 IBError(ibxeInvalidColumnIndex,[nil]);
2422
2423 if not HasInterface(aIBXSQLVAR.Index) then
2424 AddInterface(aIBXSQLVAR.Index, TIBSQLData.Create(self,aIBXSQLVAR));
2425 Result := TIBSQLData(GetInterface(aIBXSQLVAR.Index));
2426 end;
2427
2428 constructor TResults.Create(aResults: TSQLDataArea);
2429 begin
2430 inherited Create(aResults.Count);
2431 FResults := aResults;
2432 FStatement := aResults.Statement;
2433 FPrepareSeqNo := aResults.PrepareSeqNo;
2434 FTransactionSeqNo := aResults.TransactionSeqNo;
2435 FResults.StateChanged(FChangeSeqNo);
2436 end;
2437
2438 function TResults.getCount: integer;
2439 begin
2440 CheckActive;
2441 Result := FResults.Count;
2442 end;
2443
2444 function TResults.ByName(Idx: AnsiString): ISQLData;
2445 var col: TSQLVarData;
2446 begin
2447 Result := nil;
2448 CheckActive;
2449 if FResults.CheckStatementStatus(ssBOF) then
2450 IBError(ibxeBOF,[nil]);
2451 if FResults.CheckStatementStatus(ssEOF) then
2452 IBError(ibxeEOF,[nil]);
2453
2454 if FResults.Count > 0 then
2455 begin
2456 col := FResults.ColumnByName(Idx);
2457 if col <> nil then
2458 Result := GetISQLData(col);
2459 end;
2460 end;
2461
2462 function TResults.getSQLData(index: integer): ISQLData;
2463 begin
2464 CheckActive;
2465 if FResults.CheckStatementStatus(ssBOF) then
2466 IBError(ibxeBOF,[nil]);
2467 if FResults.CheckStatementStatus(ssEOF) then
2468 IBError(ibxeEOF,[nil]);
2469 if (index < 0) or (index >= FResults.Count) then
2470 IBError(ibxeInvalidColumnIndex,[nil]);
2471
2472 Result := GetISQLData(FResults.Column[index]);
2473 end;
2474
2475 procedure TResults.GetData(index: integer; var IsNull: boolean; var len: short;
2476 var data: PByte);
2477 begin
2478 CheckActive;
2479 FResults.GetData(index,IsNull, len,data);
2480 end;
2481
2482 function TResults.GetTransaction: ITransaction;
2483 begin
2484 Result := FStatement.GetTransaction;
2485 end;
2486
2487 procedure TResults.SetRetainInterfaces(aValue: boolean);
2488 begin
2489 RetainInterfaces := aValue;
2490 end;
2491
2492 end.
2493