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