ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/FBSQLData.pas
Revision: 59
Committed: Mon Mar 13 09:51:56 2017 UTC (7 years ago) by tony
Content type: text/x-pascal
File size: 68187 byte(s)
Log Message:

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