ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBSQL.pas
Revision: 33
Committed: Sat Jul 18 12:30:52 2015 UTC (8 years, 8 months ago) by tony
Content type: text/x-pascal
File size: 79099 byte(s)
Log Message:
Committing updates for Release R1-3-1

File Contents

# Content
1 {************************************************************************}
2 { }
3 { Borland Delphi Visual Component Library }
4 { InterBase Express core components }
5 { }
6 { Copyright (c) 1998-2000 Inprise Corporation }
7 { }
8 { InterBase Express is based in part on the product }
9 { Free IB Components, written by Gregory H. Deatz for }
10 { Hoagland, Longo, Moran, Dunst & Doukas Company. }
11 { Free IB Components is used under license. }
12 { }
13 { The contents of this file are subject to the InterBase }
14 { Public License Version 1.0 (the "License"); you may not }
15 { use this file except in compliance with the License. You }
16 { may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17 { Software distributed under the License is distributed on }
18 { an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
19 { express or implied. See the License for the specific language }
20 { governing rights and limitations under the License. }
21 { The Original Code was created by InterBase Software Corporation }
22 { and its successors. }
23 { Portions created by Inprise Corporation are Copyright (C) Inprise }
24 { Corporation. All Rights Reserved. }
25 { Contributor(s): Jeff Overcash }
26 { }
27 { IBX For Lazarus (Firebird Express) }
28 { Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29 { Portions created by MWA Software are copyright McCallum Whyman }
30 { Associates Ltd 2011 - 2014 }
31 { }
32 {************************************************************************}
33
34 unit IBSQL;
35
36 {$Mode Delphi}
37
38 { IBSQL param names in dialect 3 quoted format (e.g. :"MyParam") are by default disabled.
39
40 Dialect 3 quoted format parameter names represent a significant overhead and are of
41 limited value - especially for users that use only TIBSQL or TIBCustomDataset
42 descendents. They were previously used internally by IBX to simplify SQL generation
43 for TTable components in Master/Slave relationships which are linked by
44 Dialect 3 names. They were also generated by TStoredProc when the original
45 parameter names are quoted.
46
47 However, for some users they do cause a big processing overhead. The TTable/TStoredProc
48 code has been re-written so that they are no required by IBX internally.
49 The code to support quoted parameter names is now subject to conditional compilation.
50 To enable support, ALLOWDIALECT3PARAMNAMES should be defined when IBX is compiled.
51
52 Hint: deleting the space between the brace and the dollar sign below
53
54 }
55
56 { $define ALLOWDIALECT3PARAMNAMES}
57
58 {$ifndef ALLOWDIALECT3PARAMNAMES}
59
60 { Even when dialect 3 quoted format parameter names are not supported, IBX still processes
61 parameter names case insensitive. This does result in some additional overhead
62 due to a call to "AnsiUpperCase". This can be avoided by undefining
63 "UseCaseSensitiveParamName" below.
64
65 Note: do not define "UseCaseSensitiveParamName" when "ALLOWDIALECT3PARAMNAMES"
66 is defined. This will not give a useful result.
67 }
68 {$define UseCaseSensitiveParamName}
69 {$endif}
70
71 interface
72
73 uses
74 {$IFDEF WINDOWS }
75 Windows,
76 {$ELSE}
77 baseunix, unix,
78 {$ENDIF}
79 SysUtils, Classes, IBHeader,
80 IBErrorCodes, IBExternals, DB, IB, IBDatabase, IBUtils, IBXConst;
81
82 const
83 sSQLErrorSeparator = ' When Executing: ';
84
85 type
86 TIBSQL = class;
87 TIBXSQLDA = class;
88
89 { TIBXSQLVAR }
90 TIBXSQLVAR = class(TObject)
91 private
92 FParent: TIBXSQLDA;
93 FSQL: TIBSQL;
94 FIndex: Integer;
95 FModified: Boolean;
96 FName: String;
97 FUniqueName: boolean;
98 FXSQLVAR: PXSQLVAR; { Point to the PXSQLVAR in the owner object }
99
100 function AdjustScale(Value: Int64; Scale: Integer): Double;
101 function AdjustScaleToInt64(Value: Int64; Scale: Integer): Int64;
102 function AdjustScaleToCurrency(Value: Int64; Scale: Integer): Currency;
103 function GetAsBoolean: boolean;
104 function GetAsCurrency: Currency;
105 function GetAsInt64: Int64;
106 function GetAsDateTime: TDateTime;
107 function GetAsDouble: Double;
108 function GetAsFloat: Float;
109 function GetAsLong: Long;
110 function GetAsPointer: Pointer;
111 function GetAsQuad: TISC_QUAD;
112 function GetAsShort: Short;
113 function GetAsString: String;
114 function GetAsVariant: Variant;
115 function GetAsXSQLVAR: PXSQLVAR;
116 function GetIsNull: Boolean;
117 function GetIsNullable: Boolean;
118 function GetSize: Integer;
119 function GetSQLType: Integer;
120 procedure SetAsBoolean(AValue: boolean);
121 procedure SetAsCurrency(Value: Currency);
122 procedure SetAsInt64(Value: Int64);
123 procedure SetAsDate(Value: TDateTime);
124 procedure SetAsLong(Value: Long);
125 procedure SetAsTime(Value: TDateTime);
126 procedure SetAsDateTime(Value: TDateTime);
127 procedure SetAsDouble(Value: Double);
128 procedure SetAsFloat(Value: Float);
129 procedure SetAsPointer(Value: Pointer);
130 procedure SetAsQuad(Value: TISC_QUAD);
131 procedure SetAsShort(Value: Short);
132 procedure SetAsString(Value: String);
133 procedure SetAsVariant(Value: Variant);
134 procedure SetAsXSQLVAR(Value: PXSQLVAR);
135 procedure SetIsNull(Value: Boolean);
136 procedure SetIsNullable(Value: Boolean);
137 procedure xSetAsBoolean(AValue: boolean);
138 procedure xSetAsCurrency(Value: Currency);
139 procedure xSetAsInt64(Value: Int64);
140 procedure xSetAsDate(Value: TDateTime);
141 procedure xSetAsTime(Value: TDateTime);
142 procedure xSetAsDateTime(Value: TDateTime);
143 procedure xSetAsDouble(Value: Double);
144 procedure xSetAsFloat(Value: Float);
145 procedure xSetAsLong(Value: Long);
146 procedure xSetAsPointer(Value: Pointer);
147 procedure xSetAsQuad(Value: TISC_QUAD);
148 procedure xSetAsShort(Value: Short);
149 procedure xSetAsString(Value: String);
150 procedure xSetAsVariant(Value: Variant);
151 procedure xSetAsXSQLVAR(Value: PXSQLVAR);
152 procedure xSetIsNull(Value: Boolean);
153 procedure xSetIsNullable(Value: Boolean);
154 public
155 constructor Create(Parent: TIBXSQLDA; Query: TIBSQL);
156 procedure Assign(Source: TIBXSQLVAR);
157 procedure Clear;
158 procedure LoadFromFile(const FileName: String);
159 procedure LoadFromStream(Stream: TStream);
160 procedure SaveToFile(const FileName: String);
161 procedure SaveToStream(Stream: TStream);
162 property AsDate: TDateTime read GetAsDateTime write SetAsDate;
163 property AsBoolean:boolean read GetAsBoolean write SetAsBoolean;
164 property AsTime: TDateTime read GetAsDateTime write SetAsTime;
165 property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
166 property AsDouble: Double read GetAsDouble write SetAsDouble;
167 property AsFloat: Float read GetAsFloat write SetAsFloat;
168 property AsCurrency: Currency read GetAsCurrency write SetAsCurrency;
169 property AsInt64: Int64 read GetAsInt64 write SetAsInt64;
170 property AsInteger: Integer read GetAsLong write SetAsLong;
171 property AsLong: Long read GetAsLong write SetAsLong;
172 property AsPointer: Pointer read GetAsPointer write SetAsPointer;
173 property AsQuad: TISC_QUAD read GetAsQuad write SetAsQuad;
174 property AsShort: Short read GetAsShort write SetAsShort;
175 property AsString: String read GetAsString write SetAsString;
176 property AsVariant: Variant read GetAsVariant write SetAsVariant;
177 property AsXSQLVAR: PXSQLVAR read GetAsXSQLVAR write SetAsXSQLVAR;
178 property Data: PXSQLVAR read FXSQLVAR write FXSQLVAR;
179 property IsNull: Boolean read GetIsNull write SetIsNull;
180 property IsNullable: Boolean read GetIsNullable write SetIsNullable;
181 property Index: Integer read FIndex;
182 property Modified: Boolean read FModified write FModified;
183 property Name: String read FName;
184 property Size: Integer read GetSize;
185 property SQLType: Integer read GetSQLType;
186 property Value: Variant read GetAsVariant write SetAsVariant;
187 end;
188
189 TIBXSQLVARArray = Array of TIBXSQLVAR;
190
191 TIBXSQLDAType = (daInput,daOutput);
192
193 { TIBXSQLDA }
194
195 TIBXSQLDA = class(TObject)
196 protected
197 FSQL: TIBSQL;
198 FCount: Integer;
199 FSize: Integer;
200 FInputSQLDA: boolean;
201 FXSQLDA: PXSQLDA;
202 FXSQLVARs: TIBXSQLVARArray; { array of IBXQLVARs }
203 FUniqueRelationName: String;
204 function GetModified: Boolean;
205 function GetRecordSize: Integer;
206 function GetXSQLDA: PXSQLDA;
207 function GetXSQLVAR(Idx: Integer): TIBXSQLVAR;
208 function GetXSQLVARByName(Idx: String): TIBXSQLVAR;
209 procedure Initialize;
210 procedure SetCount(Value: Integer);
211 public
212 constructor Create(Query: TIBSQL; sqldaType: TIBXSQLDAType);
213 destructor Destroy; override;
214 procedure SetParamName(FieldName: String; Idx: Integer; UniqueName: boolean = false);
215 function ByName(Idx: String): TIBXSQLVAR;
216 property AsXSQLDA: PXSQLDA read GetXSQLDA;
217 property Count: Integer read FCount write SetCount;
218 property Modified: Boolean read GetModified;
219 property RecordSize: Integer read GetRecordSize;
220 property Vars[Idx: Integer]: TIBXSQLVAR read GetXSQLVAR; default;
221 property UniqueRelationName: String read FUniqueRelationName;
222 end;
223
224 { TIBBatch }
225
226 TIBBatch = class(TObject)
227 protected
228 FFilename: String;
229 FColumns: TIBXSQLDA;
230 FParams: TIBXSQLDA;
231 public
232 procedure ReadyFile; virtual; abstract;
233 property Columns: TIBXSQLDA read FColumns;
234 property Filename: String read FFilename write FFilename;
235 property Params: TIBXSQLDA read FParams;
236 end;
237
238 TIBBatchInput = class(TIBBatch)
239 public
240 function ReadParameters: Boolean; virtual; abstract;
241 end;
242
243 TIBBatchOutput = class(TIBBatch)
244 public
245 function WriteColumns: Boolean; virtual; abstract;
246 end;
247
248
249 { TIBOutputDelimitedFile }
250 TIBOutputDelimitedFile = class(TIBBatchOutput)
251 protected
252 {$IFDEF UNIX}
253 FHandle: cint;
254 {$ELSE}
255 FHandle: THandle;
256 {$ENDIF}
257 FOutputTitles: Boolean;
258 FColDelimiter,
259 FRowDelimiter: string;
260 public
261 destructor Destroy; override;
262 procedure ReadyFile; override;
263 function WriteColumns: Boolean; override;
264 property ColDelimiter: string read FColDelimiter write FColDelimiter;
265 property OutputTitles: Boolean read FOutputTitles
266 write FOutputTitles;
267 property RowDelimiter: string read FRowDelimiter write FRowDelimiter;
268 end;
269
270 { TIBInputDelimitedFile }
271 TIBInputDelimitedFile = class(TIBBatchInput)
272 protected
273 FColDelimiter,
274 FRowDelimiter: string;
275 FEOF: Boolean;
276 FFile: TFileStream;
277 FLookAhead: Char;
278 FReadBlanksAsNull: Boolean;
279 FSkipTitles: Boolean;
280 public
281 destructor Destroy; override;
282 function GetColumn(var Col: string): Integer;
283 function ReadParameters: Boolean; override;
284 procedure ReadyFile; override;
285 property ColDelimiter: string read FColDelimiter write FColDelimiter;
286 property ReadBlanksAsNull: Boolean read FReadBlanksAsNull
287 write FReadBlanksAsNull;
288 property RowDelimiter: string read FRowDelimiter write FRowDelimiter;
289 property SkipTitles: Boolean read FSkipTitles write FSkipTitles;
290 end;
291
292 { TIBOutputRawFile }
293 TIBOutputRawFile = class(TIBBatchOutput)
294 protected
295 {$IFDEF UNIX}
296 FHandle: cint;
297 {$ELSE}
298 FHandle: THandle;
299 {$ENDIF}
300 public
301 destructor Destroy; override;
302 procedure ReadyFile; override;
303 function WriteColumns: Boolean; override;
304 end;
305
306 { TIBInputRawFile }
307 TIBInputRawFile = class(TIBBatchInput)
308 protected
309 {$IFDEF UNIX}
310 FHandle: cint;
311 {$ELSE}
312 FHandle: THandle;
313 {$ENDIF}
314 public
315 destructor Destroy; override;
316 function ReadParameters: Boolean; override;
317 procedure ReadyFile; override;
318 end;
319
320 { TIBSQL }
321 TIBSQLTypes = (SQLUnknown, SQLSelect, SQLInsert,
322 SQLUpdate, SQLDelete, SQLDDL,
323 SQLGetSegment, SQLPutSegment,
324 SQLExecProcedure, SQLStartTransaction,
325 SQLCommit, SQLRollback,
326 SQLSelectForUpdate, SQLSetGenerator);
327
328 TIBSQL = class(TComponent)
329 private
330 FIBLoaded: Boolean;
331 FUniqueParamNames: Boolean;
332 function GetFieldCount: integer;
333 procedure SetUniqueParamNames(AValue: Boolean);
334 protected
335 FBase: TIBBase;
336 FBOF, { At BOF? }
337 FEOF, { At EOF? }
338 FGoToFirstRecordOnExecute, { Automatically position record on first record after executing }
339 FOpen, { Is a cursor open? }
340 FPrepared: Boolean; { Has the query been prepared? }
341 FRecordCount: Integer; { How many records have been read so far? }
342 FCursor: String; { Cursor name...}
343 FHandle: TISC_STMT_HANDLE; { Once prepared, this accesses the SQL Query }
344 FOnSQLChanging: TNotifyEvent; { Call this when the SQL is changing }
345 FSQL: TStrings; { SQL Query (by user) }
346 FParamCheck: Boolean; { Check for parameters? (just like TQuery) }
347 FProcessedSQL: TStrings; { SQL Query (pre-processed for param labels) }
348 FSQLParams, { Any parameters to the query }
349 FSQLRecord: TIBXSQLDA; { The current record }
350 FSQLType: TIBSQLTypes; { Select, update, delete, insert, create, alter, etc...}
351 FGenerateParamNames: Boolean; { Auto generate param names ?}
352 procedure DoBeforeDatabaseDisconnect(Sender: TObject);
353 function GetDatabase: TIBDatabase;
354 function GetDBHandle: PISC_DB_HANDLE;
355 function GetEOF: Boolean;
356 function GetFields(const Idx: Integer): TIBXSQLVAR;
357 function GetFieldIndex(FieldName: String): Integer;
358 function GetPlan: String;
359 function GetRecordCount: Integer;
360 function GetRowsAffected: Integer;
361 function GetSQLParams: TIBXSQLDA;
362 function GetTransaction: TIBTransaction;
363 function GetTRHandle: PISC_TR_HANDLE;
364 procedure PreprocessSQL;
365 procedure SetDatabase(Value: TIBDatabase);
366 procedure SetSQL(Value: TStrings);
367 procedure SetTransaction(Value: TIBTransaction);
368 procedure SQLChanging(Sender: TObject);
369 procedure BeforeTransactionEnd(Sender: TObject; Action: TTransactionAction);
370 public
371 constructor Create(AOwner: TComponent); override;
372 destructor Destroy; override;
373 procedure BatchInput(InputObject: TIBBatchInput);
374 procedure BatchOutput(OutputObject: TIBBatchOutput);
375 function Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
376 procedure CheckClosed; { raise error if query is not closed. }
377 procedure CheckOpen; { raise error if query is not open.}
378 procedure CheckValidStatement; { raise error if statement is invalid.}
379 procedure Close;
380 function Current: TIBXSQLDA;
381 procedure ExecQuery;
382 function FieldByName(FieldName: String): TIBXSQLVAR;
383 function ParamByName(ParamName: String): TIBXSQLVAR;
384 procedure FreeHandle;
385 function Next: TIBXSQLDA;
386 procedure Prepare;
387 function GetUniqueRelationName: String;
388 property Bof: Boolean read FBOF;
389 property DBHandle: PISC_DB_HANDLE read GetDBHandle;
390 property Eof: Boolean read GetEOF;
391 property Fields[const Idx: Integer]: TIBXSQLVAR read GetFields;
392 property FieldIndex[FieldName: String]: Integer read GetFieldIndex;
393 property FieldCount: integer read GetFieldCount;
394 property Open: Boolean read FOpen;
395 property Params: TIBXSQLDA read GetSQLParams;
396 property Plan: String read GetPlan;
397 property Prepared: Boolean read FPrepared;
398 property RecordCount: Integer read GetRecordCount;
399 property RowsAffected: Integer read GetRowsAffected;
400 property SQLType: TIBSQLTypes read FSQLType;
401 property TRHandle: PISC_TR_HANDLE read GetTRHandle;
402 property Handle: TISC_STMT_HANDLE read FHandle;
403 property UniqueRelationName: String read GetUniqueRelationName;
404 published
405 property Database: TIBDatabase read GetDatabase write SetDatabase;
406 property GenerateParamNames: Boolean read FGenerateParamNames write FGenerateParamNames;
407 property UniqueParamNames: Boolean read FUniqueParamNames write SetUniqueParamNames;
408 property GoToFirstRecordOnExecute: Boolean read FGoToFirstRecordOnExecute
409 write FGoToFirstRecordOnExecute
410 default True;
411 property ParamCheck: Boolean read FParamCheck write FParamCheck;
412 property SQL: TStrings read FSQL write SetSQL;
413 property Transaction: TIBTransaction read GetTransaction write SetTransaction;
414 property OnSQLChanging: TNotifyEvent read FOnSQLChanging write FOnSQLChanging;
415 end;
416
417 implementation
418
419 uses
420 IBIntf, IBBlob, Variants , IBSQLMonitor;
421
422 { TIBXSQLVAR }
423 constructor TIBXSQLVAR.Create(Parent: TIBXSQLDA; Query: TIBSQL);
424 begin
425 inherited Create;
426 FParent := Parent;
427 FSQL := Query;
428 end;
429
430 procedure TIBXSQLVAR.Assign(Source: TIBXSQLVAR);
431 var
432 szBuff: PChar;
433 s_bhandle, d_bhandle: TISC_BLOB_HANDLE;
434 bSourceBlob, bDestBlob: Boolean;
435 iSegs: Int64;
436 iMaxSeg: Int64;
437 iSize: Int64;
438 iBlobType: Short;
439 begin
440 szBuff := nil;
441 bSourceBlob := True;
442 bDestBlob := True;
443 s_bhandle := nil;
444 d_bhandle := nil;
445 try
446 if (Source.IsNull) then
447 begin
448 IsNull := True;
449 exit;
450 end
451 else
452 if (FXSQLVAR^.sqltype and (not 1) = SQL_ARRAY) or
453 (Source.FXSQLVAR^.sqltype and (not 1) = SQL_ARRAY) then
454 exit; { arrays not supported }
455 if (FXSQLVAR^.sqltype and (not 1) <> SQL_BLOB) and
456 (Source.FXSQLVAR^.sqltype and (not 1) <> SQL_BLOB) then
457 begin
458 AsXSQLVAR := Source.AsXSQLVAR;
459 exit;
460 end
461 else
462 if (Source.FXSQLVAR^.sqltype and (not 1) <> SQL_BLOB) then
463 begin
464 szBuff := nil;
465 IBAlloc(szBuff, 0, Source.FXSQLVAR^.sqllen);
466 Move(Source.FXSQLVAR^.sqldata[0], szBuff[0], Source.FXSQLVAR^.sqllen);
467 bSourceBlob := False;
468 iSize := Source.FXSQLVAR^.sqllen;
469 end
470 else
471 if (FXSQLVAR^.sqltype and (not 1) <> SQL_BLOB) then
472 bDestBlob := False;
473
474 if bSourceBlob then
475 begin
476 { read the blob }
477 Source.FSQL.Call(isc_open_blob2(StatusVector, Source.FSQL.DBHandle,
478 Source.FSQL.TRHandle, @s_bhandle, PISC_QUAD(Source.FXSQLVAR.sqldata),
479 0, nil), True);
480 try
481 IBBlob.GetBlobInfo(@s_bhandle, iSegs, iMaxSeg, iSize,
482 iBlobType);
483 szBuff := nil;
484 IBAlloc(szBuff, 0, iSize);
485 IBBlob.ReadBlob(@s_bhandle, szBuff, iSize);
486 finally
487 Source.FSQL.Call(isc_close_blob(StatusVector, @s_bhandle), True);
488 end;
489 end;
490
491 if bDestBlob then
492 begin
493 { write the blob }
494 FSQL.Call(isc_create_blob2(StatusVector, FSQL.DBHandle,
495 FSQL.TRHandle, @d_bhandle, PISC_QUAD(FXSQLVAR.sqldata),
496 0, nil), True);
497 try
498 IBBlob.WriteBlob(@d_bhandle, szBuff, iSize);
499 isNull := false
500 finally
501 FSQL.Call(isc_close_blob(StatusVector, @d_bhandle), True);
502 end;
503 end
504 else
505 begin
506 { just copy the buffer }
507 FXSQLVAR.sqltype := SQL_TEXT;
508 FXSQLVAR.sqllen := iSize;
509 IBAlloc(FXSQLVAR.sqldata, iSize, iSize);
510 Move(szBuff[0], FXSQLVAR^.sqldata[0], iSize);
511 end;
512 finally
513 FreeMem(szBuff);
514 end;
515 end;
516
517 function TIBXSQLVAR.AdjustScale(Value: Int64; Scale: Integer): Double;
518 var
519 Scaling : Int64;
520 i: Integer;
521 Val: Double;
522 begin
523 Scaling := 1; Val := Value;
524 if Scale > 0 then
525 begin
526 for i := 1 to Scale do
527 Scaling := Scaling * 10;
528 result := Val * Scaling;
529 end
530 else
531 if Scale < 0 then
532 begin
533 for i := -1 downto Scale do
534 Scaling := Scaling * 10;
535 result := Val / Scaling;
536 end
537 else
538 result := Val;
539 end;
540
541 function TIBXSQLVAR.AdjustScaleToInt64(Value: Int64; Scale: Integer): Int64;
542 var
543 Scaling : Int64;
544 i: Integer;
545 Val: Int64;
546 begin
547 Scaling := 1; Val := Value;
548 if Scale > 0 then begin
549 for i := 1 to Scale do Scaling := Scaling * 10;
550 result := Val * Scaling;
551 end else if Scale < 0 then begin
552 for i := -1 downto Scale do Scaling := Scaling * 10;
553 result := Val div Scaling;
554 end else
555 result := Val;
556 end;
557
558 function TIBXSQLVAR.AdjustScaleToCurrency(Value: Int64; Scale: Integer): Currency;
559 var
560 Scaling : Int64;
561 i : Integer;
562 FractionText, PadText, CurrText: string;
563 begin
564 Result := 0;
565 Scaling := 1;
566 if Scale > 0 then
567 begin
568 for i := 1 to Scale do
569 Scaling := Scaling * 10;
570 result := Value * Scaling;
571 end
572 else
573 if Scale < 0 then
574 begin
575 for i := -1 downto Scale do
576 Scaling := Scaling * 10;
577 FractionText := IntToStr(abs(Value mod Scaling));
578 for i := Length(FractionText) to -Scale -1 do
579 PadText := '0' + PadText;
580 if Value < 0 then
581 CurrText := '-' + IntToStr(Abs(Value div Scaling)) + DecimalSeparator + PadText + FractionText
582 else
583 CurrText := IntToStr(Abs(Value div Scaling)) + DecimalSeparator + PadText + FractionText;
584 try
585 result := StrToCurr(CurrText);
586 except
587 on E: Exception do
588 IBError(ibxeInvalidDataConversion, [nil]);
589 end;
590 end
591 else
592 result := Value;
593 end;
594
595 function TIBXSQLVAR.GetAsBoolean: boolean;
596 begin
597 result := false;
598 if not IsNull then
599 begin
600 if FXSQLVAR^.sqltype and (not 1) = SQL_BOOLEAN then
601 result := PByte(FXSQLVAR^.sqldata)^ = ISC_TRUE
602 else
603 IBError(ibxeInvalidDataConversion, [nil]);
604 end
605 end;
606
607 function TIBXSQLVAR.GetAsCurrency: Currency;
608 begin
609 result := 0;
610 if FSQL.Database.SQLDialect < 3 then
611 result := GetAsDouble
612 else begin
613 if not IsNull then
614 case FXSQLVAR^.sqltype and (not 1) of
615 SQL_TEXT, SQL_VARYING: begin
616 try
617 result := StrtoCurr(AsString);
618 except
619 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
620 end;
621 end;
622 SQL_SHORT:
623 result := AdjustScaleToCurrency(Int64(PShort(FXSQLVAR^.sqldata)^),
624 FXSQLVAR^.sqlscale);
625 SQL_LONG:
626 result := AdjustScaleToCurrency(Int64(PLong(FXSQLVAR^.sqldata)^),
627 FXSQLVAR^.sqlscale);
628 SQL_INT64:
629 result := AdjustScaleToCurrency(PInt64(FXSQLVAR^.sqldata)^,
630 FXSQLVAR^.sqlscale);
631 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
632 result := Trunc(AsDouble);
633 else
634 IBError(ibxeInvalidDataConversion, [nil]);
635 end;
636 end;
637 end;
638
639 function TIBXSQLVAR.GetAsInt64: Int64;
640 begin
641 result := 0;
642 if not IsNull then
643 case FXSQLVAR^.sqltype and (not 1) of
644 SQL_TEXT, SQL_VARYING: begin
645 try
646 result := StrToInt64(AsString);
647 except
648 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
649 end;
650 end;
651 SQL_SHORT:
652 result := AdjustScaleToInt64(Int64(PShort(FXSQLVAR^.sqldata)^),
653 FXSQLVAR^.sqlscale);
654 SQL_LONG:
655 result := AdjustScaleToInt64(Int64(PLong(FXSQLVAR^.sqldata)^),
656 FXSQLVAR^.sqlscale);
657 SQL_INT64:
658 result := AdjustScaleToInt64(PInt64(FXSQLVAR^.sqldata)^,
659 FXSQLVAR^.sqlscale);
660 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
661 result := Trunc(AsDouble);
662 else
663 IBError(ibxeInvalidDataConversion, [nil]);
664 end;
665 end;
666
667 function TIBXSQLVAR.GetAsDateTime: TDateTime;
668 var
669 tm_date: TCTimeStructure;
670 msecs: word;
671 begin
672 result := 0;
673 if not IsNull then
674 case FXSQLVAR^.sqltype and (not 1) of
675 SQL_TEXT, SQL_VARYING: begin
676 try
677 result := StrToDate(AsString);
678 except
679 on E: EConvertError do IBError(ibxeInvalidDataConversion, [nil]);
680 end;
681 end;
682 SQL_TYPE_DATE: begin
683 isc_decode_sql_date(PISC_DATE(FXSQLVAR^.sqldata), @tm_date);
684 try
685 result := EncodeDate(Word(tm_date.tm_year + 1900), Word(tm_date.tm_mon + 1),
686 Word(tm_date.tm_mday));
687 except
688 on E: EConvertError do begin
689 IBError(ibxeInvalidDataConversion, [nil]);
690 end;
691 end;
692 end;
693 SQL_TYPE_TIME: begin
694 isc_decode_sql_time(PISC_TIME(FXSQLVAR^.sqldata), @tm_date);
695 try
696 msecs := (PISC_TIME(FXSQLVAR^.sqldata)^ mod 10000) div 10;
697 result := EncodeTime(Word(tm_date.tm_hour), Word(tm_date.tm_min),
698 Word(tm_date.tm_sec), msecs)
699 except
700 on E: EConvertError do begin
701 IBError(ibxeInvalidDataConversion, [nil]);
702 end;
703 end;
704 end;
705 SQL_TIMESTAMP: begin
706 isc_decode_date(PISC_QUAD(FXSQLVAR^.sqldata), @tm_date);
707 try
708 result := EncodeDate(Word(tm_date.tm_year + 1900), Word(tm_date.tm_mon + 1),
709 Word(tm_date.tm_mday));
710 msecs := (PISC_TIMESTAMP(FXSQLVAR^.sqldata)^.timestamp_time mod 10000) div 10;
711 if result >= 0 then
712 result := result + EncodeTime(Word(tm_date.tm_hour), Word(tm_date.tm_min),
713 Word(tm_date.tm_sec), msecs)
714 else
715 result := result - EncodeTime(Word(tm_date.tm_hour), Word(tm_date.tm_min),
716 Word(tm_date.tm_sec), msecs)
717 except
718 on E: EConvertError do begin
719 IBError(ibxeInvalidDataConversion, [nil]);
720 end;
721 end;
722 end;
723 else
724 IBError(ibxeInvalidDataConversion, [nil]);
725 end;
726 end;
727
728 function TIBXSQLVAR.GetAsDouble: Double;
729 begin
730 result := 0;
731 if not IsNull then begin
732 case FXSQLVAR^.sqltype and (not 1) of
733 SQL_TEXT, SQL_VARYING: begin
734 try
735 result := StrToFloat(AsString);
736 except
737 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
738 end;
739 end;
740 SQL_SHORT:
741 result := AdjustScale(Int64(PShort(FXSQLVAR^.sqldata)^),
742 FXSQLVAR^.sqlscale);
743 SQL_LONG:
744 result := AdjustScale(Int64(PLong(FXSQLVAR^.sqldata)^),
745 FXSQLVAR^.sqlscale);
746 SQL_INT64:
747 result := AdjustScale(PInt64(FXSQLVAR^.sqldata)^, FXSQLVAR^.sqlscale);
748 SQL_FLOAT:
749 result := PFloat(FXSQLVAR^.sqldata)^;
750 SQL_DOUBLE, SQL_D_FLOAT:
751 result := PDouble(FXSQLVAR^.sqldata)^;
752 else
753 IBError(ibxeInvalidDataConversion, [nil]);
754 end;
755 if FXSQLVAR^.sqlscale <> 0 then
756 result :=
757 StrToFloat(FloatToStrF(result, fffixed, 15,
758 Abs(FXSQLVAR^.sqlscale) ));
759 end;
760 end;
761
762 function TIBXSQLVAR.GetAsFloat: Float;
763 begin
764 result := 0;
765 try
766 result := AsDouble;
767 except
768 on E: EOverflow do
769 IBError(ibxeInvalidDataConversion, [nil]);
770 end;
771 end;
772
773 function TIBXSQLVAR.GetAsLong: Long;
774 begin
775 result := 0;
776 if not IsNull then
777 case FXSQLVAR^.sqltype and (not 1) of
778 SQL_TEXT, SQL_VARYING: begin
779 try
780 result := StrToInt(AsString);
781 except
782 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
783 end;
784 end;
785 SQL_SHORT:
786 result := Trunc(AdjustScale(Int64(PShort(FXSQLVAR^.sqldata)^),
787 FXSQLVAR^.sqlscale));
788 SQL_LONG:
789 result := Trunc(AdjustScale(Int64(PLong(FXSQLVAR^.sqldata)^),
790 FXSQLVAR^.sqlscale));
791 SQL_INT64:
792 result := Trunc(AdjustScale(PInt64(FXSQLVAR^.sqldata)^, FXSQLVAR^.sqlscale));
793 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
794 result := Trunc(AsDouble);
795 else
796 IBError(ibxeInvalidDataConversion, [nil]);
797 end;
798 end;
799
800 function TIBXSQLVAR.GetAsPointer: Pointer;
801 begin
802 if not IsNull then
803 result := FXSQLVAR^.sqldata
804 else
805 result := nil;
806 end;
807
808 function TIBXSQLVAR.GetAsQuad: TISC_QUAD;
809 begin
810 result.gds_quad_high := 0;
811 result.gds_quad_low := 0;
812 if not IsNull then
813 case FXSQLVAR^.sqltype and (not 1) of
814 SQL_BLOB, SQL_ARRAY, SQL_QUAD:
815 result := PISC_QUAD(FXSQLVAR^.sqldata)^;
816 else
817 IBError(ibxeInvalidDataConversion, [nil]);
818 end;
819 end;
820
821 function TIBXSQLVAR.GetAsShort: Short;
822 begin
823 result := 0;
824 try
825 result := AsLong;
826 except
827 on E: Exception do IBError(ibxeInvalidDataConversion, [nil]);
828 end;
829 end;
830
831
832 function TIBXSQLVAR.GetAsString: String;
833 var
834 sz: PChar;
835 str_len: Integer;
836 ss: TStringStream;
837 begin
838 result := '';
839 { Check null, if so return a default string }
840 if not IsNull then
841 case FXSQLVar^.sqltype and (not 1) of
842 SQL_ARRAY:
843 result := '(Array)'; {do not localize}
844 SQL_BLOB: begin
845 ss := TStringStream.Create('');
846 try
847 SaveToStream(ss);
848 result := ss.DataString;
849 finally
850 ss.Free;
851 end;
852 end;
853 SQL_TEXT, SQL_VARYING: begin
854 sz := FXSQLVAR^.sqldata;
855 if (FXSQLVar^.sqltype and (not 1) = SQL_TEXT) then
856 str_len := FXSQLVar^.sqllen
857 else begin
858 str_len := isc_vax_integer(FXSQLVar^.sqldata, 2);
859 Inc(sz, 2);
860 end;
861 SetString(result, sz, str_len);
862 if ((FXSQLVar^.sqltype and (not 1)) = SQL_TEXT) then
863 result := TrimRight(result);
864 end;
865 SQL_TYPE_DATE:
866 case FSQL.Database.SQLDialect of
867 1 : result := DateTimeToStr(AsDateTime);
868 3 : result := DateToStr(AsDateTime);
869 end;
870 SQL_TYPE_TIME :
871 result := TimeToStr(AsDateTime);
872 SQL_TIMESTAMP:
873 result := DateTimeToStr(AsDateTime);
874 SQL_SHORT, SQL_LONG:
875 if FXSQLVAR^.sqlscale = 0 then
876 result := IntToStr(AsLong)
877 else if FXSQLVAR^.sqlscale >= (-4) then
878 result := CurrToStr(AsCurrency)
879 else
880 result := FloatToStr(AsDouble);
881 SQL_INT64:
882 if FXSQLVAR^.sqlscale = 0 then
883 result := IntToStr(AsInt64)
884 else if FXSQLVAR^.sqlscale >= (-4) then
885 result := CurrToStr(AsCurrency)
886 else
887 result := FloatToStr(AsDouble);
888 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
889 result := FloatToStr(AsDouble);
890 else
891 IBError(ibxeInvalidDataConversion, [nil]);
892 end;
893 end;
894
895 function TIBXSQLVAR.GetAsVariant: Variant;
896 begin
897 if IsNull then
898 result := NULL
899 { Check null, if so return a default string }
900 else case FXSQLVar^.sqltype and (not 1) of
901 SQL_ARRAY:
902 result := '(Array)'; {do not localize}
903 SQL_BLOB:
904 result := '(Blob)'; {do not localize}
905 SQL_TEXT, SQL_VARYING:
906 result := AsString;
907 SQL_TIMESTAMP, SQL_TYPE_DATE, SQL_TYPE_TIME:
908 result := AsDateTime;
909 SQL_SHORT, SQL_LONG:
910 if FXSQLVAR^.sqlscale = 0 then
911 result := AsLong
912 else if FXSQLVAR^.sqlscale >= (-4) then
913 result := AsCurrency
914 else
915 result := AsDouble;
916 SQL_INT64:
917 if FXSQLVAR^.sqlscale = 0 then
918 result := AsInt64
919 else if FXSQLVAR^.sqlscale >= (-4) then
920 result := AsCurrency
921 else
922 result := AsDouble;
923 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
924 result := AsDouble;
925 SQL_BOOLEAN:
926 result := AsBoolean;
927 else
928 IBError(ibxeInvalidDataConversion, [nil]);
929 end;
930 end;
931
932 function TIBXSQLVAR.GetAsXSQLVAR: PXSQLVAR;
933 begin
934 result := FXSQLVAR;
935 end;
936
937 function TIBXSQLVAR.GetIsNull: Boolean;
938 begin
939 result := IsNullable and (FXSQLVAR^.sqlind^ = -1);
940 end;
941
942 function TIBXSQLVAR.GetIsNullable: Boolean;
943 begin
944 result := (FXSQLVAR^.sqltype and 1 = 1);
945 end;
946
947 procedure TIBXSQLVAR.LoadFromFile(const FileName: String);
948 var
949 fs: TFileStream;
950 begin
951 fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
952 try
953 LoadFromStream(fs);
954 finally
955 fs.Free;
956 end;
957 end;
958
959 procedure TIBXSQLVAR.LoadFromStream(Stream: TStream);
960 var
961 bs: TIBBlobStream;
962 begin
963 bs := TIBBlobStream.Create;
964 try
965 bs.Mode := bmWrite;
966 bs.Database := FSQL.Database;
967 bs.Transaction := FSQL.Transaction;
968 Stream.Seek(0, soFromBeginning);
969 bs.LoadFromStream(Stream);
970 bs.Finalize;
971 AsQuad := bs.BlobID;
972 finally
973 bs.Free;
974 end;
975 end;
976
977 procedure TIBXSQLVAR.SaveToFile(const FileName: String);
978 var
979 fs: TFileStream;
980 begin
981 fs := TFileStream.Create(FileName, fmCreate or fmShareExclusive);
982 try
983 SaveToStream(fs);
984 finally
985 fs.Free;
986 end;
987 end;
988
989 procedure TIBXSQLVAR.SaveToStream(Stream: TStream);
990 var
991 bs: TIBBlobStream;
992 begin
993 bs := TIBBlobStream.Create;
994 try
995 bs.Mode := bmRead;
996 bs.Database := FSQL.Database;
997 bs.Transaction := FSQL.Transaction;
998 bs.BlobID := AsQuad;
999 bs.SaveToStream(Stream);
1000 finally
1001 bs.Free;
1002 end;
1003 end;
1004
1005 function TIBXSQLVAR.GetSize: Integer;
1006 begin
1007 result := FXSQLVAR^.sqllen;
1008 end;
1009
1010 function TIBXSQLVAR.GetSQLType: Integer;
1011 begin
1012 result := FXSQLVAR^.sqltype and (not 1);
1013 end;
1014
1015 procedure TIBXSQLVAR.SetAsBoolean(AValue: boolean);
1016 var
1017 i: Integer;
1018 begin
1019 if FUniqueName then
1020 xSetAsBoolean(AValue)
1021 else
1022 for i := 0 to FParent.FCount - 1 do
1023 if FParent[i].FName = FName then
1024 FParent[i].xSetAsBoolean(AValue);
1025 end;
1026
1027 procedure TIBXSQLVAR.xSetAsCurrency(Value: Currency);
1028 begin
1029 if IsNullable then
1030 IsNull := False;
1031 FXSQLVAR^.sqltype := SQL_INT64 or (FXSQLVAR^.sqltype and 1);
1032 FXSQLVAR^.sqlscale := -4;
1033 FXSQLVAR^.sqllen := SizeOf(Int64);
1034 IBAlloc(FXSQLVAR^.sqldata, 0, FXSQLVAR^.sqllen);
1035 PCurrency(FXSQLVAR^.sqldata)^ := Value;
1036 FModified := True;
1037 end;
1038
1039 procedure TIBXSQLVAR.SetAsCurrency(Value: Currency);
1040 var
1041 i: Integer;
1042 begin
1043 if FSQL.Database.SQLDialect < 3 then
1044 AsDouble := Value
1045 else
1046 begin
1047
1048 if FUniqueName then
1049 xSetAsCurrency(Value)
1050 else
1051 for i := 0 to FParent.FCount - 1 do
1052 if FParent[i].FName = FName then
1053 FParent[i].xSetAsCurrency(Value);
1054 end;
1055 end;
1056
1057 procedure TIBXSQLVAR.xSetAsInt64(Value: Int64);
1058 begin
1059 if IsNullable then
1060 IsNull := False;
1061
1062 FXSQLVAR^.sqltype := SQL_INT64 or (FXSQLVAR^.sqltype and 1);
1063 FXSQLVAR^.sqlscale := 0;
1064 FXSQLVAR^.sqllen := SizeOf(Int64);
1065 IBAlloc(FXSQLVAR^.sqldata, 0, FXSQLVAR^.sqllen);
1066 PInt64(FXSQLVAR^.sqldata)^ := Value;
1067 FModified := True;
1068 end;
1069
1070 procedure TIBXSQLVAR.SetAsInt64(Value: Int64);
1071 var
1072 i: Integer;
1073 begin
1074 if FUniqueName then
1075 xSetAsInt64(Value)
1076 else
1077 for i := 0 to FParent.FCount - 1 do
1078 if FParent[i].FName = FName then
1079 FParent[i].xSetAsInt64(Value);
1080 end;
1081
1082 procedure TIBXSQLVAR.xSetAsDate(Value: TDateTime);
1083 var
1084 tm_date: TCTimeStructure;
1085 Yr, Mn, Dy: Word;
1086 begin
1087 if IsNullable then
1088 IsNull := False;
1089
1090 FXSQLVAR^.sqltype := SQL_TYPE_DATE or (FXSQLVAR^.sqltype and 1);
1091 DecodeDate(Value, Yr, Mn, Dy);
1092 with tm_date do begin
1093 tm_sec := 0;
1094 tm_min := 0;
1095 tm_hour := 0;
1096 tm_mday := Dy;
1097 tm_mon := Mn - 1;
1098 tm_year := Yr - 1900;
1099 end;
1100 FXSQLVAR^.sqllen := SizeOf(ISC_DATE);
1101 IBAlloc(FXSQLVAR^.sqldata, 0, FXSQLVAR^.sqllen);
1102 isc_encode_sql_date(@tm_date, PISC_DATE(FXSQLVAR^.sqldata));
1103 FModified := True;
1104 end;
1105
1106 procedure TIBXSQLVAR.SetAsDate(Value: TDateTime);
1107 var
1108 i: Integer;
1109 begin
1110 if FSQL.Database.SQLDialect < 3 then
1111 begin
1112 AsDateTime := Value;
1113 exit;
1114 end;
1115
1116 if FUniqueName then
1117 xSetAsDate(Value)
1118 else
1119 for i := 0 to FParent.FCount - 1 do
1120 if FParent[i].FName = FName then
1121 FParent[i].xSetAsDate(Value);
1122 end;
1123
1124 procedure TIBXSQLVAR.xSetAsTime(Value: TDateTime);
1125 var
1126 tm_date: TCTimeStructure;
1127 Hr, Mt, S, Ms: Word;
1128 begin
1129 if IsNullable then
1130 IsNull := False;
1131
1132 FXSQLVAR^.sqltype := SQL_TYPE_TIME or (FXSQLVAR^.sqltype and 1);
1133 DecodeTime(Value, Hr, Mt, S, Ms);
1134 with tm_date do begin
1135 tm_sec := S;
1136 tm_min := Mt;
1137 tm_hour := Hr;
1138 tm_mday := 0;
1139 tm_mon := 0;
1140 tm_year := 0;
1141 end;
1142 FXSQLVAR^.sqllen := SizeOf(ISC_TIME);
1143 IBAlloc(FXSQLVAR^.sqldata, 0, FXSQLVAR^.sqllen);
1144 isc_encode_sql_time(@tm_date, PISC_TIME(FXSQLVAR^.sqldata));
1145 if Ms > 0 then
1146 Inc(PISC_TIME(FXSQLVAR^.sqldata)^,Ms*10);
1147 FModified := True;
1148 end;
1149
1150 procedure TIBXSQLVAR.SetAsTime(Value: TDateTime);
1151 var
1152 i: Integer;
1153 begin
1154 if FSQL.Database.SQLDialect < 3 then
1155 begin
1156 AsDateTime := Value;
1157 exit;
1158 end;
1159
1160 if FUniqueName then
1161 xSetAsTime(Value)
1162 else
1163 for i := 0 to FParent.FCount - 1 do
1164 if FParent[i].FName = FName then
1165 FParent[i].xSetAsTime(Value);
1166 end;
1167
1168 procedure TIBXSQLVAR.xSetAsDateTime(Value: TDateTime);
1169 var
1170 tm_date: TCTimeStructure;
1171 Yr, Mn, Dy, Hr, Mt, S, Ms: Word;
1172 begin
1173 if IsNullable then
1174 IsNull := False;
1175
1176 FXSQLVAR^.sqltype := SQL_TIMESTAMP or (FXSQLVAR^.sqltype and 1);
1177 DecodeDate(Value, Yr, Mn, Dy);
1178 DecodeTime(Value, Hr, Mt, S, Ms);
1179 with tm_date do begin
1180 tm_sec := S;
1181 tm_min := Mt;
1182 tm_hour := Hr;
1183 tm_mday := Dy;
1184 tm_mon := Mn - 1;
1185 tm_year := Yr - 1900;
1186 end;
1187 FXSQLVAR^.sqllen := SizeOf(TISC_QUAD);
1188 IBAlloc(FXSQLVAR^.sqldata, 0, FXSQLVAR^.sqllen);
1189 isc_encode_date(@tm_date, PISC_QUAD(FXSQLVAR^.sqldata));
1190 if Ms > 0 then
1191 Inc(PISC_TIMESTAMP(FXSQLVAR^.sqldata)^.timestamp_time,Ms*10);
1192 FModified := True;
1193 end;
1194
1195 procedure TIBXSQLVAR.SetAsDateTime(Value: TDateTime);
1196 var
1197 i: Integer;
1198 begin
1199 if FUniqueName then
1200 xSetAsDateTime(value)
1201 else
1202 for i := 0 to FParent.FCount - 1 do
1203 if FParent[i].FName = FName then
1204 FParent[i].xSetAsDateTime(Value);
1205 end;
1206
1207 procedure TIBXSQLVAR.xSetAsDouble(Value: Double);
1208 begin
1209 if IsNullable then
1210 IsNull := False;
1211
1212 FXSQLVAR^.sqltype := SQL_DOUBLE or (FXSQLVAR^.sqltype and 1);
1213 FXSQLVAR^.sqllen := SizeOf(Double);
1214 FXSQLVAR^.sqlscale := 0;
1215 IBAlloc(FXSQLVAR^.sqldata, 0, FXSQLVAR^.sqllen);
1216 PDouble(FXSQLVAR^.sqldata)^ := Value;
1217 FModified := True;
1218 end;
1219
1220 procedure TIBXSQLVAR.SetAsDouble(Value: Double);
1221 var
1222 i: Integer;
1223 begin
1224 if FUniqueName then
1225 xSetAsDouble(Value)
1226 else
1227 for i := 0 to FParent.FCount - 1 do
1228 if FParent[i].FName = FName then
1229 FParent[i].xSetAsDouble(Value);
1230 end;
1231
1232 procedure TIBXSQLVAR.xSetAsFloat(Value: Float);
1233 begin
1234 if IsNullable then
1235 IsNull := False;
1236
1237 FXSQLVAR^.sqltype := SQL_FLOAT or (FXSQLVAR^.sqltype and 1);
1238 FXSQLVAR^.sqllen := SizeOf(Float);
1239 FXSQLVAR^.sqlscale := 0;
1240 IBAlloc(FXSQLVAR^.sqldata, 0, FXSQLVAR^.sqllen);
1241 PSingle(FXSQLVAR^.sqldata)^ := Value;
1242 FModified := True;
1243 end;
1244
1245 procedure TIBXSQLVAR.SetAsFloat(Value: Float);
1246 var
1247 i: Integer;
1248 begin
1249 if FUniqueName then
1250 xSetAsFloat(Value)
1251 else
1252 for i := 0 to FParent.FCount - 1 do
1253 if FParent[i].FName = FName then
1254 FParent[i].xSetAsFloat(Value);
1255 end;
1256
1257 procedure TIBXSQLVAR.xSetAsLong(Value: Long);
1258 begin
1259 if IsNullable then
1260 IsNull := False;
1261
1262 FXSQLVAR^.sqltype := SQL_LONG or (FXSQLVAR^.sqltype and 1);
1263 FXSQLVAR^.sqllen := SizeOf(Long);
1264 FXSQLVAR^.sqlscale := 0;
1265 IBAlloc(FXSQLVAR^.sqldata, 0, FXSQLVAR^.sqllen);
1266 PLong(FXSQLVAR^.sqldata)^ := Value;
1267 FModified := True;
1268 end;
1269
1270 procedure TIBXSQLVAR.SetAsLong(Value: Long);
1271 var
1272 i: Integer;
1273 begin
1274 if FUniqueName then
1275 xSetAsLong(Value)
1276 else
1277 for i := 0 to FParent.FCount - 1 do
1278 if FParent[i].FName = FName then
1279 FParent[i].xSetAsLong(Value);
1280 end;
1281
1282 procedure TIBXSQLVAR.xSetAsPointer(Value: Pointer);
1283 begin
1284 if IsNullable and (Value = nil) then
1285 IsNull := True
1286 else begin
1287 IsNull := False;
1288 FXSQLVAR^.sqltype := SQL_TEXT or (FXSQLVAR^.sqltype and 1);
1289 Move(Value^, FXSQLVAR^.sqldata^, FXSQLVAR^.sqllen);
1290 end;
1291 FModified := True;
1292 end;
1293
1294 procedure TIBXSQLVAR.SetAsPointer(Value: Pointer);
1295 var
1296 i: Integer;
1297 begin
1298 if FUniqueName then
1299 xSetAsPointer(Value)
1300 else
1301 for i := 0 to FParent.FCount - 1 do
1302 if FParent[i].FName = FName then
1303 FParent[i].xSetAsPointer(Value);
1304 end;
1305
1306 procedure TIBXSQLVAR.xSetAsQuad(Value: TISC_QUAD);
1307 begin
1308 if IsNullable then
1309 IsNull := False;
1310 if (FXSQLVAR^.sqltype and (not 1) <> SQL_BLOB) and
1311 (FXSQLVAR^.sqltype and (not 1) <> SQL_ARRAY) then
1312 IBError(ibxeInvalidDataConversion, [nil]);
1313 FXSQLVAR^.sqllen := SizeOf(TISC_QUAD);
1314 IBAlloc(FXSQLVAR^.sqldata, 0, FXSQLVAR^.sqllen);
1315 PISC_QUAD(FXSQLVAR^.sqldata)^ := Value;
1316 FModified := True;
1317 end;
1318
1319 procedure TIBXSQLVAR.SetAsQuad(Value: TISC_QUAD);
1320 var
1321 i: Integer;
1322 begin
1323 if FUniqueName then
1324 xSetAsQuad(Value)
1325 else
1326 for i := 0 to FParent.FCount - 1 do
1327 if FParent[i].FName = FName then
1328 FParent[i].xSetAsQuad(Value);
1329 end;
1330
1331 procedure TIBXSQLVAR.xSetAsShort(Value: Short);
1332 begin
1333 if IsNullable then
1334 IsNull := False;
1335
1336 FXSQLVAR^.sqltype := SQL_SHORT or (FXSQLVAR^.sqltype and 1);
1337 FXSQLVAR^.sqllen := SizeOf(Short);
1338 FXSQLVAR^.sqlscale := 0;
1339 IBAlloc(FXSQLVAR^.sqldata, 0, FXSQLVAR^.sqllen);
1340 PShort(FXSQLVAR^.sqldata)^ := Value;
1341 FModified := True;
1342 end;
1343
1344 procedure TIBXSQLVAR.SetAsShort(Value: Short);
1345 var
1346 i: Integer;
1347 begin
1348 if FUniqueName then
1349 xSetAsShort(Value)
1350 else
1351 for i := 0 to FParent.FCount - 1 do
1352 if FParent[i].FName = FName then
1353 FParent[i].xSetAsShort(Value);
1354 end;
1355
1356 procedure TIBXSQLVAR.xSetAsString(Value: String);
1357 var
1358 stype: Integer;
1359 ss: TStringStream;
1360
1361 procedure SetStringValue;
1362 var
1363 i: Integer;
1364 begin
1365 if (FXSQLVAR^.sqlname = 'DB_KEY') or {do not localize}
1366 (FXSQLVAR^.sqlname = 'RDB$DB_KEY') then {do not localize}
1367 Move(Value[1], FXSQLVAR^.sqldata^, FXSQLVAR^.sqllen)
1368 else begin
1369 FXSQLVAR^.sqltype := SQL_TEXT or (FXSQLVAR^.sqltype and 1);
1370 FXSQLVAR^.sqllen := Length(Value);
1371 IBAlloc(FXSQLVAR^.sqldata, 0, FXSQLVAR^.sqllen + 1);
1372 if (Length(Value) > 0) then
1373 Move(Value[1], FXSQLVAR^.sqldata^, FXSQLVAR^.sqllen);
1374 end;
1375 FModified := True;
1376 end;
1377
1378 begin
1379 if IsNullable then
1380 IsNull := False;
1381
1382 stype := FXSQLVAR^.sqltype and (not 1);
1383 if (stype = SQL_TEXT) or (stype = SQL_VARYING) then
1384 SetStringValue
1385 else begin
1386 if (stype = SQL_BLOB) then
1387 begin
1388 ss := TStringStream.Create(Value);
1389 try
1390 LoadFromStream(ss);
1391 finally
1392 ss.Free;
1393 end;
1394 end
1395 else if Value = '' then
1396 IsNull := True
1397 else if (stype = SQL_TIMESTAMP) or (stype = SQL_TYPE_DATE) or
1398 (stype = SQL_TYPE_TIME) then
1399 xSetAsDateTime(StrToDateTime(Value))
1400 else
1401 SetStringValue;
1402 end;
1403 end;
1404
1405 procedure TIBXSQLVAR.SetAsString(Value: String);
1406 var
1407 i: integer;
1408 begin
1409 if FUniqueName then
1410 xSetAsString(Value)
1411 else
1412 for i := 0 to FParent.FCount - 1 do
1413 if FParent[i].FName = FName then
1414 FParent[i].xSetAsString(Value);
1415 end;
1416
1417 procedure TIBXSQLVAR.xSetAsVariant(Value: Variant);
1418 begin
1419 if VarIsNull(Value) then
1420 IsNull := True
1421 else case VarType(Value) of
1422 varEmpty, varNull:
1423 IsNull := True;
1424 varSmallint, varInteger, varByte,
1425 varWord, varShortInt:
1426 AsLong := Value;
1427 varInt64:
1428 AsInt64 := Value;
1429 varSingle, varDouble:
1430 AsDouble := Value;
1431 varCurrency:
1432 AsCurrency := Value;
1433 varBoolean:
1434 AsBoolean := Value;
1435 varDate:
1436 AsDateTime := Value;
1437 varOleStr, varString:
1438 AsString := Value;
1439 varArray:
1440 IBError(ibxeNotSupported, [nil]);
1441 varByRef, varDispatch, varError, varUnknown, varVariant:
1442 IBError(ibxeNotPermitted, [nil]);
1443 end;
1444 end;
1445
1446 procedure TIBXSQLVAR.SetAsVariant(Value: Variant);
1447 var
1448 i: integer;
1449 begin
1450 if FUniqueName then
1451 xSetAsVariant(Value)
1452 else
1453 for i := 0 to FParent.FCount - 1 do
1454 if FParent[i].FName = FName then
1455 FParent[i].xSetAsVariant(Value);
1456 end;
1457
1458 procedure TIBXSQLVAR.xSetAsXSQLVAR(Value: PXSQLVAR);
1459 var
1460 sqlind: PShort;
1461 sqldata: PChar;
1462 local_sqllen: Integer;
1463 begin
1464 sqlind := FXSQLVAR^.sqlind;
1465 sqldata := FXSQLVAR^.sqldata;
1466 Move(Value^, FXSQLVAR^, SizeOf(TXSQLVAR));
1467 FXSQLVAR^.sqlind := sqlind;
1468 FXSQLVAR^.sqldata := sqldata;
1469 if (Value^.sqltype and 1 = 1) then
1470 begin
1471 if (FXSQLVAR^.sqlind = nil) then
1472 IBAlloc(FXSQLVAR^.sqlind, 0, SizeOf(Short));
1473 FXSQLVAR^.sqlind^ := Value^.sqlind^;
1474 end
1475 else
1476 if (FXSQLVAR^.sqlind <> nil) then
1477 ReallocMem(FXSQLVAR^.sqlind, 0);
1478 if ((FXSQLVAR^.sqltype and (not 1)) = SQL_VARYING) then
1479 local_sqllen := FXSQLVAR^.sqllen + 2
1480 else
1481 local_sqllen := FXSQLVAR^.sqllen;
1482 FXSQLVAR^.sqlscale := Value^.sqlscale;
1483 IBAlloc(FXSQLVAR^.sqldata, 0, local_sqllen);
1484 Move(Value^.sqldata[0], FXSQLVAR^.sqldata[0], local_sqllen);
1485 FModified := True;
1486 end;
1487
1488 procedure TIBXSQLVAR.SetAsXSQLVAR(Value: PXSQLVAR);
1489 var
1490 i: Integer;
1491 begin
1492 if FUniqueName then
1493 xSetAsXSQLVAR(Value)
1494 else
1495 for i := 0 to FParent.FCount - 1 do
1496 if FParent[i].FName = FName then
1497 FParent[i].xSetAsXSQLVAR(Value);
1498 end;
1499
1500 procedure TIBXSQLVAR.xSetIsNull(Value: Boolean);
1501 begin
1502 if Value then
1503 begin
1504 if not IsNullable then
1505 IsNullable := True;
1506
1507 if Assigned(FXSQLVAR^.sqlind) then
1508 FXSQLVAR^.sqlind^ := -1;
1509 FModified := True;
1510 end
1511 else
1512 if ((not Value) and IsNullable) then
1513 begin
1514 if Assigned(FXSQLVAR^.sqlind) then
1515 FXSQLVAR^.sqlind^ := 0;
1516 FModified := True;
1517 end;
1518 end;
1519
1520 procedure TIBXSQLVAR.SetIsNull(Value: Boolean);
1521 var
1522 i: Integer;
1523 begin
1524 if FUniqueName then
1525 xSetIsNull(Value)
1526 else
1527 for i := 0 to FParent.FCount - 1 do
1528 if FParent[i].FName = FName then
1529 FParent[i].xSetIsNull(Value);
1530 end;
1531
1532 procedure TIBXSQLVAR.xSetIsNullable(Value: Boolean);
1533 begin
1534 if (Value <> IsNullable) then
1535 begin
1536 if Value then
1537 begin
1538 FXSQLVAR^.sqltype := FXSQLVAR^.sqltype or 1;
1539 IBAlloc(FXSQLVAR^.sqlind, 0, SizeOf(Short));
1540 end
1541 else
1542 begin
1543 FXSQLVAR^.sqltype := FXSQLVAR^.sqltype and (not 1);
1544 ReallocMem(FXSQLVAR^.sqlind, 0);
1545 end;
1546 end;
1547 end;
1548
1549 procedure TIBXSQLVAR.SetIsNullable(Value: Boolean);
1550 var
1551 i: Integer;
1552 begin
1553 if FUniqueName then
1554 xSetIsNullable(Value)
1555 else
1556 for i := 0 to FParent.FCount - 1 do
1557 if FParent[i].FName = FName then
1558 FParent[i].xSetIsNullable(Value);
1559 end;
1560
1561 procedure TIBXSQLVAR.xSetAsBoolean(AValue: boolean);
1562 begin
1563 if IsNullable then
1564 IsNull := False;
1565
1566 FXSQLVAR^.sqltype := SQL_BOOLEAN;
1567 FXSQLVAR^.sqllen := 1;
1568 FXSQLVAR^.sqlscale := 0;
1569 IBAlloc(FXSQLVAR^.sqldata, 0, FXSQLVAR^.sqllen);
1570 if AValue then
1571 PByte(FXSQLVAR^.sqldata)^ := ISC_TRUE
1572 else
1573 PByte(FXSQLVAR^.sqldata)^ := ISC_FALSE;
1574 FModified := True;
1575 end;
1576
1577 procedure TIBXSQLVAR.Clear;
1578 begin
1579 IsNull := true;
1580 end;
1581
1582
1583 { TIBXSQLDA }
1584 constructor TIBXSQLDA.Create(Query: TIBSQL; sqldaType: TIBXSQLDAType);
1585 begin
1586 inherited Create;
1587 FSQL := Query;
1588 FSize := 0;
1589 FUniqueRelationName := '';
1590 FInputSQLDA := sqldaType = daInput;
1591 end;
1592
1593 destructor TIBXSQLDA.Destroy;
1594 var
1595 i: Integer;
1596 begin
1597 if FXSQLDA <> nil then
1598 begin
1599 for i := 0 to FSize - 1 do
1600 begin
1601 FreeMem(FXSQLVARs[i].FXSQLVAR^.sqldata);
1602 FreeMem(FXSQLVARs[i].FXSQLVAR^.sqlind);
1603 FXSQLVARs[i].Free ;
1604 end;
1605 FreeMem(FXSQLDA);
1606 FXSQLDA := nil;
1607 FXSQLVARs := nil;
1608 end;
1609 inherited Destroy;
1610 end;
1611
1612 procedure TIBXSQLDA.SetParamName(FieldName: String; Idx: Integer;
1613 UniqueName: boolean);
1614 var
1615 fn: string;
1616 begin
1617 {$ifdef UseCaseSensitiveParamName}
1618 FXSQLVARs[Idx].FName := AnsiUpperCase(FieldName);
1619 {$else}
1620 FXSQLVARs[Idx].FName := FieldName;
1621 {$endif}
1622 FXSQLVARs[Idx].FIndex := Idx;
1623 FXSQLVARs[Idx].FUniqueName := UniqueName
1624 end;
1625
1626 function TIBXSQLDA.GetModified: Boolean;
1627 var
1628 i: Integer;
1629 begin
1630 result := False;
1631 for i := 0 to FCount - 1 do
1632 if FXSQLVARs[i].Modified then
1633 begin
1634 result := True;
1635 exit;
1636 end;
1637 end;
1638
1639 function TIBXSQLDA.GetRecordSize: Integer;
1640 begin
1641 result := SizeOf(TIBXSQLDA) + XSQLDA_LENGTH(FSize);
1642 end;
1643
1644 function TIBXSQLDA.GetXSQLDA: PXSQLDA;
1645 begin
1646 result := FXSQLDA;
1647 end;
1648
1649 function TIBXSQLDA.GetXSQLVAR(Idx: Integer): TIBXSQLVAR;
1650 begin
1651 if (Idx < 0) or (Idx >= FCount) then
1652 IBError(ibxeXSQLDAIndexOutOfRange, [nil]);
1653 result := FXSQLVARs[Idx]
1654 end;
1655
1656 function TIBXSQLDA.ByName(Idx: String): TIBXSQLVAR;
1657 begin
1658 result := GetXSQLVARByName(Idx);
1659 if result = nil then
1660 IBError(ibxeFieldNotFound, [Idx]);
1661 end;
1662
1663 function TIBXSQLDA.GetXSQLVARByName(Idx: String): TIBXSQLVAR;
1664 var
1665 s: String;
1666 i: Integer;
1667 begin
1668 {$ifdef ALLOWDIALECT3PARAMNAMES}
1669 s := FormatIdentifierValueNC(FSQL.Database.SQLDialect, Idx);
1670 {$else}
1671 {$ifdef UseCaseSensitiveParamName}
1672 s := AnsiUpperCase(Idx);
1673 {$else}
1674 s := Idx;
1675 {$endif}
1676 {$endif}
1677 for i := 0 to FCount - 1 do
1678 if Vars[i].FName = s then
1679 begin
1680 Result := FXSQLVARs[i];
1681 Exit;
1682 end;
1683 Result := nil;
1684 end;
1685
1686 procedure TIBXSQLDA.Initialize;
1687
1688 function VarByName(idx: string; limit: integer): TIBXSQLVAR;
1689 var
1690 k: integer;
1691 begin
1692 for k := 0 to limit do
1693 if FXSQLVARs[k].FName = idx then
1694 begin
1695 Result := FXSQLVARs[k];
1696 Exit;
1697 end;
1698 Result := nil;
1699 end;
1700
1701 var
1702 i, j, j_len: Integer;
1703 st: String;
1704 bUnique: Boolean;
1705 sBaseName: string;
1706 begin
1707 bUnique := True;
1708 if FXSQLDA <> nil then
1709 begin
1710 for i := 0 to FCount - 1 do
1711 begin
1712 with FXSQLVARs[i].Data^ do
1713 begin
1714
1715 {First get the unique relation name, if any}
1716
1717 if bUnique and (strpas(relname) <> '') then
1718 begin
1719 if FUniqueRelationName = '' then
1720 FUniqueRelationName := strpas(relname)
1721 else
1722 if strpas(relname) <> FUniqueRelationName then
1723 begin
1724 FUniqueRelationName := '';
1725 bUnique := False;
1726 end;
1727 end;
1728
1729 {If an output SQLDA then copy the aliasnames to the FName list. Ensure
1730 that they are all upper case only and disambiguated.
1731 }
1732
1733 if not FInputSQLDA then
1734 begin
1735 st := Space2Underscore(AnsiUppercase(strpas(aliasname)));
1736 if st = '' then
1737 begin
1738 sBaseName := 'F_'; {do not localize}
1739 aliasname_length := 2;
1740 j := 1; j_len := 1;
1741 st := sBaseName + IntToStr(j);
1742 end
1743 else
1744 begin
1745 j := 0; j_len := 0;
1746 sBaseName := st;
1747 end;
1748
1749 {Look for other columns with the same name and make unique}
1750
1751 while VarByName(st,i-1) <> nil do
1752 begin
1753 Inc(j);
1754 j_len := Length(IntToStr(j));
1755 if j_len + Length(sBaseName) > 31 then
1756 st := Copy(sBaseName, 1, 31 - j_len) + IntToStr(j)
1757 else
1758 st := sBaseName + IntToStr(j);
1759 end;
1760
1761 FXSQLVARs[i].FName := st;
1762 end;
1763
1764 {Finally initialise the XSQLVAR}
1765
1766 FXSQLVARs[i].FIndex := i;
1767
1768 case sqltype and (not 1) of
1769 SQL_TEXT, SQL_TYPE_DATE, SQL_TYPE_TIME, SQL_TIMESTAMP,
1770 SQL_BLOB, SQL_ARRAY, SQL_QUAD, SQL_SHORT, SQL_BOOLEAN,
1771 SQL_LONG, SQL_INT64, SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: begin
1772 if (sqllen = 0) then
1773 { Make sure you get a valid pointer anyway
1774 select '' from foo }
1775 IBAlloc(sqldata, 0, 1)
1776 else
1777 IBAlloc(sqldata, 0, sqllen)
1778 end;
1779 SQL_VARYING: begin
1780 IBAlloc(sqldata, 0, sqllen + 2);
1781 end;
1782 else
1783 IBError(ibxeUnknownSQLDataType, [sqltype and (not 1)])
1784 end;
1785 if (sqltype and 1 = 1) then
1786 IBAlloc(sqlind, 0, SizeOf(Short))
1787 else
1788 if (sqlind <> nil) then
1789 ReallocMem(sqlind, 0);
1790 end;
1791 end;
1792 end;
1793 end;
1794
1795 procedure TIBXSQLDA.SetCount(Value: Integer);
1796 var
1797 i, OldSize: Integer;
1798 p : PXSQLVAR;
1799 begin
1800 FCount := Value;
1801 if FCount = 0 then
1802 FUniqueRelationName := ''
1803 else
1804 begin
1805 if FSize > 0 then
1806 OldSize := XSQLDA_LENGTH(FSize)
1807 else
1808 OldSize := 0;
1809 if FCount > FSize then
1810 begin
1811 IBAlloc(FXSQLDA, OldSize, XSQLDA_LENGTH(FCount));
1812 SetLength(FXSQLVARs, FCount);
1813 FXSQLDA^.version := SQLDA_VERSION1;
1814 p := @FXSQLDA^.sqlvar[0];
1815 for i := 0 to FCount - 1 do
1816 begin
1817 if i >= FSize then
1818 FXSQLVARs[i] := TIBXSQLVAR.Create(self, FSQL);
1819 FXSQLVARs[i].FXSQLVAR := p;
1820 p := Pointer(PChar(p) + sizeof(FXSQLDA^.sqlvar));
1821 end;
1822 FSize := FCount;
1823 end;
1824 if FSize > 0 then
1825 begin
1826 FXSQLDA^.sqln := Value;
1827 FXSQLDA^.sqld := Value;
1828 end;
1829 end;
1830 end;
1831
1832 { TIBOutputDelimitedFile }
1833
1834 destructor TIBOutputDelimitedFile.Destroy;
1835 begin
1836 {$IFDEF UNIX}
1837 if FHandle <> -1 then
1838 fpclose(FHandle);
1839 {$ELSE}
1840 if FHandle <> 0 then
1841 begin
1842 FlushFileBuffers(FHandle);
1843 CloseHandle(FHandle);
1844 end;
1845 {$ENDIF}
1846 inherited Destroy;
1847 end;
1848
1849 procedure TIBOutputDelimitedFile.ReadyFile;
1850 var
1851 i: Integer;
1852 {$IFDEF UNIX}
1853 BytesWritten: cint;
1854 {$ELSE}
1855 BytesWritten: DWORD;
1856 {$ENDIF}
1857 st: string;
1858 begin
1859 if FColDelimiter = '' then
1860 FColDelimiter := TAB;
1861 if FRowDelimiter = '' then
1862 FRowDelimiter := CRLF;
1863 {$IFDEF UNIX}
1864 FHandle := FpOpen(Filename,O_WrOnly or O_Creat);
1865 {$ELSE}
1866 FHandle := CreateFile(PChar(Filename), GENERIC_WRITE, 0, nil, CREATE_ALWAYS,
1867 FILE_ATTRIBUTE_NORMAL, 0);
1868 if FHandle = INVALID_HANDLE_VALUE then
1869 FHandle := 0;
1870 {$ENDIF}
1871 if FOutputTitles then
1872 begin
1873 for i := 0 to Columns.Count - 1 do
1874 if i = 0 then
1875 st := strpas(Columns[i].Data^.aliasname)
1876 else
1877 st := st + FColDelimiter + strpas(Columns[i].Data^.aliasname);
1878 st := st + FRowDelimiter;
1879 {$IFDEF UNIX}
1880 if FHandle <> -1 then
1881 BytesWritten := FpWrite(FHandle,st[1],Length(st));
1882 if BytesWritten = -1 then
1883 raise Exception.Create('File Write Error');
1884 {$ELSE}
1885 WriteFile(FHandle, st[1], Length(st), BytesWritten, nil);
1886 {$ENDIF}
1887 end;
1888 end;
1889
1890 function TIBOutputDelimitedFile.WriteColumns: Boolean;
1891 var
1892 i: Integer;
1893 {$IFDEF UNIX}
1894 BytesWritten: cint;
1895 {$ELSE}
1896 BytesWritten: DWORD;
1897 {$ENDIF}
1898 st: string;
1899 begin
1900 result := False;
1901 {$IFDEF UNIX}
1902 if FHandle <> -1 then
1903 {$ELSE}
1904 if FHandle <> 0 then
1905 {$ENDIF}
1906 begin
1907 st := '';
1908 for i := 0 to Columns.Count - 1 do
1909 begin
1910 if i > 0 then
1911 st := st + FColDelimiter;
1912 st := st + StripString(Columns[i].AsString, FColDelimiter + FRowDelimiter);
1913 end;
1914 st := st + FRowDelimiter;
1915 {$IFDEF UNIX}
1916 BytesWritten := FpWrite(FHandle,st[1],Length(st));
1917 {$ELSE}
1918 WriteFile(FHandle, st[1], Length(st), BytesWritten, nil);
1919 {$ENDIF}
1920 if BytesWritten = DWORD(Length(st)) then
1921 result := True;
1922 end
1923 end;
1924
1925 { TIBInputDelimitedFile }
1926
1927 destructor TIBInputDelimitedFile.Destroy;
1928 begin
1929 FFile.Free;
1930 inherited Destroy;
1931 end;
1932
1933 function TIBInputDelimitedFile.GetColumn(var Col: string): Integer;
1934 var
1935 c: Char;
1936 BytesRead: Integer;
1937
1938 procedure ReadInput;
1939 begin
1940 if FLookAhead <> NULL_TERMINATOR then
1941 begin
1942 c := FLookAhead;
1943 BytesRead := 1;
1944 FLookAhead := NULL_TERMINATOR;
1945 end else
1946 BytesRead := FFile.Read(c, 1);
1947 end;
1948
1949 procedure CheckCRLF(Delimiter: string);
1950 begin
1951 if (c = CR) and (Pos(LF, Delimiter) > 0) then {mbcs ok}
1952 begin
1953 BytesRead := FFile.Read(c, 1);
1954 if (BytesRead = 1) and (c <> #10) then
1955 FLookAhead := c
1956 end;
1957 end;
1958
1959 begin
1960 Col := '';
1961 result := 0;
1962 ReadInput;
1963 while BytesRead <> 0 do begin
1964 if Pos(c, FColDelimiter) > 0 then {mbcs ok}
1965 begin
1966 CheckCRLF(FColDelimiter);
1967 result := 1;
1968 break;
1969 end else if Pos(c, FRowDelimiter) > 0 then {mbcs ok}
1970 begin
1971 CheckCRLF(FRowDelimiter);
1972 result := 2;
1973 break;
1974 end else
1975 Col := Col + c;
1976 ReadInput;
1977 end;
1978 end;
1979
1980 function TIBInputDelimitedFile.ReadParameters: Boolean;
1981 var
1982 i, curcol: Integer;
1983 Col: string;
1984 begin
1985 result := False;
1986 if not FEOF then begin
1987 curcol := 0;
1988 repeat
1989 i := GetColumn(Col);
1990 if (i = 0) then
1991 FEOF := True;
1992 if (curcol < Params.Count) then
1993 begin
1994 try
1995 if (Col = '') and
1996 (ReadBlanksAsNull) then
1997 Params[curcol].IsNull := True
1998 else
1999 Params[curcol].AsString := Col;
2000 Inc(curcol);
2001 except
2002 on E: Exception do begin
2003 if not (FEOF and (curcol = Params.Count)) then
2004 raise;
2005 end;
2006 end;
2007 end;
2008 until (FEOF) or (i = 2);
2009 result := ((FEOF) and (curcol = Params.Count)) or
2010 (not FEOF);
2011 end;
2012 end;
2013
2014 procedure TIBInputDelimitedFile.ReadyFile;
2015 begin
2016 if FColDelimiter = '' then
2017 FColDelimiter := TAB;
2018 if FRowDelimiter = '' then
2019 FRowDelimiter := CRLF;
2020 FLookAhead := NULL_TERMINATOR;
2021 FEOF := False;
2022 if FFile <> nil then
2023 FFile.Free;
2024 FFile := TFileStream.Create(FFilename, fmOpenRead or fmShareDenyWrite);
2025 if FSkipTitles then
2026 ReadParameters;
2027 end;
2028
2029 { TIBOutputRawFile }
2030 destructor TIBOutputRawFile.Destroy;
2031 begin
2032 {$IFDEF UNIX}
2033 if FHandle <> -1 then
2034 fpclose(FHandle);
2035 {$ELSE}
2036 if FHandle <> 0 then
2037 begin
2038 FlushFileBuffers(FHandle);
2039 CloseHandle(FHandle);
2040 end;
2041 {$ENDIF}
2042 inherited Destroy;
2043 end;
2044
2045 procedure TIBOutputRawFile.ReadyFile;
2046 begin
2047 {$IFDEF UNIX}
2048 FHandle := FpOpen(Filename,O_WrOnly or O_Creat);
2049 {$ELSE}
2050 FHandle := CreateFile(PChar(Filename), GENERIC_WRITE, 0, nil, CREATE_ALWAYS,
2051 FILE_ATTRIBUTE_NORMAL, 0);
2052 if FHandle = INVALID_HANDLE_VALUE then
2053 FHandle := 0;
2054 {$ENDIF}
2055 end;
2056
2057 function TIBOutputRawFile.WriteColumns: Boolean;
2058 var
2059 i: Integer;
2060 BytesWritten: DWord;
2061 begin
2062 result := False;
2063 if FHandle <> 0 then
2064 begin
2065 for i := 0 to Columns.Count - 1 do
2066 begin
2067 {$IFDEF UNIX}
2068 BytesWritten := FpWrite(FHandle,Columns[i].Data^.sqldata^, Columns[i].Data^.sqllen);
2069 {$ELSE}
2070 WriteFile(FHandle, Columns[i].Data^.sqldata^, Columns[i].Data^.sqllen,
2071 BytesWritten, nil);
2072 {$ENDIF}
2073 if BytesWritten <> DWORD(Columns[i].Data^.sqllen) then
2074 exit;
2075 end;
2076 result := True;
2077 end;
2078 end;
2079
2080 { TIBInputRawFile }
2081 destructor TIBInputRawFile.Destroy;
2082 begin
2083 {$IFDEF UNIX}
2084 if FHandle <> -1 then
2085 fpclose(FHandle);
2086 {$ELSE}
2087 if FHandle <> 0 then
2088 CloseHandle(FHandle);
2089 {$ENDIF}
2090 inherited Destroy;
2091 end;
2092
2093 function TIBInputRawFile.ReadParameters: Boolean;
2094 var
2095 i: Integer;
2096 BytesRead: DWord;
2097 begin
2098 result := False;
2099 {$IFDEF UNIX}
2100 if FHandle <> -1 then
2101 {$ELSE}
2102 if FHandle <> 0 then
2103 {$ENDIF}
2104 begin
2105 for i := 0 to Params.Count - 1 do
2106 begin
2107 {$IFDEF UNIX}
2108 BytesRead := FpRead(FHandle,Params[i].Data^.sqldata^,Params[i].Data^.sqllen);
2109 {$ELSE}
2110 ReadFile(FHandle, Params[i].Data^.sqldata^, Params[i].Data^.sqllen,
2111 BytesRead, nil);
2112 {$ENDIF}
2113 if BytesRead <> DWORD(Params[i].Data^.sqllen) then
2114 exit;
2115 end;
2116 result := True;
2117 end;
2118 end;
2119
2120 procedure TIBInputRawFile.ReadyFile;
2121 begin
2122 {$IFDEF UNIX}
2123 if FHandle <> -1 then
2124 fpclose(FHandle);
2125 FHandle := FpOpen(Filename,O_RdOnly);
2126 if FHandle = -1 then
2127 raise Exception.CreateFmt('Unable to open file %s',[Filename]);
2128 {$ELSE}
2129 if FHandle <> 0 then
2130 CloseHandle(FHandle);
2131 FHandle := CreateFile(PChar(Filename), GENERIC_READ, 0, nil, OPEN_EXISTING,
2132 FILE_FLAG_SEQUENTIAL_SCAN, 0);
2133 if FHandle = INVALID_HANDLE_VALUE then
2134 FHandle := 0;
2135 {$ENDIF}
2136 end;
2137
2138 { TIBSQL }
2139 constructor TIBSQL.Create(AOwner: TComponent);
2140 begin
2141 inherited Create(AOwner);
2142 FIBLoaded := False;
2143 CheckIBLoaded;
2144 FIBLoaded := True;
2145 FGenerateParamNames := False;
2146 FGoToFirstRecordOnExecute := True;
2147 FBase := TIBBase.Create(Self);
2148 FBase.BeforeDatabaseDisconnect := DoBeforeDatabaseDisconnect;
2149 FBase.BeforeTransactionEnd := BeforeTransactionEnd;
2150 FBOF := False;
2151 FEOF := False;
2152 FPrepared := False;
2153 FRecordCount := 0;
2154 FSQL := TStringList.Create;
2155 TStringList(FSQL).OnChanging := SQLChanging;
2156 FProcessedSQL := TStringList.Create;
2157 FHandle := nil;
2158 FSQLParams := TIBXSQLDA.Create(self,daInput);
2159 FSQLRecord := TIBXSQLDA.Create(self,daOutput);
2160 FSQLType := SQLUnknown;
2161 FParamCheck := True;
2162 FCursor := HexStr(self); //Name + RandomString(8);
2163 if AOwner is TIBDatabase then
2164 Database := TIBDatabase(AOwner)
2165 else
2166 if AOwner is TIBTransaction then
2167 Transaction := TIBTransaction(AOwner);
2168 end;
2169
2170 destructor TIBSQL.Destroy;
2171 begin
2172 if FIBLoaded then
2173 begin
2174 if (FOpen) then
2175 Close;
2176 if (FHandle <> nil) then
2177 FreeHandle;
2178 FSQL.Free;
2179 FProcessedSQL.Free;
2180 FBase.Free;
2181 FSQLParams.Free;
2182 FSQLRecord.Free;
2183 end;
2184 inherited Destroy;
2185 end;
2186
2187 procedure TIBSQL.BatchInput(InputObject: TIBBatchInput);
2188 begin
2189 if not Prepared then
2190 Prepare;
2191 InputObject.FParams := Self.FSQLParams;
2192 InputObject.ReadyFile;
2193 if FSQLType in [SQLInsert, SQLUpdate, SQLDelete, SQLExecProcedure] then
2194 while InputObject.ReadParameters do
2195 ExecQuery;
2196 end;
2197
2198 procedure TIBSQL.BatchOutput(OutputObject: TIBBatchOutput);
2199 begin
2200 CheckClosed;
2201 if not Prepared then
2202 Prepare;
2203 if FSQLType = SQLSelect then begin
2204 try
2205 ExecQuery;
2206 OutputObject.FColumns := Self.FSQLRecord;
2207 OutputObject.ReadyFile;
2208 if not FGoToFirstRecordOnExecute then
2209 Next;
2210 while (not Eof) and (OutputObject.WriteColumns) do
2211 Next;
2212 finally
2213 Close;
2214 end;
2215 end;
2216 end;
2217
2218 procedure TIBSQL.CheckClosed;
2219 begin
2220 if FOpen then IBError(ibxeSQLOpen, [nil]);
2221 end;
2222
2223 procedure TIBSQL.CheckOpen;
2224 begin
2225 if not FOpen then IBError(ibxeSQLClosed, [nil]);
2226 end;
2227
2228 procedure TIBSQL.CheckValidStatement;
2229 begin
2230 FBase.CheckTransaction;
2231 if (FHandle = nil) then
2232 IBError(ibxeInvalidStatementHandle, [nil]);
2233 end;
2234
2235 procedure TIBSQL.Close;
2236 var
2237 isc_res: ISC_STATUS;
2238 begin
2239 try
2240 if (FHandle <> nil) and (SQLType = SQLSelect) and FOpen then begin
2241 isc_res := Call(
2242 isc_dsql_free_statement(StatusVector, @FHandle, DSQL_close),
2243 False);
2244 if (StatusVector^ = 1) and (isc_res > 0) and
2245 not CheckStatusVector(
2246 [isc_bad_stmt_handle, isc_dsql_cursor_close_err]) then
2247 IBDatabaseError;
2248 end;
2249 finally
2250 FEOF := False;
2251 FBOF := False;
2252 FOpen := False;
2253 FRecordCount := 0;
2254 end;
2255 end;
2256
2257 function TIBSQL.Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
2258 begin
2259 result := 0;
2260 if Transaction <> nil then
2261 result := Transaction.Call(ErrCode, RaiseError)
2262 else
2263 if RaiseError and (ErrCode > 0) then
2264 IBDataBaseError;
2265 end;
2266
2267 function TIBSQL.Current: TIBXSQLDA;
2268 begin
2269 result := FSQLRecord;
2270 end;
2271
2272 function TIBSQL.GetFieldCount: integer;
2273 begin
2274 Result := FSQLRecord.Count
2275 end;
2276
2277 procedure TIBSQL.SetUniqueParamNames(AValue: Boolean);
2278 begin
2279 if FUniqueParamNames = AValue then Exit;
2280 FreeHandle;
2281 FUniqueParamNames := AValue;
2282 end;
2283
2284 procedure TIBSQL.DoBeforeDatabaseDisconnect(Sender: TObject);
2285 begin
2286 if (FHandle <> nil) then begin
2287 Close;
2288 FreeHandle;
2289 end;
2290 end;
2291
2292 procedure TIBSQL.ExecQuery;
2293 var
2294 fetch_res: ISC_STATUS;
2295 begin
2296 CheckClosed;
2297 if not Prepared then Prepare;
2298 CheckValidStatement;
2299 case FSQLType of
2300 SQLSelect: begin
2301 Call(isc_dsql_execute2(StatusVector,
2302 TRHandle,
2303 @FHandle,
2304 Database.SQLDialect,
2305 FSQLParams.AsXSQLDA,
2306 nil), True);
2307 Call(
2308 isc_dsql_set_cursor_name(StatusVector, @FHandle, PChar(FCursor), 0),
2309 True);
2310 FOpen := True;
2311 FBOF := True;
2312 FEOF := False;
2313 FRecordCount := 0;
2314 if not (csDesigning in ComponentState) then
2315 MonitorHook.SQLExecute(Self);
2316 if FGoToFirstRecordOnExecute then
2317 Next;
2318 end;
2319 SQLExecProcedure: begin
2320 fetch_res := Call(isc_dsql_execute2(StatusVector,
2321 TRHandle,
2322 @FHandle,
2323 Database.SQLDialect,
2324 FSQLParams.AsXSQLDA,
2325 FSQLRecord.AsXSQLDA), True);
2326 if not (csDesigning in ComponentState) then
2327 MonitorHook.SQLExecute(Self);
2328 (* if (fetch_res <> 0) and (fetch_res <> isc_deadlock) then
2329 begin
2330 { Sometimes a prepared stored procedure appears to get
2331 off sync on the server ....This code is meant to try
2332 to work around the problem simply by "retrying". This
2333 need to be reproduced and fixed.
2334 }
2335 isc_dsql_prepare(StatusVector, TRHandle, @FHandle, 0,
2336 PChar(FProcessedSQL.Text), 1, nil);
2337 Call(isc_dsql_execute2(StatusVector,
2338 TRHandle,
2339 @FHandle,
2340 Database.SQLDialect,
2341 FSQLParams.AsXSQLDA,
2342 FSQLRecord.AsXSQLDA), True);
2343 end; *)
2344 end
2345 else
2346 Call(isc_dsql_execute(StatusVector,
2347 TRHandle,
2348 @FHandle,
2349 Database.SQLDialect,
2350 FSQLParams.AsXSQLDA), True);
2351 if not (csDesigning in ComponentState) then
2352 MonitorHook.SQLExecute(Self);
2353 end;
2354 FBase.DoAfterExecQuery(self);
2355 // writeln('Rows Affected = ',RowsAffected);
2356 end;
2357
2358 function TIBSQL.GetEOF: Boolean;
2359 begin
2360 result := FEOF or not FOpen;
2361 end;
2362
2363 function TIBSQL.FieldByName(FieldName: String): TIBXSQLVAR;
2364 var
2365 i: Integer;
2366 begin
2367 i := GetFieldIndex(FieldName);
2368 if (i < 0) then
2369 IBError(ibxeFieldNotFound, [FieldName]);
2370 result := GetFields(i);
2371 end;
2372
2373 function TIBSQL.ParamByName(ParamName: String): TIBXSQLVAR;
2374 begin
2375 Result := Params.ByName(ParamName);
2376 end;
2377
2378 function TIBSQL.GetFields(const Idx: Integer): TIBXSQLVAR;
2379 begin
2380 if (Idx < 0) or (Idx >= FSQLRecord.Count) then
2381 IBError(ibxeFieldNotFound, [IntToStr(Idx)]);
2382 result := FSQLRecord[Idx];
2383 end;
2384
2385 function TIBSQL.GetFieldIndex(FieldName: String): Integer;
2386 begin
2387 if (FSQLRecord.GetXSQLVarByName(FieldName) = nil) then
2388 result := -1
2389 else
2390 result := FSQLRecord.GetXSQLVarByName(FieldName).Index;
2391 end;
2392
2393 function TIBSQL.Next: TIBXSQLDA;
2394 var
2395 fetch_res: ISC_STATUS;
2396 begin
2397 result := nil;
2398 if not FEOF then begin
2399 CheckOpen;
2400 { Go to the next record... }
2401 fetch_res :=
2402 Call(isc_dsql_fetch(StatusVector, @FHandle, Database.SQLDialect, FSQLRecord.AsXSQLDA), False);
2403 if (fetch_res = 100) or (CheckStatusVector([isc_dsql_cursor_err])) then begin
2404 FEOF := True;
2405 end else if (fetch_res > 0) then begin
2406 try
2407 IBDataBaseError;
2408 except
2409 Close;
2410 raise;
2411 end;
2412 end else begin
2413 Inc(FRecordCount);
2414 FBOF := False;
2415 result := FSQLRecord;
2416 end;
2417 if not (csDesigning in ComponentState) then
2418 MonitorHook.SQLFetch(Self);
2419 end;
2420 end;
2421
2422 procedure TIBSQL.FreeHandle;
2423 var
2424 isc_res: ISC_STATUS;
2425 begin
2426 try
2427 { The following two lines merely set the SQLDA count
2428 variable FCount to 0, but do not deallocate
2429 That way the allocations can be reused for
2430 a new query sring in the same SQL instance }
2431 FSQLRecord.Count := 0;
2432 FSQLParams.Count := 0;
2433 if FHandle <> nil then begin
2434 isc_res :=
2435 Call(isc_dsql_free_statement(StatusVector, @FHandle, DSQL_drop), False);
2436 if (StatusVector^ = 1) and (isc_res > 0) and (isc_res <> isc_bad_stmt_handle) then
2437 IBDataBaseError;
2438 end;
2439 finally
2440 FPrepared := False;
2441 FHandle := nil;
2442 end;
2443 end;
2444
2445 function TIBSQL.GetDatabase: TIBDatabase;
2446 begin
2447 result := FBase.Database;
2448 end;
2449
2450 function TIBSQL.GetDBHandle: PISC_DB_HANDLE;
2451 begin
2452 result := FBase.DBHandle;
2453 end;
2454
2455 function TIBSQL.GetPlan: String;
2456 var
2457 result_buffer: array[0..16384] of Char;
2458 result_length, i: Integer;
2459 info_request: Char;
2460 begin
2461 if (not Prepared) or
2462 (not (FSQLType in [SQLSelect, SQLSelectForUpdate,
2463 {TODO: SQLExecProcedure, }
2464 SQLUpdate, SQLDelete])) then
2465 result := ''
2466 else begin
2467 info_request := isc_info_sql_get_plan;
2468 Call(isc_dsql_sql_info(StatusVector, @FHandle, 2, @info_request,
2469 SizeOf(result_buffer), result_buffer), True);
2470 if (result_buffer[0] <> isc_info_sql_get_plan) then
2471 IBError(ibxeUnknownError, [nil]);
2472 result_length := isc_vax_integer(@result_buffer[1], 2);
2473 SetString(result, nil, result_length);
2474 for i := 1 to result_length do
2475 result[i] := result_buffer[i + 2];
2476 result := Trim(result);
2477 end;
2478 end;
2479
2480 function TIBSQL.GetRecordCount: Integer;
2481 begin
2482 result := FRecordCount;
2483 end;
2484
2485 function TIBSQL.GetRowsAffected: Integer;
2486 var
2487 info_request: Char;
2488 RB: TResultBuffer;
2489 begin
2490 if not Prepared then
2491 result := -1
2492 else begin
2493 RB := TResultBuffer.Create;
2494 try
2495 info_request := isc_info_sql_records;
2496 if isc_dsql_sql_info(StatusVector, @FHandle, 1, @info_request,
2497 RB.Size, RB.buffer) > 0 then
2498 IBDatabaseError;
2499 case SQLType of
2500 SQLInsert, SQLUpdate: {Covers Insert or Update as well as individual update}
2501 Result := RB.GetValue(isc_info_sql_records, isc_info_req_insert_count)+
2502 RB.GetValue(isc_info_sql_records, isc_info_req_update_count);
2503 SQLDelete:
2504 Result := RB.GetValue(isc_info_sql_records, isc_info_req_delete_count);
2505 SQLExecProcedure:
2506 Result := RB.GetValue(isc_info_sql_records, isc_info_req_insert_count) +
2507 RB.GetValue(isc_info_sql_records, isc_info_req_update_count) +
2508 RB.GetValue(isc_info_sql_records, isc_info_req_delete_count);
2509 else
2510 Result := 0;
2511 end;
2512 finally
2513 RB.Free;
2514 end;
2515 end;
2516 end;
2517
2518 function TIBSQL.GetSQLParams: TIBXSQLDA;
2519 begin
2520 if not Prepared then
2521 Prepare;
2522 result := FSQLParams;
2523 end;
2524
2525 function TIBSQL.GetTransaction: TIBTransaction;
2526 begin
2527 result := FBase.Transaction;
2528 end;
2529
2530 function TIBSQL.GetTRHandle: PISC_TR_HANDLE;
2531 begin
2532 result := FBase.TRHandle;
2533 end;
2534
2535 {
2536 Preprocess SQL
2537 Using FSQL, process the typed SQL and put the process SQL
2538 in FProcessedSQL and parameter names in FSQLParams
2539 }
2540 procedure TIBSQL.PreprocessSQL;
2541 var
2542 cCurChar, cNextChar, cQuoteChar: Char;
2543 sSQL, sProcessedSQL, sParamName: String;
2544 i, iLenSQL, iSQLPos: Integer;
2545 iCurState {$ifdef ALLOWDIALECT3PARAMNAMES}, iCurParamState {$endif}: Integer;
2546 iParamSuffix: Integer;
2547 slNames: TStrings;
2548
2549 const
2550 DefaultState = 0;
2551 CommentState = 1;
2552 QuoteState = 2;
2553 ParamState = 3;
2554 {$ifdef ALLOWDIALECT3PARAMNAMES}
2555 ParamDefaultState = 0;
2556 ParamQuoteState = 1;
2557 {$endif}
2558
2559 procedure AddToProcessedSQL(cChar: Char);
2560 begin
2561 sProcessedSQL[iSQLPos] := cChar;
2562 Inc(iSQLPos);
2563 end;
2564
2565 begin
2566 sParamName := '';
2567 slNames := TStringList.Create;
2568 try
2569 { Do some initializations of variables }
2570 iParamSuffix := 0;
2571 cQuoteChar := '''';
2572 sSQL := FSQL.Text;
2573 iLenSQL := Length(sSQL);
2574 SetString(sProcessedSQL, nil, iLenSQL + 1);
2575 i := 1;
2576 iSQLPos := 1;
2577 iCurState := DefaultState;
2578 {$ifdef ALLOWDIALECT3PARAMNAMES}
2579 iCurParamState := ParamDefaultState;
2580 {$endif}
2581 { Now, traverse through the SQL string, character by character,
2582 picking out the parameters and formatting correctly for InterBase }
2583 while (i <= iLenSQL) do begin
2584 { Get the current token and a look-ahead }
2585 cCurChar := sSQL[i];
2586 if i = iLenSQL then
2587 cNextChar := #0
2588 else
2589 cNextChar := sSQL[i + 1];
2590 { Now act based on the current state }
2591 case iCurState of
2592 DefaultState: begin
2593 case cCurChar of
2594 '''', '"': begin
2595 cQuoteChar := cCurChar;
2596 iCurState := QuoteState;
2597 end;
2598 '?', ':': begin
2599 iCurState := ParamState;
2600 AddToProcessedSQL('?');
2601 end;
2602 '/': if (cNextChar = '*') then begin
2603 AddToProcessedSQL(cCurChar);
2604 Inc(i);
2605 iCurState := CommentState;
2606 end;
2607 end;
2608 end;
2609 CommentState: begin
2610 if (cNextChar = #0) then
2611 IBError(ibxeSQLParseError, [SEOFInComment])
2612 else if (cCurChar = '*') then begin
2613 if (cNextChar = '/') then
2614 iCurState := DefaultState;
2615 end;
2616 end;
2617 QuoteState: begin
2618 if cNextChar = #0 then
2619 IBError(ibxeSQLParseError, [SEOFInString])
2620 else if (cCurChar = cQuoteChar) then begin
2621 if (cNextChar = cQuoteChar) then begin
2622 AddToProcessedSQL(cCurChar);
2623 Inc(i);
2624 end else
2625 iCurState := DefaultState;
2626 end;
2627 end;
2628 ParamState:
2629 begin
2630 { collect the name of the parameter }
2631 {$ifdef ALLOWDIALECT3PARAMNAMES}
2632 if iCurParamState = ParamDefaultState then
2633 begin
2634 if cCurChar = '"' then
2635 iCurParamState := ParamQuoteState
2636 else
2637 {$endif}
2638 if (cCurChar in ['A'..'Z', 'a'..'z', '0'..'9', '_', '$']) then
2639 sParamName := sParamName + cCurChar
2640 else if FGenerateParamNames then
2641 begin
2642 sParamName := 'IBXParam' + IntToStr(iParamSuffix); {do not localize}
2643 Inc(iParamSuffix);
2644 iCurState := DefaultState;
2645 slNames.AddObject(sParamName,self); //Note local convention
2646 //add pointer to self to mark entry
2647 sParamName := '';
2648 end
2649 else
2650 IBError(ibxeSQLParseError, [SParamNameExpected]);
2651 {$ifdef ALLOWDIALECT3PARAMNAMES}
2652 end
2653 else begin
2654 { determine if Quoted parameter name is finished }
2655 if cCurChar = '"' then
2656 begin
2657 Inc(i);
2658 slNames.Add(sParamName);
2659 SParamName := '';
2660 iCurParamState := ParamDefaultState;
2661 iCurState := DefaultState;
2662 end
2663 else
2664 sParamName := sParamName + cCurChar
2665 end;
2666 {$endif}
2667 { determine if the unquoted parameter name is finished }
2668 if {$ifdef ALLOWDIALECT3PARAMNAMES}(iCurParamState <> ParamQuoteState) and {$endif}
2669 (iCurState <> DefaultState) then
2670 begin
2671 if not (cNextChar in ['A'..'Z', 'a'..'z',
2672 '0'..'9', '_', '$']) then begin
2673 Inc(i);
2674 iCurState := DefaultState;
2675 slNames.Add(sParamName);
2676 sParamName := '';
2677 end;
2678 end;
2679 end;
2680 end;
2681 if iCurState <> ParamState then
2682 AddToProcessedSQL(sSQL[i]);
2683 Inc(i);
2684 end;
2685 AddToProcessedSQL(#0);
2686 FSQLParams.Count := slNames.Count;
2687 for i := 0 to slNames.Count - 1 do
2688 FSQLParams.SetParamName(slNames[i], i,FUniqueParamNames or (slNames.Objects[i] <> nil));
2689 FProcessedSQL.Text := sProcessedSQL;
2690 finally
2691 slNames.Free;
2692 end;
2693 end;
2694
2695 procedure TIBSQL.SetDatabase(Value: TIBDatabase);
2696 begin
2697 FBase.Database := Value;
2698 end;
2699
2700 procedure TIBSQL.Prepare;
2701 var
2702 stmt_len: Integer;
2703 res_buffer: array[0..7] of Char;
2704 type_item: Char;
2705 begin
2706 CheckClosed;
2707 FBase.CheckDatabase;
2708 FBase.CheckTransaction;
2709 if FPrepared then
2710 exit;
2711 if (FSQL.Text = '') then
2712 IBError(ibxeEmptyQuery, [nil]);
2713 if not ParamCheck then
2714 FProcessedSQL.Text := FSQL.Text
2715 else
2716 PreprocessSQL;
2717 if (FProcessedSQL.Text = '') then
2718 IBError(ibxeEmptyQuery, [nil]);
2719 try
2720 Call(isc_dsql_alloc_statement2(StatusVector, DBHandle,
2721 @FHandle), True);
2722 Call(isc_dsql_prepare(StatusVector, TRHandle, @FHandle, 0,
2723 PChar(FProcessedSQL.Text), Database.SQLDialect, nil), True);
2724 { After preparing the statement, query the stmt type and possibly
2725 create a FSQLRecord "holder" }
2726 { Get the type of the statement }
2727 type_item := isc_info_sql_stmt_type;
2728 Call(isc_dsql_sql_info(StatusVector, @FHandle, 1, @type_item,
2729 SizeOf(res_buffer), res_buffer), True);
2730 if (res_buffer[0] <> isc_info_sql_stmt_type) then
2731 IBError(ibxeUnknownError, [nil]);
2732 stmt_len := isc_vax_integer(@res_buffer[1], 2);
2733 FSQLType := TIBSQLTypes(isc_vax_integer(@res_buffer[3], stmt_len));
2734 { Done getting the type }
2735 case FSQLType of
2736 SQLGetSegment,
2737 SQLPutSegment,
2738 SQLStartTransaction: begin
2739 FreeHandle;
2740 IBError(ibxeNotPermitted, [nil]);
2741 end;
2742 SQLCommit,
2743 SQLRollback,
2744 SQLDDL, SQLSetGenerator,
2745 SQLInsert, SQLUpdate, SQLDelete, SQLSelect, SQLSelectForUpdate,
2746 SQLExecProcedure: begin
2747 { We already know how many inputs there are, so... }
2748 if (FSQLParams.FXSQLDA <> nil) and
2749 (Call(isc_dsql_describe_bind(StatusVector, @FHandle, Database.SQLDialect,
2750 FSQLParams.FXSQLDA), False) > 0) then
2751 IBDataBaseError;
2752 FSQLParams.Initialize;
2753 if FSQLType in [SQLSelect, SQLSelectForUpdate,
2754 SQLExecProcedure] then begin
2755 { Allocate an initial output descriptor (with one column) }
2756 FSQLRecord.Count := 1;
2757 { Using isc_dsql_describe, get the right size for the columns... }
2758 Call(isc_dsql_describe(StatusVector, @FHandle, Database.SQLDialect, FSQLRecord.FXSQLDA), True);
2759 if FSQLRecord.FXSQLDA^.sqld > FSQLRecord.FXSQLDA^.sqln then begin
2760 FSQLRecord.Count := FSQLRecord.FXSQLDA^.sqld;
2761 Call(isc_dsql_describe(StatusVector, @FHandle, Database.SQLDialect, FSQLRecord.FXSQLDA), True);
2762 end else if FSQLRecord.FXSQLDA^.sqld = 0 then
2763 FSQLRecord.Count := 0;
2764 FSQLRecord.Initialize;
2765 end;
2766 end;
2767 end;
2768 FPrepared := True;
2769 if not (csDesigning in ComponentState) then
2770 MonitorHook.SQLPrepare(Self);
2771 except
2772 on E: Exception do begin
2773 if (FHandle <> nil) then
2774 FreeHandle;
2775 if E is EIBInterBaseError then
2776 raise EIBInterBaseError.Create(EIBInterBaseError(E).SQLCode,
2777 EIBInterBaseError(E).IBErrorCode,
2778 EIBInterBaseError(E).Message +
2779 sSQLErrorSeparator + FProcessedSQL.Text)
2780 else
2781 raise;
2782 end;
2783 end;
2784 end;
2785
2786 function TIBSQL.GetUniqueRelationName: String;
2787 begin
2788 if FPrepared and (FSQLType = SQLSelect) then
2789 result := FSQLRecord.UniqueRelationName
2790 else
2791 result := '';
2792 end;
2793
2794 procedure TIBSQL.SetSQL(Value: TStrings);
2795 begin
2796 if FSQL.Text <> Value.Text then
2797 begin
2798 FSQL.BeginUpdate;
2799 try
2800 FSQL.Assign(Value);
2801 finally
2802 FSQL.EndUpdate;
2803 end;
2804 end;
2805 end;
2806
2807 procedure TIBSQL.SetTransaction(Value: TIBTransaction);
2808 begin
2809 FBase.Transaction := Value;
2810 end;
2811
2812 procedure TIBSQL.SQLChanging(Sender: TObject);
2813 begin
2814 if Assigned(OnSQLChanging) then
2815 OnSQLChanging(Self);
2816 if FHandle <> nil then FreeHandle;
2817 end;
2818
2819 procedure TIBSQL.BeforeTransactionEnd(Sender: TObject;
2820 Action: TTransactionAction);
2821 begin
2822 if (FOpen) then
2823 Close;
2824 end;
2825
2826 end.