ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/FBSQLData.pas
Revision: 47
Committed: Mon Jan 9 15:31:51 2017 UTC (7 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 66886 byte(s)
Log Message:
Committing updates for Release R2-0-1

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