ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/FBSQLData.pas
Revision: 45
Committed: Tue Dec 6 10:33:46 2016 UTC (7 years, 11 months ago) by tony
Content type: text/x-pascal
File size: 66100 byte(s)
Log Message:
Committing updates for Release R2-0-0

File Contents

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