ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/FBSQLData.pas
Revision: 56
Committed: Mon Mar 6 10:20:02 2017 UTC (7 years, 8 months ago) by tony
Content type: text/x-pascal
File size: 67582 byte(s)
Log Message:
Committing updates for Trunk

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