fibquery.pas

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

    FProcessedSQL:string; // SQL Query (pre-processed for param labels)
    FSQLParams, // Any parameters to the query.
    FSQLRecord:TFIBXSQLDA; // The current record
    FSQLType:TFIBSQLTypes; // Select, update, delete, insert, create, alter, etc...

    FUserSQLParams:TFIBXSQLDA;
    FProcExecuted:boolean;
    FOnSQLFetch:TOnSQLFetch;
    FMacroChar:Char;
    vUserParamsCreated:boolean;
    FCountLockSQL:integer;
    FModifyTable:string;
    FOptions:TpFIBQueryOptions;
    vDiffParams:boolean;
    FOnlySrvParams:TStringList;
    FCallTime:Cardinal;
    FMacroChanged:boolean;
    FSQLTextChangeCount:integer;
    FHaveStreamParams:boolean;
    FQueryRunState:TQueryRunState;
    FCodePageApplied:boolean;
    FAutoCloseOnTransactionEnd:boolean;
  {$DEFINE FIB_INTERFACE}
   {$I FIBQueryPT.inc}
  {$UNDEF FIB_INTERFACE}
    procedure SaveStreamedParams;
    procedure ClearStreamedParams;
    procedure SetParamCheck(Value:boolean);
    function GetModifyTable:string;
    procedure DatabaseDisconnecting(Sender:TObject);
    function GetDatabase:TFIBDatabase;
    function GetDBHandle:PISC_DB_HANDLE;
    function GetEOF:Boolean;
    function GetFields(const Idx:Integer):TFIBXSQLVAR;
    function GetFieldIndex(const FieldName:string):Integer;
    function GetPlan:string;
    function GetRecordCount:Integer;
    function GetRowsAffected:Integer;
    function GetAllRowsAffected:TAllRowsAffected;

    function GetSQLParams:TFIBXSQLDA;
    function GetTransaction:TFIBTransaction;
    function GetTRHandle:PISC_TR_HANDLE;
    procedure SetDatabase(Value:TFIBDatabase); virtual;
    procedure SetSQL(Value:TStrings);
    procedure SetMacroChar(Value:Char);
    procedure SetTransaction(Value:TFIBTransaction);
    procedure SQLChanging(Sender:TObject);
    procedure SQLChange(Sender:TObject);
    procedure DoTransactionEnding(Sender:TObject);
 // Added procedures
    procedure SaveRestoreValues(SQLDA:TFIBXSQLDA;IsSave:boolean);

    function GetWhereClause(Index:Integer):string;
    procedure SetWhereClause(Index:Integer;const WhereClauseTxt:string);
    function GetOrderString:string;
    procedure SetOrderString(const OrderTxt:string);

    function GetGroupByString:string;
    procedure SetGroupByString(const GroupByTxt:string);

    function GetFieldsClause:string;
    procedure SetFieldsClause(const NewFields:string);

    procedure PrepareUserParamsTypes;
    procedure StartStatisticExec(const stText:string);
    procedure EndStatisticExec(const stText:string);
    procedure DoStatisticPrepare(const stText:string);

    function ParamsNotExist(const SQLText:string):boolean;
    procedure PreprocessSQL(const sSQL:string;IsUserSQL:boolean);
    procedure DoBeforeExecute;
    procedure DoAfterExecute;
  public
    constructor Create(AOwner:TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;
    property Handle:TISC_STMT_HANDLE read FHandle;
  private
    FExtSQLDA:array of TExtDescribeSQLVar;
    procedure FillExtDescribeSQLVars;
    procedure ConvertSQLTextToCodePage;
  public
    function TableAliasForField(FieldIndex:integer):string; overload;
    function TableAliasForFieldByName(const aFieldName:string):string;
 {$IFNDEF BCB}
    function TableAliasForField(const aFieldName:string):string; overload;
 {$ENDIF}
  private
    FOnBatchError:TOnBatchError;
    FCursorName:string;
  public
    function BatchInput(InputObject:TFIBBatchInputStream):boolean;
    function BatchOutput(OutputObject:TFIBBatchOutputStream):boolean;
{$IFDEF WINDOWS}
    procedure BatchInputRawFile(const FileName:string);
    procedure BatchOutputRawFile(const FileName:string;Version:integer=1);
{$ENDIF}
    procedure BatchToQuery(ToQuery:TFIBQuery;Mappings:TStrings);
  public
    function Call(ErrCode:ISC_STATUS; RaiseError:Boolean):ISC_STATUS;
    procedure CheckClosed(const OpName:string);// raise error if query is not closed.
    procedure CheckOpen(const OpName:string); // raise error if query is not open.
    procedure CheckValidStatement; // raise error if statement is invalid.
    procedure Close; // close the query.
    function Current:TFIBXSQLDA;
    procedure ExecQuery; virtual; // ExecQuery the query.
    procedure ExecuteImmediate;
{$IFDEF SUPPORT_IB2007}
    procedure ExecuteAsBatch; overload;
    procedure ExecuteAsBatch(const SQLs:array of string); overload;
{$ENDIF}
    procedure FreeHandle;
    function Next:TFIBXSQLDA;
    procedure Prepare; // Prepare the query.

    function FieldByName(const FieldName:string):TFIBXSQLVAR;
    function FindField(const FieldName:string):TFIBXSQLVAR;
    function FN(const FieldName:string):TFIBXSQLVAR;

    function FieldByOrigin(const TableName,FieldName:string):TFIBXSQLVAR; //overload;
    function SQLFieldName(const aFieldName:string):string;
{$IFDEF SUPPORT_ARRAY_FIELD}
    procedure PrepareArrayFields;
    procedure PrepareArraySqlVar(
      SqlVar:TFIBXSQLVAR;const RelName,aSQLName:string; IsField:boolean
    );
{$ENDIF}
    procedure SetParamValues(const ParamValues:array of Variant); overload;
    procedure SetParamValues(const ParamNames:string;ParamValues:array of Variant); overload;
    procedure ExecWP(const ParamValues:array of Variant); overload;
    procedure ExecWP(const ParamNames:string;ParamValues:array of Variant); overload;
                                           // Exec Query with ParamValues
    procedure ExecWPS(const ParamSources:array of ISQLObject); overload;
    procedure ExecWPS(ParamSource:ISQLObject; AllRecords:boolean=True); overload;

    procedure BeginModifySQLText;
    procedure EndModifySQLText;
    function CountModifySQLText:integer;
    function GetMainWhereIndex:integer;
    function GetMainWhereClause:string;
    procedure SetMainWhereClause (const Value:string);
    function IsProc:boolean;
    function ParamByName(const ParamName:string):TFIBXSQLVAR;
    function FindParam (const aParamName:string):TFIBXSQLVAR;
    procedure ApplyMacro;
    procedure RestoreMacroDefaultValues;
    function FieldCount:integer;
    function SQLDescribeInfo(InfoRequest:array of char):PXSQLDA;
    property Bof:Boolean read FBOF;
    property DBHandle:PISC_DB_HANDLE read GetDBHandle;
    property Eof:Boolean read GetEOF;
    property FldByName[const FieldName:string]:TFIBXSQLVAR read FieldByName; default;
    property Fields[const Idx:Integer]:TFIBXSQLVAR read GetFields;
    property FieldIndex[const FieldName:string]:Integer read GetFieldIndex;
    property Open:Boolean read FOpen;
    property Params:TFIBXSQLDA read GetSQLParams;
    property Plan:string read GetPlan;
    property Prepared:Boolean read FPrepared;
    property RecordCount:Integer read GetRecordCount;
    property RowsAffected:Integer read GetRowsAffected;
    property AllRowsAffected:TAllRowsAffected read GetAllRowsAffected;
    property SQLType:TFIBSQLTypes read FSQLType;
    property TRHandle:PISC_TR_HANDLE read GetTRHandle;
    property ProcExecuted:boolean read FProcExecuted write FProcExecuted;
    property OnSQLFetch:TOnSQLFetch read FOnSQLFetch write FOnSQLFetch; // for internal use
    property OnlySrvParams:TStringList read FOnlySrvParams;
  protected
    FConditions:TConditions;
    procedure SetConditions(Value:TConditions);
  published
    property Conditions:TConditions read FConditions write SetConditions;
  public
{ISQLObject}
    function ParamCount:integer;
    function ParamName(ParamIndex:integer):string;
    function FieldName(FieldIndex:integer):string;
    function FieldsCount:integer;
    function FieldExist(const FieldName:string; var FieldIndex:integer):boolean;
    function ParamExist(const ParamName:string; var ParamIndex:integer):boolean;
    function FieldValue(const FieldName:string;Old:boolean):variant; overload;
    function FieldValue(const FieldIndex:integer;Old:boolean):variant; overload;
    function ParamValue(const ParamName:string):variant; overload;
    function ParamValue(const ParamIndex:integer):variant; overload;
    procedure SetParamValue(const ParamIndex:integer; aValue:Variant);
    function IEof:boolean;
    procedure INext;

{End ISQLObject}

    function ReadySQLText(ForChangeExecSQL:boolean=True):string;
    property SQLTextChangeCount:integer read FSQLTextChangeCount;
  private
    procedure SetPlanClause(const Value:string);
    function GetPlanClause:string;
  public
    procedure AssignProperties(Source:TFIBQuery);
    function WhereClausesCount:integer;
    property WhereClause[Index:integer]:string read GetWhereClause write SetWhereClause;
    property MainWhereClause:string read GetMainWhereClause write SetMainWhereClause;
    property IndexMainWhere:integer read GetMainWhereIndex;
    property CursorName:string read FCursorName write FCursorName;
    property OrderClause:string read GetOrderString write SetOrderString;
    property GroupByClause:string read GetGroupByString write SetGroupByString;
    property FieldsClause:string read GetFieldsClause write SetFieldsClause;
    property PlanClause:string read GetPlanClause write SetPlanClause;
    property ModifyTable:string read GetModifyTable;
    property CallTime:Cardinal read FCallTime;
    property MacroChanged:boolean read FMacroChanged;
    property SQLKind:TSQLKind read GetSQLKind;
    property BeforeExecute:TNotifyEvent read FBeforeExecute write FBeforeExecute;
    property AfterExecute:TNotifyEvent read FAfterExecute write FAfterExecute;

  published
    property Transaction:TFIBTransaction read GetTransaction write SetTransaction;
    property Database:TFIBDatabase read GetDatabase write SetDatabase;

    property GoToFirstRecordOnExecute:Boolean read FGoToFirstRecordOnExecute
                                               write FGoToFirstRecordOnExecute
                                               default True;
    property ParamCheck:Boolean read FParamCheck write SetParamCheck default True;
    property SQL:TStrings read FSQL write SetSQL;

    property OnSQLChanging:TNotifyEvent read FOnSQLChanging write FOnSQLChanging;
    property Options:TpFIBQueryOptions read FOptions write FOptions stored False;
    property OnBatching:TOnBatching read FOnBatching write FOnBatching;
    property OnBatchError:TOnBatchError read FOnBatchError write FOnBatchError;
    property TransactionEnding:TNotifyEvent read FTransactionEnding write FTransactionEnding;
    property TransactionEnded:TNotifyEvent read FTransactionEnded write FTransactionEnded;
{$IFDEF CSMonitor}
    property CSMonitorSupport:TCSMonitorSupport read FCSMonitorSupport write SetMonitorSupport;
{$ENDIF}

  end;

procedure BlobToStream (ModelVar:TFIBXSQLVAR; BlobID:TISC_QUAD;Stream:TStream);

const
   ExecProcPrefix ='EXECUTE ';
  //Statistic consts
   scPrepareCount ='PrepareCount';
   scExecuteCount ='ExecuteCount';
   scSumTimeExecute ='SumTimeExecute';
   scAvgTimeExecute ='AvgTimeExecute';
   scMaxTimeExecute ='MaxTimeExecute';
   scLastTimeExecute='LastTimeExecute';
   scLastQuery ='LastQueryName';

   fibGUID_NULL:TGUID = '{00000000-0000-0000-0000-000000000000}';
   chUnicodeFSS=3;

{$IFDEF SUPPORT_KOI8_CHARSET}
   chFBKOI8R=63;
   chFBKOI8U=64;
   CodePageKOI8R=20866;
   CodePageKOI8RU=21866;
{$ENDIF}

implementation

uses
  FIBMiscellaneous, StrUtil,
  IBBlobFilter, FIBConsts,FIBCloneComponents
  //Added uses
{$IFNDEF NO_MONITOR}
  ,FIBSQLMonitor
{$ENDIF}
{$IFDEF CSMonitor}
 ,FIBDataSet,pFIBDataSet
{$ENDIF}
 ;

const
 cPlanMaxLength=16384;

(* TFIBXSQLVAR *)
constructor TFIBXSQLVAR.Create(AParent:TFIBXSQLDA);
begin
  FParent:= AParent;
  FVariantFalse:= 0;
  FVariantTrue:= 1;
  FModified:=False;
  FIsMacro:=False;
  FQuoted:=False;
  FOldValue:=Unassigned;
  FInWhereClause:=False;
  FInitialized:=False;
  FCanForceIsNull:=False;
 {$IFDEF SUPPORT_ARRAY_FIELD}
  vFIBArray:=nil;
 {$ENDIF}
end;

destructor TFIBXSQLVAR.Destroy; //override;
begin
 {$IFDEF SUPPORT_ARRAY_FIELD}
 if Assigned(vFIBArray) then vFIBArray.Free;
 {$ENDIF}
 inherited Destroy;
 FreeAndNil(FStreamValue);
end;

{$WARNINGS OFF}
function TFIBXSQLVAR.AdjustScale(Value:Int64; Scale:Integer):Double;
begin
 Result:= Value*E10[Scale];
end;

function TFIBXSQLVAR.AdjustScaleToCurrency(Value:Int64; Scale:Integer):Currency;
begin
 try
  Result:= Value * E10[Scale];
 except
  Result:= 0;
 end;
end;

function TFIBXSQLVAR.AdjustScaleToInt64(Value:Int64; Scale:Integer):Int64;
begin
  if Scale = 0 then
   Result:= Value
  else
   Result:= Value div Trunc(E10[-Scale])
end;
{$WARNINGS ON}

procedure TFIBXSQLVAR.Assign(Source:TFIBXSQLVAR);
var
  szBuff:PChar;
  s_bhandle, d_bhandle:TISC_BLOB_HANDLE;
  bSourceBlob, bDestBlob:Boolean;
  iSegs, iMaxSeg, iSize:Long;
  iBlobType:Short;
  SP:TFIBXSQLVAR;
  DestSQLType,SrcSQLType:integer;
begin
  szBuff:= nil;
  SrcSQLType:=Source.FXSQLVAR^.sqltype and (not 1);
  DestSQLType:=FXSQLVAR^.sqltype and (not 1);
  bSourceBlob:=SrcSQLType=SQL_BLOB;
  bDestBlob:=True;
  s_bhandle:=nil;
  d_bhandle:=nil;
  try
    if (Source.IsNull) then
    begin
      IsNull:= True;
      Exit;
    end
    else
    if (DestSQLType = SQL_ARRAY) or (SrcSQLType = SQL_ARRAY) then Exit;
     // arrays not supported.

    if (DestSQLType<>SQL_BLOB) and not bSourceBlob then
    begin
      AsXSQLVAR:= Source.AsXSQLVAR;
      Exit;
    end
    else
    if (SrcSQLType<>SQL_BLOB) then
    begin
      szBuff:= nil;
      FIBAlloc(szBuff, 0, Source.FXSQLVAR^.sqllen);
      Move(Source.FXSQLVAR^.sqldata[0], szBuff[0], Source.FXSQLVAR^.sqllen);
      iSize:= Source.FXSQLVAR^.sqllen;
    end
    else
    if (DestSQLType<>SQL_BLOB) then
    begin
     if FParent=FQuery.FUserSQLParams then
     begin
      if not FQuery.Prepared then FQuery.Prepare;
      SP:=FQuery.FSQLParams.FindParam(Name);
      bDestBlob:= not (
       (SP=nil) or (SP.FXSQLVAR^.sqltype and (not 1)<>SQL_BLOB)
      );
      if bDestBlob then AsQuad:=SP.AsQuad;
     end
     else
      bDestBlob:= False;
    end;
    if bSourceBlob then
    begin
      // read the blob
      Source.FQuery.Call(
        Source.FQuery.Database.ClientLibrary.isc_open_blob2(StatusVector, Source.FQuery.DBHandle,
        Source.FQuery.TRHandle, @s_bhandle, PISC_QUAD(Source.FXSQLVAR.sqldata),
        0, nil), True
      );
      with Source.FQuery,Source.FQuery.Database do
      try
        GetBlobInfo(ClientLibrary,@s_bhandle,iSegs, iMaxSeg, iSize,iBlobType);
        szBuff:= nil;
        FIBAlloc(szBuff, 0, iSize);
        ReadBlob(ClientLibrary,@s_bhandle, szBuff, iSize);
        if (not bDestBlob) // 桤徨汔屐 腓