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