ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBSQL.pas
Revision: 1
Committed: Mon Jul 31 16:43:00 2000 UTC (23 years, 8 months ago) by tony
Content type: text/x-pascal
File size: 69636 byte(s)
Log Message:
Borland IBX Open Source Release

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