fibquery.pas

FIBPlus version 6-96. This is somewhat usefull interbase database components. TFIBDatabase, TFIBTab

{***************************************************************}
{ FIBPlus-component library for direct access to Firebird and }
{ InterBase databases }
{ }
{ FIBPlus is based in part on the product }
{ Free IB Components, written by Gregory H. Deatz for }
{ Hoagland, Longo, Moran, Dunst & Doukas Company. }
{ mailto:[e-mail] }
{ }
{ Copyright (c) 1998-2007 Devrace Ltd. }
{ Written by Serge Buzadzhy ([e-mail]) }
{ }
{-------------------------------------------------------------}
{ FIBPlus home page:http://www.fibplus.com/ }
{ FIBPlus support:http://www.devrace.com/support/ }
{-------------------------------------------------------------}
{ }
{ Please see the file License.txt for full license information }
{***************************************************************}

unit FIBQuery;

interface

{$I FIBPlus.inc}

uses
  SysUtils, Classes, ibase,IB_Intf, IB_Externals,
  DB, fib, FIBDatabase, StdFuncs,IB_ErrorCodes,SqlTxtRtns,pFIBProps,
  pFIBInterfaces,
 {$IFDEF SUPPORT_ARRAY_FIELD} pFIBArray, {$ENDIF}
 {$IFDEF WINDOWS}
   Windows {$IFDEF D6+},FMTBcd, Variants{$ENDIF}
  ;
 {$ENDIF}
 {$IFDEF LINUX}
   Types, FMTBcd , Variants;
 {$ENDIF}

type
  TFIBQuery = class;
  TFIBXSQLDA = class;
  TFIBXSQLVAR = class;

  TExtDescribeSQLVar =
  record
   sql_relation_alias:array[0..LENGTH_METANAMES-1] of AnsiChar;
  end;

  TTypeSetToParam =(tspNull,tspIsNullable,tspScale, tspValue,tspSqlVar);

  (* TFIBXSQLVAR *)
  TFIBXSQLVAR = class(TObject)
  private
    function GetAsBoolean:boolean;
    procedure SetAsBoolean(const Value:boolean);
  protected
    FIndex:Integer;
    FModified:Boolean;
    FName:string;
    FQuery:TFIBQuery;
    FVariantFalse,
    FVariantTrue:Variant;
    FXSQLVAR:PXSQLVAR; // Point to the PXSQLVAR in the owner object
    FParent:TFIBXSQLDA;
// Added variables
    FIsMacro:boolean;
    FQuoted:boolean;
    FOldValue:Variant; // Value Param from last ExecQuery
    FDefMacroValue:string;
    FSrvSQLType:integer;
    FSrvSQLSubType:integer;
    FSrvSQLLen:Smallint;
    FSrvSQLScale:Smallint;
    FInWhereClause:boolean;
    FCanForceIsNull:boolean;
    FInitialized:boolean;
    FBeginPosInText:integer;
    FEndPosInText:integer;
    FIsDefferedSetting:boolean;
    FStreamValue:TMemoryStream;
    FWideTempValue:WideString;
 {$IFDEF SUPPORT_ARRAY_FIELD}
    vFIBArray:TpFIBArray;
 {$ENDIF}

    function AdjustScale(Value:Int64; Scale:Integer):Double; {$IFDEF D6+} deprecated; {$ENDIF}
    function AdjustScaleToCurrency(Value:Int64; Scale:Integer):Currency; {$IFDEF D6+} deprecated;{$ENDIF}
    function AdjustScaleToInt64(Value:Int64; Scale:Integer):Int64;{$IFDEF D6+} deprecated;{$ENDIF}
    function GetAsInt64:Int64;

    function GetAsCurrency:Currency;
 {$IFNDEF NO_USE_COMP}
    function GetAsComp:Comp;
 {$ENDIF}
    function GetAsDateTime:TDateTime;
    function GetAsTimeStamp:TTimeStamp;
    function GetAsDouble:Double;
    function GetAsFloat:Double;
    function GetAsSingle:Float;
    function GetAsLong:Long;
    function GetAsPointer:Pointer;
    function GetAsQuad:TISC_QUAD;
    function GetAsShort:Short;
    function GetAsString:string;
    function GetAsAnsiString:Ansistring;
    function GetAsVariant:Variant;
    function GetAsExtended:Extended;
    function GetAsXSQLVAR:PXSQLVAR;
    function GetIsNull:Boolean;
    function GetIsNullable:Boolean;
    function GetSize:Integer;
    function GetSQLType:Integer;
    function GetServerSQLType:Integer;
    function GetSQLSubtype:Short;
    function GetServerSQLSubType:Integer;
    function GetServerSQLSize:Integer;
    function GetServerSQLScale:Integer;
// Array Support
 {$IFDEF SUPPORT_ARRAY_FIELD}
    procedure CheckArrayType;
    function GetDimensionCount:Integer;
    function GetDimension(Index:Integer):TISC_ARRAY_BOUND;
    function GetSliceSize:integer;
    function GetElementType:TFieldType;
    function GetArraySize:integer;
  {$ENDIF}
//
    procedure SetValue(aSQLType,aSize:integer;ValueType:TTypeSetToParam;const aValue);

    procedure SetAsCurrency(aValue:Currency);
 {$IFNDEF NO_USE_COMP}
    procedure SetAsComp(aValue:comp); //patchInt64A
{$ENDIF}
    procedure SetAsInt64(aValue:Int64);
    procedure SetAsDateTime(aValue:TDateTime);
    procedure SetAsTime(aValue:TDateTime);
    procedure SetAsDate(aValue:TDateTime);
    procedure SetAsTimeStamp(aValue:TTimeStamp);
    procedure SetAsDouble(aValue:Double);
    procedure SetAsFloat(aValue:Double);
    procedure SetAsSingle(aValue:Float);
    procedure SetAsExtended(aValue:Extended);

    procedure SetAsLong(aValue:Long);
    procedure SetAsQuad(aValue:TISC_QUAD);
    procedure SetAsShort(aValue:Short);
    procedure InternalSetAsString(aValue:Pointer; IsWide:boolean; AdjustDeffered:boolean=False);
    procedure SetAsString(const aValue:string);
    procedure SetAsWideString(const aValue:WideString);
    procedure SetAsAnsiString(const aValue:Ansistring);
    function GetAsWideString:WideString;

    procedure SetAsVariant(Value:Variant);

    procedure SetAsXSQLVAR(aValue:PXSQLVAR);
    procedure SetIsNull(aValue:Boolean);
    procedure SetIsNullable(aValue:Boolean);
    function GetScale:integer;

    procedure SetScale(Value:integer);
    function GetAsBcd:TBcd;
    procedure SetAsBcd(Value:TBcd);

    function GetAsGUID:TGUID;
    procedure SetAsGuid(aValue:TGUID);
  public
    constructor Create(AParent:TFIBXSQLDA);
    destructor Destroy; override;
    procedure Assign(Source:TFIBXSQLVAR);

    procedure SetSQLLen(A:SmallInt);

    function IsNumericType(SQLType:Integer):boolean;
    function IsRealType(SQLType:Integer):boolean;
    function IsDateTimeType(SQLType:Integer):boolean;

    procedure LoadFromFile(const FileName:string);
    procedure LoadFromStream(Stream:TStream);
    procedure SaveToFile(const FileName:string);
    procedure SaveToStream(Stream:TStream);
    procedure Clear;
    function IsParam:boolean;
    function IsBlob:boolean;
    function SqlName:string;
    function AliasName:string;
    function RelationName:string;
    function CharacterSet:string;
// Array Support
{$IFDEF SUPPORT_ARRAY_FIELD}
    function IsArray:boolean;
    function GetArrayElement(Indexes:array of Integer):Variant;
    function GetArrayValues:Variant;
    procedure SetArrayValue(Value:Variant);
{$ENDIF}
    function IsDefMacroValue:boolean;
    procedure SetDefMacroValue;
//

    property AsCurrency:Currency read GetAsCurrency write SetAsCurrency;
 {$IFNDEF NO_USE_COMP}
    property AsComp:comp read GetAsComp write SetAsComp;
 {$ENDIF}
    property AsExtended:Extended read GetAsExtended write SetAsExtended;
    property AsInt64:Int64 read GetAsInt64 write SetAsInt64;
    property AsBcd:TBcd read GetAsBcd write SetAsBcd;
    property AsGuid:TGUID read GetAsGUID write SetAsGUID;
    property AsDateTime:TDateTime read GetAsDateTime write SetAsDateTime;
    property AsDate:TDateTime read GetAsDateTime write SetAsDate;
    property AsTime:TDateTime read GetAsDateTime write SetAsTime;
    property AsTimeStamp:TTimeStamp read GetAsTimeStamp write SetAsTimeStamp;
    property AsDouble:Double read GetAsDouble write SetAsDouble;
    property AsFloat:Double read GetAsFloat write SetAsFloat;
    property AsSingle:Float read GetAsSingle write SetAsSingle;
    property AsInteger:Integer read GetAsLong write SetAsLong;
    property AsLong:Long read GetAsLong write SetAsLong;
    property AsPointer:Pointer read GetAsPointer;
    property AsQuad:TISC_QUAD read GetAsQuad write SetAsQuad;
    property AsShort:Short read GetAsShort write SetAsShort;
    property AsString:string read GetAsString write SetAsString;
    property AsWideString:WideString read GetAsWideString write SetAsWideString;
    property AsAnsiString:AnsiString read GetAsAnsiString write SetAsAnsiString;

    property AsVariant:Variant read GetAsVariant write SetAsVariant;
    property AsXSQLVAR:PXSQLVAR read GetAsXSQLVAR write SetAsXSQLVAR;
    property AsBoolean:boolean read GetAsBoolean write SetAsBoolean;
    property Data:PXSQLVAR read FXSQLVAR write FXSQLVAR;
    property IsNull:Boolean read GetIsNull write SetIsNull;
    property IsNullable:Boolean read GetIsNullable write SetIsNullable;
    property Scale:Integer read GetScale write SetScale;
    property Index:Integer read FIndex;
    property Modified:Boolean read FModified write FModified;
    property Name:string read FName;
    property Size:Integer read GetSize;
    property ServerSize:Integer read GetServerSQLSize;
    property SQLType:Integer read GetSQLType;
    property ServerSQLType:Integer read GetServerSQLType;
    property SQLSubtype:Short read GetSQLSubtype;
    property ServerSQLSubType:Integer read GetServerSQLSubType;
    property Value:Variant read GetAsVariant write SetAsVariant;
    property OldValue:Variant read FOldValue;
    property VariantFalse:Variant read FVariantFalse write FVariantFalse;
    property VariantTrue:Variant read FVariantTrue write FVariantTrue;
// Added properties
    property IsMacro:boolean read FIsMacro write FIsMacro;
    property Quoted:boolean read FQuoted write FQuoted;
    property DefMacroValue:string read FDefMacroValue write FDefMacroValue;
    property InWhereClause:boolean read FInWhereClause;
    property BeginPosInText:integer read FBeginPosInText;
    property EndPosInText:integer read FEndPosInText;

// Array Support
 {$IFDEF SUPPORT_ARRAY_FIELD}
    property FIBArray:TpFIBArray read vFIBArray;
    property DimensionCount:integer read GetDimensionCount;
    property Dimension[Index:Integer]:TISC_ARRAY_BOUND read GetDimension;
    property ElementType:TFieldType read GetElementType;
    property ArraySize:Integer read GetArraySize;
 {$ENDIF}

  end;

  TFIBXSQLVARArray = array[0..0] of TFIBXSQLVAR;
  PFIBXSQLVARArray = ^TFIBXSQLVARArray;

  (* TFIBXSQLVAR *)
  TFIBXSQLDA = class(TObject)
  private
    FEquelNames:TStringList;
    FCachedNames:TStringList;
    FCount:Integer;
    FHasDefferedSettings:Boolean;
    procedure AdjustDefferedSettings;
  protected
    FNames:TStringList;
    FQuery:TFIBQuery;
    FSize:Integer;
    FXSQLDA:PXSQLDA;
    FXSQLVARs:PFIBXSQLVARArray; // array of FIBXQLVARs
    FIsParams:boolean;
    function GetModified:Boolean;
    function GetNames:string;
    function GetRecordSize:Integer;
    function GetXSQLDA:PXSQLDA;
    function GetXSQLVAR(Idx:Integer):TFIBXSQLVAR;
    function GetXSQLVARByName(const Idx:string):TFIBXSQLVAR;
    procedure Initialize;
    procedure SetCount(Value:Integer);
    procedure AddName(const FieldName:string; Idx:Integer; Quoted:boolean);
    procedure SetUnModifiedToVars;
  public
    constructor Create(aIsParams:boolean);
    destructor Destroy; override;
    procedure ClearValues;
    function FindParam(const aParamName:string):TFIBXSQLVAR;
    function ParamByName(const aParamName:string):TFIBXSQLVAR;
    procedure AssignValues(SourceSQLDA:TFIBXSQLDA);
    property AsXSQLDA:PXSQLDA read GetXSQLDA;
    property ByName[const Idx:string]:TFIBXSQLVAR read GetXSQLVARByName;
    property Count:Integer read FCount write SetCount;
    property Modified:Boolean read GetModified;
    property Names:string read GetNames;
    property RecordSize:Integer read GetRecordSize;
    property Vars[Idx:Integer]:TFIBXSQLVAR read GetXSQLVAR; default;
  end;

  (* TFIBBatch-basis for batch input and batch output objects. *)
  TBatchState = (bsNotPrepared,bsFileReady,bsInProcess,bsInError);

  TFIBBatch = class(TObject)
  protected
    FFilename:Ansistring;
    FColumns:TFIBXSQLDA;
    FParams:TFIBXSQLDA;
    FState:TBatchState;
  public
    constructor Create;
    procedure ReadyStream; virtual; abstract;
    property Columns:TFIBXSQLDA read FColumns;
    property Filename:Ansistring read FFilename write FFilename;
    property Params:TFIBXSQLDA read FParams;
    property State:TBatchState read FState;
  end;

  (* TFIBBatchInputStream-see FIBMiscellaneous for good examples. *)
  TFIBBatchInputStream = class(TFIBBatch)
  public
    function ReadParameters:Boolean; virtual; abstract;
  end;
  TFIBBatchInputStreamClass = class of TFIBBatchInputStream;

  (* TFIBBatchOutputStream-see FIBMiscellaneous for good examples. *)
  TFIBBatchOutputStream = class(TFIBBatch)
  public
    function WriteColumns:Boolean; virtual; abstract;
  end;

  TFIBBatchOutputStreamClass = class of TFIBBatchOutputStream;

  (* TFIBQuery *)
  TFIBSQLTypes = (SQLUnknown, SQLSelect, SQLInsert,
                   SQLUpdate, SQLDelete, SQLDDL,
                   SQLGetSegment, SQLPutSegment,
                   SQLExecProcedure, SQLStartTransaction,
                   SQLCommit, SQLRollback,
                   SQLSelectForUpdate, SQLSetGenerator,SQLSavePointOperation
                  );

  TOnSQLFetch =procedure (RecordNumber:integer; var StopFetching:boolean
  ) of object;

  TBatchOperation =(boInput,boOutput,boOutputToQuery);
  TBatchAction =(baContinue,baStop,baSkip);
  TBatchErrorAction =(beFail, beAbort, beRetry,beIgnore);

  TOnBatching =
   procedure(BatchOperation:TBatchOperation;RecNumber:integer;var BatchAction:TBatchAction)
   of object;

  TOnBatchError = procedure(E:EFIBError;var BatchErrorAction:TBatchErrorAction) of object;

  TAllRowsAffected =
  record
    Updates:integer;
    Deletes:integer;
    Selects:integer;
    Inserts:integer;
  end;

  TQueryRunStateValues=(qrsInPrepare,qrsInExecute);
  TQueryRunState = set of TQueryRunStateValues;

  TFIBQuery = class(TComponent,ISQLObject)
  private
   FOnBatching:TOnBatching;
   FDoParamCheck:boolean;
   FParser:TSQLParser;
   FTransactionEnding:TNotifyEvent;
   FTransactionEnded:TNotifyEvent;
   FBeforeExecute:TNotifyEvent;
   FAfterExecute:TNotifyEvent;
{$IFDEF CSMonitor}
   FCSMonitorSupport:TCSMonitorSupport;
   procedure SetMonitorSupport(Value:TCSMonitorSupport);
   function GetCSMonText:string;
{$ENDIF}
   function GetSQLKind:TSQLKind;
  protected
    FBase:TFIBBase;
    FBOF, // At BOF?
    FEof, // At EOF
    FGoToFirstRecordOnExecute, // Automatically position record on first record after executing
    FOpen, // Is a cursor open?
    FPrepared:Boolean; // Has the query been prepared?
    FRecordCount:Integer; // How many records have been read so far?
    FHandle:TISC_STMT_HANDLE; // Once prepared, this accesses the SQL Query

    FOnSQLChanging:TNotifyEvent; // Call this when the SQL is changing.
    FSQL:TStrings; // SQL Query (by user)
    FParamCheck:Boolean; // Check for parameters? (just like TQuery)