ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBSQL.pas
Revision: 19
Committed: Mon Jul 7 13:00:15 2014 UTC (9 years, 8 months ago) by tony
Content type: text/x-pascal
File size: 76957 byte(s)
Log Message:
Committing updates for Release R1-1-0

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