{******************************************************************************} { UNIFIED INTERBASE (UIB) } { } { Project JEDI Code Library (JCL) } { } { The contents of this file are subject to the Mozilla Public License Version } { 1.1 (the "License"); you may not use this file except in compliance with the } { License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ } { } { Software distributed under the License is distributed on an "AS IS" basis, } { WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for } { the specific language governing rights and limitations under the License. } { } { The Initial Developer of the Original Code is documented in the accompanying } { help file JCL.chm. Portions created by these individuals are Copyright (C) } { 2003 of these individuals. } { } { The Initial Developer of TMemoryPool is TurboPower FlashFiler. } { } { Unit owner: Henri Gourvest } { Last modified: September 21, 2003 } { } {******************************************************************************} { UIB Library, class and functions helpers to use Interbase API. } unit JvUIBLib; {$I jvcl.inc} {$I JvUIB.inc} {$ALIGN ON} {$MINENUMSIZE 4} interface uses {$IFDEF USEJVCL} {$IFDEF UNITVERSIONING} JclUnitVersioning, {$ENDIF UNITVERSIONING} {$ENDIF USEJVCL} {$IFDEF MSWINDOWS} Windows, {$ENDIF} {$IFDEF COMPILER6_UP} Variants, {$ENDIF} {$IFDEF FPC} Variants, {$ENDIF} JvUIBase, JvUIBError, Classes, SysUtils; type TUIBFieldType = (uftUnKnown, uftNumeric, uftChar, uftVarchar, uftCstring, uftSmallint, uftInteger, uftQuad, uftFloat, uftDoublePrecision, uftTimestamp, uftBlob, uftBlobId, uftDate, uftTime, uftInt64 {$IFDEF IB7_UP}, uftBoolean{$ENDIF}); TScale = 1..15; //****************************************************************************** // Errors handling //****************************************************************************** EUIBConvertError = class(Exception); EUIBError = class(Exception) private FErrorCode: Integer; FSQLCode : Integer; public property ErrorCode: Integer read FErrorCode; property SQLCode: Integer read FSQLCode; end; EUIBException = class(EUIBError) private FNumber: Integer; public property Number: Integer read FNumber; end; EUIBGFixError = class(EUIBError); EUIBDSQLError = class(EUIBError); EUIBDynError = class(EUIBError); EUIBGBakError = class(EUIBError); EUIBGSecError = class(EUIBError); EUIBLicenseError = class(EUIBError); EUIBGStatError = class(EUIBError); EUIBExceptionClass = class of EUIBException; EUIBParser = class(Exception) private FLine: Integer; FCharacter: Integer; public // the extra parameter is a dummy parameter to force the generation of // a unique constructor declaration in the resulting hpp file // when used with BCB constructor Create(Line, Character: Integer; dummyForBCB : Integer = 0); property Line: Integer read FLine; property Character: Integer read FCharacter; end; const QuadNull: TISCQuad = (gds_quad_high: 0; gds_quad_low: 0); //****************************************************************************** // Database //****************************************************************************** type TCharacterSet = (csNONE, csASCII, csBIG_5, csCYRL, csDOS437, csDOS850, csDOS852, csDOS857, csDOS860, csDOS861, csDOS863, csDOS865, csEUCJ_0208, csGB_2312, csISO8859_1, csISO8859_2, csKSC_5601, csNEXT, csOCTETS, csSJIS_0208, csUNICODE_FSS, csWIN1250, csWIN1251, csWIN1252, csWIN1253, csWIN1254 {$IFDEF FB15_UP} ,csDOS737, csDOS775, csDOS858, csDOS862, csDOS864, csDOS866, csDOS869, csWIN1255, csWIN1256, csWIN1257, csISO8859_3, csISO8859_4, csISO8859_5, csISO8859_6, csISO8859_7, csISO8859_8, csISO8859_9, csISO8859_13 {$ENDIF FB15_UP} {$IFDEF IB71_UP} ,csISO8859_15 ,csKOI8R {$ENDIF IB71_UP} ); const CharacterSetStr : array[TCharacterSet] of string = ( 'NONE', 'ASCII', 'BIG_5', 'CYRL', 'DOS437', 'DOS850', 'DOS852', 'DOS857', 'DOS860', 'DOS861', 'DOS863', 'DOS865', 'EUCJ_0208', 'GB_2312', 'ISO8859_1', 'ISO8859_2', 'KSC_5601', 'NEXT', 'OCTETS', 'SJIS_0208', 'UNICODE_FSS', 'WIN1250', 'WIN1251', 'WIN1252', 'WIN1253', 'WIN1254' {$IFDEF FB15_UP} ,'DOS737', 'DOS775', 'DOS858', 'DOS862', 'DOS864', 'DOS866', 'DOS869', 'WIN1255', 'WIN1256', 'WIN1257', 'ISO8859_3', 'ISO8859_4', 'ISO8859_5', 'ISO8859_6', 'ISO8859_7', 'ISO8859_8', 'ISO8859_9', 'ISO8859_13' {$ENDIF FB15_UP} {$IFDEF IB71_UP} ,'ISO8859_15', 'KOI8R' {$ENDIF IB71_UP} ); {$IFDEF DLLREGISTRY} FBINSTANCES = 'SOFTWARE\Firebird Project\Firebird Server\Instances'; {$ENDIF DLLREGISTRY} function StrToCharacterSet(const CharacterSet: string): TCharacterSet; function CreateDBParams(Params: String; Delimiter: Char = ';'): string; function GetClientLibrary: string; //****************************************************************************** // Transaction //****************************************************************************** const // Default Transaction Parameter TPBDefault = isc_tpb_version3 + isc_tpb_write + isc_tpb_concurrency + isc_tpb_wait; //****************************************************************************** // DSQL //****************************************************************************** //**************************************** // TSQLDA //**************************************** const {$IFDEF IB7_UP} MaxParamLength = 274; {$ELSE} MaxParamLength = 125; {$ENDIF IB7_UP} type PUIBSQLVar = ^TUIBSQLVar; TUIBSQLVar = record SqlType : Smallint; SqlScale : Smallint; {$IFDEF IB7_UP} SqlPrecision : Smallint; {$ENDIF IB7_UP} SqlSubType : Smallint; SqlLen : Smallint; SqlData : Pchar; SqlInd : PSmallint; case byte of // TSQLResult 0 : ( SqlNameLength : Smallint; SqlName : array[0..METADATALENGTH-1] of char; RelNameLength : Smallint; RelName : array[0..METADATALENGTH-1] of char; OwnNameLength : Smallint; OwnName : array[0..METADATALENGTH-1] of char; AliasNameLength : Smallint; AliasName : array[0..METADATALENGTH-1] of char; ); // TSQLParam 1 : ( Init : boolean; ID : Word; ParamNameLength : Smallint; ParamName : array[0..MaxParamLength-1] of char; ); end; PUIBSQLDa = ^TUIBSQLDa; TUIBSQLDa = record version : Smallint; // version of this XSQLDA sqldaid : array[0..7] of char; // XSQLDA name field -> RESERVED sqldabc : ISCLong; // length in bytes of SQLDA -> RESERVED sqln : Smallint; // number of fields allocated sqld : Smallint; // actual number of fields sqlvar: array[Word] of TUIBSQLVar; // first field address end; TUIBStatementType = ( stSelect, // select SELECT stInsert, // insert INSERT INTO stUpdate, // update UPDATE stDelete, // delete DELETE FROM stDDL, // stGetSegment, // blob READ BLOB stPutSegment, // blob INSERT BLOB stExecProcedure, // invoke_procedure EXECUTE PROCEDURE stStartTrans, // declare DECLARE stCommit, // commit COMMIT stRollback, // rollback ROLLBACK [WORK] stSelectForUpdate, // SELECT ... FOR UPDATE stSetGenerator {$IFDEF FB15_UP} ,stSavePoint // user_savepoint | undo_savepoint SAVEPOINT | ROLLBACK [WORK] TO {$ENDIF FB15_UP} ); // TODO // alter ALTER -> DDL // create CREATE // drop DROP // grant GRANT // recreate RECREATE // replace CREATE OR ALTER // revoke REVOKE // set SET //****************************************************************************** // Abstract Class //****************************************************************************** const ScaleDivisor: array[-15..-1] of Int64 = (1000000000000000,100000000000000, 10000000000000,1000000000000,100000000000,10000000000,1000000000,100000000, 10000000,1000000,100000,10000,1000,100,10); type TSQLDA = class private FXSQLDA: PUIBSQLDa; function GetPointer: PUIBSQLDa; function GetAllocatedFields: Word; procedure SetAllocatedFields(Fields: Word); function GetActualFields: Word; function GetFieldCount: Integer; function GetSQLType(const Index: Word): Smallint; function GetSQLLen(const Index: Word): Smallint; function DecodeString(const Code: Smallint; Index: Word): String; overload; procedure DecodeString(const Code: Smallint; Index: Word; out Str: String); overload; procedure DecodeWideString(const Code: Smallint; Index: Word; out Str: WideString); protected function GetSqlName(const Index: Word): string; function GetRelName(const Index: Word): string; function GetOwnName(const Index: Word): string; function GetAliasName(const Index: Word): string; function GetIsNumeric(const Index: Word): boolean; function GetIsBlob(const Index: Word): boolean; function GetIsNull(const Index: Word): boolean; function GetIsNullable(const Index: Word): boolean; function GetAsDouble(const Index: Word): Double; function GetAsCurrency(const Index: Word): Currency; function GetAsInt64(const Index: Word): Int64; function GetAsInteger(const Index: Word): Integer; function GetAsSingle(const Index: Word): Single; function GetAsSmallint(const Index: Word): Smallint; function GetAsString(const Index: Word): String; virtual; function GetAsWideString(const Index: Word): WideString; virtual; function GetAsQuad(const Index: Word): TISCQuad; function GetAsVariant(const Index: Word): Variant; virtual; function GetAsDateTime(const Index: Word): TDateTime; function GetAsDate(const Index: Word): Integer; function GetAsTime(const Index: Word): Cardinal; function GetAsBoolean(const Index: Word): boolean; function GetByNameIsNumeric(const Name: String): boolean; function GetByNameIsBlob(const Name: String): boolean; function GetByNameIsNull(const Name: String): boolean; function GetByNameIsNullable(const Name: String): boolean; function GetByNameAsDouble(const Name: String): Double; function GetByNameAsCurrency(const Name: String): Currency; function GetByNameAsInt64(const Name: String): Int64; function GetByNameAsInteger(const Name: String): Integer; function GetByNameAsSingle(const Name: String): Single; function GetByNameAsSmallint(const Name: String): Smallint; function GetByNameAsString(const Name: String): String; function GetByNameAsWideString(const Name: String): WideString; function GetByNameAsQuad(const Name: String): TISCQuad; function GetByNameAsVariant(const Name: String): Variant; function GetByNameAsDateTime(const Name: String): TDateTime; function GetByNameAsBoolean(const Name: String): boolean; function GetByNameAsDate(const Name: String): Integer; function GetByNameAsTime(const Name: String): Cardinal; function GetFieldType(const Index: Word): TUIBFieldType; virtual; public procedure CheckRange(const Index: Word); function GetFieldIndex(const name: String): Word; virtual; property Data: PUIBSQLDa read FXSQLDA; property IsBlob[const Index: Word]: boolean read GetIsBlob; property IsNull[const Index: Word]: boolean read GetIsNull; property IsNullable[const Index: Word]: boolean read GetIsNullable; property IsNumeric[const Index: Word]: boolean read GetIsNumeric; property AsQuad [const Index: Word]: TISCQuad read GetAsQuad; property XSQLDA: PUIBSQLDa read GetPointer; property FieldCount: Integer read GetFieldCount; property SQLType[const Index: Word]: Smallint read GetSQLType; property SQLLen[const Index: Word]: Smallint read GetSQLLen; property FieldType[const Index: Word]: TUIBFieldType read GetFieldType; end; PPageInfo = ^TPageInfo; TPageInfo = packed record NextPage : Pointer; UsageCounter: Integer; end; TMemoryPool = class private FItemSize : Integer; FItemsInPage : Integer; FPageSize : Integer; FFirstPage : PPageInfo; FFreeList : Pointer; FList : TList; function GetCount: Integer; function GetItems(const Index: Integer): Pointer; procedure AddPage; procedure CleanFreeList(const PageStart : Pointer); public constructor Create(ItemSize, ItemsInPage : Integer); destructor Destroy; override; function New : Pointer; function PageCount : Integer; function PageUsageCount(const PageIndex : Integer) : Integer; procedure Dispose(var P: Pointer); function RemoveUnusedPages : Integer; property PageSize : Integer read FPageSize; property ItemsInPage : Integer read FItemsInPage; property ItemSize : Integer read FItemSize; property Items[const Index: Integer]: Pointer read GetItems; property Count: Integer read GetCount; end; TBlobData = packed record Size: Cardinal; Buffer: Pointer; end; TBlobDataArray = array[Word] of TBlobData; PBlobDataArray = ^TBlobDataArray; TSQLResult = class(TSQLDA) private FMemoryPool: TMemoryPool; FCachedFetch: boolean; FFetchBlobs: boolean; FDataBuffer: Pointer; FBlobArray: PBlobDataArray; FDataBufferLength: Word; FBlobsIndex: array of Word; FCurrentRecord: Integer; FBufferChunks: Cardinal; FScrollEOF: boolean; procedure AddCurrentRecord; procedure FreeBlobs(Buffer: Pointer); function GetRecordCount: Integer; function GetCurrentRecord: Integer; procedure AllocateDataBuffer; function GetBlobIndex(const Index: Word): Word; function GetEof: boolean; function GetUniqueRelationName: string; function GetBof: boolean; protected function GetAsString(const Index: Word): String; override; function GetAsWideString(const Index: Word): WideString; override; function GetAsVariant(const Index: Word): Variant; override; public constructor Create(Fields: SmallInt = 0; CachedFetch: Boolean = False; FetchBlobs: boolean = false; BufferChunks: Cardinal = 1000); destructor Destroy; override; procedure ClearRecords; procedure GetRecord(const Index: Integer); procedure SaveToStream(Stream: TStream); procedure LoadFromStream(Stream: TStream); procedure ReadBlob(const Index: Word; Stream: TStream); overload; procedure ReadBlob(const Index: Word; var str: string); overload; procedure ReadBlob(const Index: Word; var str: WideString); overload; procedure ReadBlob(const Index: Word; var Value: Variant); overload; procedure ReadBlob(const Index: Word; Data: Pointer); overload; procedure ReadBlob(const name: string; Stream: TStream); overload; procedure ReadBlob(const name: string; var str: string); overload; procedure ReadBlob(const name: string; var str: WideString); overload; procedure ReadBlob(const name: string; var Value: Variant); overload; procedure ReadBlob(const name: string; Data: Pointer); overload; function GetBlobSize(const Index: Word): Cardinal; property Eof: boolean read GetEof; property Bof: boolean read GetBof; property CachedFetch: boolean read FCachedFetch; property FetchBlobs: boolean read FFetchBlobs; property RecordCount: Integer read GetRecordCount; property CurrentRecord: Integer read GetCurrentRecord write GetRecord; property BufferChunks: Cardinal read FBufferChunks; property UniqueRelationName: string read GetUniqueRelationName; property SqlName[const Index: Word]: string read GetSqlName; property RelName[const Index: Word]: string read GetRelName; property OwnName[const Index: Word]: string read GetOwnName; property AliasName[const Index: Word]: string read GetAliasName; property AsSmallint [const Index: Word]: Smallint read GetAsSmallint; property AsInteger [const Index: Word]: Integer read GetAsInteger; property AsSingle [const Index: Word]: Single read GetAsSingle; property AsDouble [const Index: Word]: Double read GetAsDouble; property AsCurrency [const Index: Word]: Currency read GetAsCurrency; property AsInt64 [const Index: Word]: Int64 read GetAsInt64; property AsString [const Index: Word]: String read GetAsString; property AsWideString [const Index: Word]: WideString read GetAsWideString; property AsVariant [const Index: Word]: Variant read GetAsVariant; property AsDateTime [const Index: Word]: TDateTime read GetAsDateTime; property AsDate [const Index: Word]: Integer read GetAsDate; property AsTime [const Index: Word]: Cardinal read GetAsTime; property AsBoolean [const Index: Word]: Boolean read GetAsBoolean; property ByNameIsNull[const name: String]: boolean read GetByNameIsNull; property ByNameIsNullable[const name: String]: boolean read GetByNameIsNullable; property ByNameAsSmallint [const name: String]: Smallint read GetByNameAsSmallint; property ByNameAsInteger [const name: String]: Integer read GetByNameAsInteger; property ByNameAsSingle [const name: String]: Single read GetByNameAsSingle; property ByNameAsDouble [const name: String]: Double read GetByNameAsDouble; property ByNameAsCurrency [const name: String]: Currency read GetByNameAsCurrency; property ByNameAsInt64 [const name: String]: Int64 read GetByNameAsInt64; property ByNameAsString [const name: String]: String read GetByNameAsString; property ByNameAsWideString [const name: String]: WideString read GetByNameAsWideString; property ByNameAsQuad [const name: String]: TISCQuad read GetByNameAsQuad; property ByNameAsVariant [const name: String]: Variant read GetByNameAsVariant; property ByNameAsDateTime [const name: String]: TDateTime read GetByNameAsDateTime; property ByNameAsBoolean [const name: String]: Boolean read GetByNameAsBoolean; property ByNameAsDate [const name: String]: Integer read GetByNameAsDate; property ByNameAsTime [const name: String]: Cardinal read GetByNameAsTime; property Values[const name: String]: Variant read GetByNameAsVariant; default; end; TSQLResultClass = class of TSQLResult; TSQLParams = class(TSQLDA) private FParamCount: Word; procedure EncodeString(Code: Smallint; Index: Word; const str: String); procedure EncodeWideString(Code: Smallint; Index: Word; const str: WideString); function FindParam(const name: string; out Index: Word): boolean; function GetFieldName(const Index: Word): string; protected function AddField(const name: string): Word; procedure SetFieldType(const Index: Word; Size: Integer; Code: SmallInt; Scale: Smallint = 0); procedure SetIsNull(const Index: Word; const Value: boolean); procedure SetAsDouble(const Index: Word; const Value: Double); procedure SetAsCurrency(const Index: Word; const Value: Currency); procedure SetAsInt64(const Index: Word; const Value: Int64); procedure SetAsInteger(const Index: Word; const Value: Integer); procedure SetAsSingle(const Index: Word; const Value: Single); procedure SetAsSmallint(const Index: Word; const Value: Smallint); procedure SetAsString(const Index: Word; const Value: String); procedure SetAsWideString(const Index: Word; const Value: WideString); procedure SetAsQuad(const Index: Word; const Value: TISCQuad); procedure SetAsDateTime(const Index: Word; const Value: TDateTime); procedure SetAsBoolean(const Index: Word; const Value: Boolean); procedure SetAsDate(const Index: Word; const Value: Integer); procedure SetAsTime(const Index: Word; const Value: Cardinal); procedure SetByNameIsNull(const Name: String; const Value: boolean); procedure SetByNameAsDouble(const Name: String; const Value: Double); procedure SetByNameAsCurrency(const Name: String; const Value: Currency); procedure SetByNameAsInt64(const Name: String; const Value: Int64); procedure SetByNameAsInteger(const Name: String; const Value: Integer); procedure SetByNameAsSingle(const Name: String; const Value: Single); procedure SetByNameAsSmallint(const Name: String; const Value: Smallint); procedure SetByNameAsString(const Name: String; const Value: String); procedure SetByNameAsWideString(const Name: String; const Value: WideString); procedure SetByNameAsQuad(const Name: String; const Value: TISCQuad); procedure SetByNameAsDateTime(const Name: String; const Value: TDateTime); procedure SetByNameAsBoolean(const Name: String; const Value: boolean); procedure SetByNameAsDate(const Name: String; const Value: Integer); function GetFieldType(const Index: Word): TUIBFieldType; override; public constructor Create; destructor Destroy; override; procedure Clear; function Parse(const SQL: string): string; function GetFieldIndex(const name: String): Word; override; procedure AddFieldType(const Name: string; FieldType: TUIBFieldType; Scale: TScale = 1; Precision: byte = 0); property IsNull[const Index: Word]: boolean read GetIsNull write SetIsNull; property AsSmallint [const Index: Word]: Smallint read GetAsSmallint write SetAsSmallint; property AsInteger [const Index: Word]: Integer read GetAsInteger write SetAsInteger; property AsSingle [const Index: Word]: Single read GetAsSingle write SetAsSingle; property AsDouble [const Index: Word]: Double read GetAsDouble write SetAsDouble; property AsCurrency [const Index: Word]: Currency read GetAsCurrency write SetAsCurrency; property AsInt64 [const Index: Word]: Int64 read GetAsInt64 write SetAsInt64; property AsString [const Index: Word]: String read GetAsString write SetAsString; property AsWideString [const Index: Word]: WideString read GetAsWideString write SetAsWideString; property AsQuad [const Index: Word]: TISCQuad read GetAsQuad write SetAsQuad; property AsDateTime [const Index: Word]: TDateTime read GetAsDateTime write SetAsDateTime; property AsBoolean [const Index: Word]: Boolean read GetAsBoolean write SetAsBoolean; property AsDate [const Index: Word]: Integer read GetAsDate write SetAsDate; property AsTime [const Index: Word]: Cardinal read GetAsTime write SetAsTime; property ByNameIsNull[const name: String]: boolean read GetByNameIsNull write SetByNameIsNull; property ByNameAsSmallint [const name: String]: Smallint read GetByNameAsSmallint write SetByNameAsSmallint; property ByNameAsInteger [const name: String]: Integer read GetByNameAsInteger write SetByNameAsInteger; property ByNameAsSingle [const name: String]: Single read GetByNameAsSingle write SetByNameAsSingle; property ByNameAsDouble [const name: String]: Double read GetByNameAsDouble write SetByNameAsDouble; property ByNameAsCurrency [const name: String]: Currency read GetByNameAsCurrency write SetByNameAsCurrency; property ByNameAsInt64 [const name: String]: Int64 read GetByNameAsInt64 write SetByNameAsInt64; property ByNameAsString [const name: String]: String read GetByNameAsString write SetByNameAsString; property ByNameAsWideString [const name: String]: WideString read GetByNameAsWideString write SetByNameAsWideString; property ByNameAsQuad [const name: String]: TISCQuad read GetByNameAsQuad write SetByNameAsQuad; property ByNameAsVariant [const name: String]: Variant read GetByNameAsVariant; property ByNameAsDateTime [const name: String]: TDateTime read GetByNameAsDateTime write SetByNameAsDateTime; property ByNameAsBoolean [const name: String]: Boolean read GetByNameAsBoolean write SetByNameAsBoolean; property ByNameAsDate [const name: String]: Integer read GetByNameAsDate write SetByNameAsDate; property Values[const name: String]: Variant read GetByNameAsVariant; default; property FieldName[const Index: Word]: string read GetFieldName; property ParamCount : Word read FParamCount; end; TSQLParamsClass = class of TSQLParams; type TDSQLInfoData = packed record InfoCode: byte; InfoLen : Word; // isc_portable_integer convert a SmallInt to Word ??? so just say it is a word case byte of isc_info_sql_stmt_type: (StatementType: TUIBStatementType); isc_info_sql_get_plan : (PlanDesc : array[0..255] of Char); end; {$IFDEF IB7_UP} TArrayDesc = TISCArrayDescV2; TBlobDesc = TISCBlobDescV2; {$ELSE} TArrayDesc = TISCArrayDesc; TBlobDesc = TISCBlobDesc; {$ENDIF IB7_UP} TUIBLibrary = class; TStatusVector = array[0..19] of ISCStatus; PStatusVector = ^TStatusVector; TOnConnectionLost = procedure(Lib: TUIBLibrary) of object; TOnGetDBExceptionClass = procedure(Number: Integer; out Excep: EUIBExceptionClass) of object; TUIBLibrary = class(TUIBaseLibrary) private FStatusVector: TStatusVector; FOnConnectionLost: TOnConnectionLost; FOnGetDBExceptionClass: TOnGetDBExceptionClass; FRaiseErrors: boolean; FSegmentSize: Word; function GetSegmentSize: Word; procedure SetSegmentSize(Value: Word); procedure CheckUIBApiCall(const Status: ISCStatus); public constructor Create; override; property OnConnectionLost: TOnConnectionLost read FOnConnectionLost write FOnConnectionLost; property OnGetDBExceptionClass: TOnGetDBExceptionClass read FOnGetDBExceptionClass write FOnGetDBExceptionClass; property RaiseErrors: boolean read FRaiseErrors write FRaiseErrors default True; {Attaches to an existing database. Ex: AttachDatabase('c:\DataBase.gdb', DBHandle, 'user_name=SYSDBA; password=masterkey'); } procedure AttachDatabase(FileName: String; var DbHandle: IscDbHandle; Params: String; Sep: Char = ';'); {Detaches from a database previously connected with AttachDatabase.} procedure DetachDatabase(var DBHandle: IscDbHandle); procedure TransactionStart(var TraHandle: IscTrHandle; var DbHandle: IscDbHandle; const TPB: string = ''); procedure TransactionStartMultiple(var TraHandle: IscTrHandle; DBCount: Smallint; Vector: PISCTEB); procedure TransactionCommit(var TraHandle: IscTrHandle); procedure TransactionRollback(var TraHandle: IscTrHandle); procedure TransactionCommitRetaining(var TraHandle: IscTrHandle); procedure TransactionPrepare(var TraHandle: IscTrHandle); procedure TransactionRollbackRetaining(var TraHandle: IscTrHandle); procedure DSQLExecuteImmediate(var DBHandle: IscDbHandle; var TraHandle: IscTrHandle; const Statement: string; Dialect: Word; Sqlda: TSQLDA = nil); overload; procedure DSQLExecuteImmediate(const Statement: string; Dialect: Word; Sqlda: TSQLDA = nil); overload; procedure DSQLAllocateStatement(var DBHandle: IscDbHandle; var StmtHandle: IscStmtHandle); function DSQLPrepare(var TraHandle: IscTrHandle; var StmtHandle: IscStmtHandle; Statement: string; Dialect: Word; Sqlda: TSQLResult = nil): TUIBStatementType; procedure DSQLExecute(var TraHandle: IscTrHandle; var StmtHandle: IscStmtHandle; Dialect: Word; Sqlda: TSQLParams = nil); procedure DSQLExecute2(var TraHandle: IscTrHandle; var StmtHandle: IscStmtHandle; Dialect: Word; InSqlda: TSQLParams; OutSqlda: TSQLResult); procedure DSQLFreeStatement(var StmtHandle: IscStmtHandle; Option: Word); function DSQLFetch(var StmtHandle: IscStmtHandle; Dialect: Word; Sqlda: TSQLResult): boolean; function DSQLFetchWithBlobs(var DBHhandle: IscDbHandle; var TraHandle: IscTrHandle; var StmtHandle: IscStmtHandle; Dialect: Word; Sqlda: TSQLResult): boolean; procedure DSQLDescribe(var StmtHandle: IscStmtHandle; Dialect: Word; Sqlda: TSQLResult); procedure DSQLDescribeBind(var StmtHandle: IscStmtHandle; Dialect: Word; Sqlda: TSQLDA); procedure DSQLSetCursorName(var StmtHandle: IscStmtHandle; const cursor: string); procedure DSQLExecImmed2(var DBHhandle: IscDbHandle; var TraHandle: IscTrHandle; const Statement: string; dialect: Word; InSqlda, OutSqlda: TSQLDA); procedure DSQLInfo(var StmtHandle: IscStmtHandle; const Items: array of byte; var buffer: String); function DSQLInfoPlan(var StmtHandle: IscStmtHandle): string; function DSQLInfoStatementType(var StmtHandle: IscStmtHandle): TUIBStatementType; function DSQLInfoRowsAffected(var StmtHandle: IscStmtHandle; StatementType: TUIBStatementType): Cardinal; procedure DDLExecute(var DBHandle: IscDbHandle; var TraHandle: IscTrHandle; const ddl: string); function ArrayLookupBounds(var DBHandle: IscDbHandle; var TransHandle: IscTrHandle; const RelationName, FieldName: String): TArrayDesc; procedure ArrayGetSlice(var DBHandle: IscDbHandle; var TransHandle: IscTrHandle; ArrayId: TISCQuad; var desc: TArrayDesc; DestArray: PPointer; var SliceLength: Integer); procedure ArrayPutSlice(var DBHandle: IscDbHandle; var TransHandle: IscTrHandle; var ArrayId: TISCQuad; var desc: TArrayDesc; DestArray: PPointer; var SliceLength: Integer); procedure ServiceAttach(const ServiceName: string; var SvcHandle: IscSvcHandle; const Spb: string); procedure ServiceDetach(var SvcHandle: IscSvcHandle); procedure ServiceQuery(var SvcHandle: IscSvcHandle; const SendSpb, RequestSpb: string; var Buffer: string); procedure ServiceStart(var SvcHandle: IscSvcHandle; const Spb: string); function ErrSqlcode: ISCLong; function ErrInterprete: String; function ErrSQLInterprete(SQLCODE: Smallint): String; procedure BlobOpen(var DBHandle: IscDbHandle; var TraHandle: IscTrHandle; var BlobHandle: IscBlobHandle; BlobId: TISCQuad; BPB: string = ''); function BlobGetSegment(var BlobHandle: IscBlobHandle; out length: Word; BufferLength: Cardinal; Buffer: PChar): boolean; procedure BlobClose(var BlobHandle: IscBlobHandle); procedure BlobInfo(var BlobHandle: IscBlobHandle; out NumSegments, MaxSegment, TotalLength: Cardinal; out btype : byte); procedure BlobSize(var BlobHandle: IscBlobHandle; out Size: Cardinal); procedure BlobMaxSegment(var BlobHandle: IscBlobHandle; out Size: Cardinal); procedure BlobDefaultDesc(var Desc: TBlobDesc; const RelationName, FieldName: string); procedure BlobSaveToStream(var BlobHandle: IscBlobHandle; Stream: TStream); function BlobReadString(var BlobHandle: IscBlobHandle): string; overload; procedure BlobReadString(var BlobHandle: IscBlobHandle; var Str: String); overload; procedure BlobReadVariant(var BlobHandle: IscBlobHandle; var Value: Variant); // you must free memory allocated by this method !! procedure BlobReadBuffer(var BlobHandle: IscBlobHandle; var Size: Cardinal; var Buffer: Pointer); // the buffer size if known and Pointer allocated. procedure BlobReadSizedBuffer(var BlobHandle: IscBlobHandle; Buffer: Pointer); overload; // DBexpress and SP: the component set the max blob size procedure BlobReadSizedBuffer(var BlobHandle: IscBlobHandle; Buffer: Pointer; MaxSize: Cardinal); overload; function BlobCreate(var DBHandle: IscDbHandle; var TraHandle: IscTrHandle; var BlobHandle: IscBlobHandle; BPB: string = ''): TISCQuad; procedure BlobWriteSegment(var BlobHandle: IscBlobHandle; BufferLength: Cardinal; Buffer: PChar); procedure BlobWriteString(var BlobHandle: IscBlobHandle; var Str: String); procedure BlobWriteStream(var BlobHandle: IscBlobHandle; Stream: TStream); function StreamBlobOpen(var BlobId: TISCQuad; var Database: IscDbHandle; var Transaction: IscTrHandle; mode: Char): PBStream; function StreamBlobClose(Stream: PBStream): integer; {$IFDEF IB71_UP} procedure SavepointRelease(var TrHandle: IscTrHandle; const Name: string); procedure SavepointRollback(var TrHandle: IscTrHandle; const Name: string; Option: Word); procedure SavepointStart(var TrHandle: IscTrHandle; const Name: string); {$ENDIF IB71_UP} property SegMentSize: Word read GetSegmentSize write SetSegmentSize; end; //****************************************************************************** // Conversion //****************************************************************************** procedure DecodeTimeStamp(v: PISCTimeStamp; out DateTime: Double); overload; procedure DecodeTimeStamp(v: PISCTimeStamp; out TimeStamp: TTimeStamp); overload; function DecodeTimeStamp(v: PISCTimeStamp): Double; overload; procedure EncodeTimeStamp(const DateTime: TDateTime; v: PISCTimeStamp); overload; procedure EncodeTimeStamp(const Date: Integer; v: PISCTimeStamp); overload; procedure EncodeTimeStamp(const Time: Cardinal; v: PISCTimeStamp); overload; procedure DecodeSQLDate(v: Integer; out Year: SmallInt; out Month, Day: Word); overload; procedure DecodeSQLDate(const v: Integer; out Date: Double); overload; procedure DecodeSQLDate(const v: Integer; out Date: Integer); overload; function DecodeSQLDate(const v: Integer): Integer; overload; procedure EncodeSQLDate(date: TDateTime; out v: Integer); overload; procedure EncodeSQLDate(date: Integer; out v: Integer); overload; procedure EncodeSQLDate(Year: SmallInt; Month, Day: Word; out v: Integer); overload; procedure DecodeSQLTime(v: Cardinal; out Hour, Minute, Second: Word; out Fractions: LongWord); procedure EncodeSQLTime(const Hour, Minute, Second: Word; const Fractions: LongWord; out v: Cardinal); //****************************************************************************** // Event functions //****************************************************************************** // function isc_cancel_events // function isc_que_events // function isc_wait_for_event // procedure isc_event_counts // function isc_event_block //****************************************************************************** // Security //****************************************************************************** // function isc_add_user // function isc_delete_user // function isc_modify_user //****************************************************************************** // Other //****************************************************************************** // function isc_compile_request // function isc_compile_request2 // function isc_ddl // function isc_prepare // function isc_receive // function isc_reconnect_transaction // function isc_release_request // function isc_request_info // function isc_seek_blob // function isc_send // function isc_start_and_send // function isc_start_request // function isc_transact_request // function isc_unwind_request //****************************************************************************** // //****************************************************************************** // function isc_ftof // function isc_free // function isc_print_blr // procedure isc_qtoq // procedure isc_set_debug // procedure isc_vtof // procedure isc_vtov // {$IFDEF FB15} // function isc_reset_fpe // {$ENDIF} // {$IFDEF IB7_UP} // procedure isc_get_client_version // function isc_get_client_major_version // function isc_get_client_minor_version // {$ENDIF} type TParamType = ( prNone, // no param prByte, // Byte Param prCard, // Cardinal Param prStrg, // String Param prIgno // Ignore Command ); TDPBInfo = record Name : String; ParamType : TParamType; end; const DPBInfos : array[1..isc_dpb_Max_Value] of TDPBInfo = ((Name: 'cdd_pathname'; ParamType: prIgno), // not implemented (Name: 'allocation'; ParamType: prIgno), // not implemented (Name: 'journal'; ParamType: prIgno), // not implemented (Name: 'page_size'; ParamType: prCard), // ok (Name: 'num_buffers'; ParamType: prCard), // ok (Name: 'buffer_length'; ParamType: prIgno), // not implemented (Name: 'debug'; ParamType: prCard), // ok (Name: 'garbage_collect'; ParamType: prIgno), // not implemented (Name: 'verify'; ParamType: prCard), // ok (Name: 'sweep'; ParamType: prCard), // ok (Name: 'enable_journal'; ParamType: prStrg), // ok (Name: 'disable_journal'; ParamType: prNone), // ok (Name: 'dbkey_scope'; ParamType: prCard), // ok (Name: 'number_of_users'; ParamType: prIgno), // not implemented (Name: 'trace'; ParamType: prNone), // ok (Name: 'no_garbage_collect'; ParamType: prIgno), // not implemented (Name: 'damaged'; ParamType: prNone), // ok (Name: 'license'; ParamType: prStrg), (Name: 'sys_user_name'; ParamType: prStrg), // ok (Name: 'encrypt_key'; ParamType: prStrg), // ok (Name: 'activate_shadow'; ParamType: prNone), // ok deprecated (Name: 'sweep_interval'; ParamType: prCard), // ok (Name: 'delete_shadow'; ParamType: prNone), // ok (Name: 'force_write'; ParamType: prCard), // ok (Name: 'begin_log'; ParamType: prStrg), // ok (Name: 'quit_log'; ParamType: prNone), // ok (Name: 'no_reserve'; ParamType: prCard), // ok (Name: 'user_name'; ParamType: prStrg), // ok (Name: 'password'; ParamType: prStrg), // ok (Name: 'password_enc'; ParamType: prStrg), // ok (Name: 'sys_user_name_enc'; ParamType: prNone), (Name: 'interp'; ParamType: prCard), // ok (Name: 'online_dump'; ParamType: prCard), // ok (Name: 'old_file_size'; ParamType: prCard), // ok (Name: 'old_num_files'; ParamType: prCard), // ok (Name: 'old_file'; ParamType: prStrg), // ok (Name: 'old_start_page'; ParamType: prCard), // ok (Name: 'old_start_seqno'; ParamType: prCard), // ok (Name: 'old_start_file'; ParamType: prCard), // ok (Name: 'drop_walfile'; ParamType: prCard), // ok (Name: 'old_dump_id'; ParamType: prCard), // ok (Name: 'wal_backup_dir'; ParamType: prStrg), // ok (Name: 'wal_chkptlen'; ParamType: prCard), // ok (Name: 'wal_numbufs'; ParamType: prCard), // ok (Name: 'wal_bufsize'; ParamType: prCard), // ok (Name: 'wal_grp_cmt_wait'; ParamType: prCard), // ok (Name: 'lc_messages'; ParamType: prStrg), // ok (Name: 'lc_ctype'; ParamType: prStrg), // ok (Name: 'cache_manager'; ParamType: prIgno), // not used in fb1.5 (Name: 'shutdown'; ParamType: prCard), // ok (Name: 'online'; ParamType: prNone), // ok (Name: 'shutdown_delay'; ParamType: prCard), // ok (Name: 'reserved'; ParamType: prStrg), // ok (Name: 'overwrite'; ParamType: prCard), // ok (Name: 'sec_attach'; ParamType: prCard), // ok (Name: 'disable_wal'; ParamType: prNone), // ok (Name: 'connect_timeout'; ParamType: prCard), // ok (Name: 'dummy_packet_interval'; ParamType: prCard), // ok (Name: 'gbak_attach'; ParamType: prStrg), // ok (Name: 'sql_role_name'; ParamType: prStrg), // ok rolename (Name: 'set_page_buffers'; ParamType: prCard), // ok Change age buffer 50 >= buf >= 65535 (default 2048) (Name: 'working_directory'; ParamType: prStrg), // ok (Name: 'sql_dialect'; ParamType: prCard), // ok Set SQL Dialect for this connection (1,2,3) (Name: 'set_db_readonly'; ParamType: prCard), // ok (Name: 'set_db_sql_dialect'; ParamType: prCard), // ok Change sqldialect (1,2,3)) (Name: 'gfix_attach'; ParamType: prNone), // ok FB15: don't work (Name: 'gstat_attach'; ParamType: prNone) // ok FB15: don't work {$IFDEF IB65ORYF867} ,(Name: 'gbak_ods_version'; ParamType: prCard) // ?? ,(Name: 'gbak_ods_minor_version'; ParamType: prCard) // ?? {$ENDIF IB65ORYF867} {$IFDEF YF867_UP} ,(Name: 'numeric_scale_reduction';ParamType: prNone) {$ENDIF YF867_UP} {$IFDEF IB7_UP} ,(Name: 'set_group_commit'; ParamType: prNone) // ?? {$ENDIF IB7_UP} {$IFDEF IB71_UP} ,(Name: 'gbak_validate'; ParamType: prNone) // ?? {$ENDIF IB71_UP} {$IFDEF FB103_UP} ,(Name: 'set_db_charset'; ParamType: prStrg) // ok {$ENDIF FB103_UP} ); {$IFNDEF COMPILER6_UP} function TryStrToInt(const S: string; out Value: Integer): Boolean; {$ENDIF !COMPILER6_UP} {$IFDEF USEJVCL} {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/tags/JVCL3_32/run/JvUIBLib.pas $'; Revision: '$Revision: 10612 $'; Date: '$Date: 2006-05-19 21:04:09 +0200 (ven., 19 mai 2006) $'; LogPath: 'JVCL\run' ); {$ENDIF UNITVERSIONING} {$ENDIF USEJVCL} implementation uses JvUIBConst; { EUIBParser } constructor EUIBParser.Create(Line, Character: Integer; dummyForBCB : Integer); begin FLine := Line; FCharacter := Character; Message := format('Parse error Line %d, Char %d', [FLine, FCharacter]); end; //****************************************************************************** // Errors handling //****************************************************************************** {$IFNDEF COMPILER6_UP} function TryStrToInt(const S: string; out Value: Integer): Boolean; var E: Integer; begin Val(S, Value, E); Result := E = 0; end; {$ENDIF !COMPILER6_UP} const ISC_MASK = $14000000; // Defines the code as a valid ISC code FAC_MASK = $00FF0000; // Specifies the facility where the code is located CODE_MASK = $0000FFFF; // Specifies the code in the message file CLASS_MASK = $F0000000; // Defines the code as warning, error, info, or other // Note: Perhaps a debug level could be interesting !!! CLASS_ERROR = 0; // Code represents an error CLASS_WARNING = 1; // Code represents a warning CLASS_INFO = 2; // Code represents an information msg //FACILITY FAC_CODE MAX_NUMBER LAST_CHANGE FAC_JRD = 0; // 501 26/10/2002 17:02:13 <- In Use FAC_QLI = 1; // 509 07/11/1996 13:38:37 FAC_GDEF = 2; // 345 07/11/1996 13:38:37 FAC_GFIX = 3; // 114 25/12/2001 02:59:17 <- In Use FAC_GPRE = 4; // 1 07/11/1996 13:39:40 FAC_GLTJ = 5; // 1 07/11/1996 13:39:40 FAC_GRST = 6; // 1 07/11/1996 13:39:40 FAC_DSQL = 7; // 15 22/07/2001 23:26:58 <- In Use FAC_DYN = 8; // 215 01/07/2001 17:43:07 <- In Use FAC_FRED = 9; // 1 07/11/1996 13:39:40 FAC_INSTALL = 10; // 1 07/11/1996 13:39:40 FAC_TEST = 11; // 4 07/11/1996 13:38:41 FAC_GBAK = 12; // 283 05/03/2002 02:38:49 <- In Use FAC_SQLERR = 13; // 917 05/03/2002 02:55:22 FAC_SQLWARN = 14; // 102 07/11/1996 13:38:42 FAC_JRD_BUGCHK = 15; // 305 05/03/2002 02:29:03 FAC_GJRN = 16; // 241 07/11/1996 13:38:43 FAC_ISQL = 17; // 109 10/10/2001 03:27:43 FAC_GSEC = 18; // 91 04/11/1998 11:06:15 <- In Use FAC_LICENSE = 19; // 60 05/03/2002 02:30:12 <- In Use FAC_DOS = 20; // 74 05/03/2002 02:31:54 FAC_GSTAT = 21; // 36 10/10/2001 18:05:16 <- In Use function GetFacility(code: ISCStatus): Word; begin Result := (code and FAC_MASK) shr 16; end; function GetClass(code: ISCStatus): Word; begin Result := (code and CLASS_MASK) shr 30; end; function GETCode(code: ISCStatus): Word; begin Result := (code and CODE_MASK) shr 0; end; procedure TUIBLibrary.CheckUIBApiCall(const Status: ISCStatus); var Exception: EUIBError; Number: Integer; Excep: EUIBExceptionClass; begin if (Status <> 0) and FRaiseErrors then if (GetClass(Status) = CLASS_ERROR) then // only raise CLASS_ERROR begin case GetFacility(Status) of FAC_JRD : if Status = isc_except then begin Number := FStatusVector[3]; if assigned(FOnGetDBExceptionClass) then begin FOnGetDBExceptionClass(Number, Excep); Exception := Excep.Create(ErrInterprete) end else Exception := EUIBException.Create(ErrInterprete); EUIBException(Exception).FNumber := Number; end else Exception := EUIBError.Create(ErrInterprete); FAC_GFIX : Exception := EUIBGFIXError.Create(ErrInterprete); FAC_DSQL : Exception := EUIBDSQLError.Create(ErrInterprete); FAC_DYN : Exception := EUIBDYNError.Create(ErrInterprete); FAC_GBAK : Exception := EUIBGBAKError.Create(ErrInterprete); FAC_GSEC : Exception := EUIBGSECError.Create(ErrInterprete); FAC_LICENSE : Exception := EUIBLICENSEError.Create(ErrInterprete); FAC_GSTAT : Exception := EUIBGSTATError.Create(ErrInterprete); else Exception := EUIBError.Create(ErrInterprete); end; Exception.FSQLCode := ErrSqlcode; if Exception.FSQLCode <> 0 then Exception.Message := Exception.Message + ErrSQLInterprete(Exception.FSQLCode) + BreakLine; Exception.FErrorCode := GETCode(Status); Exception.Message := Exception.Message + 'Error Code: ' + IntToStr(Exception.FErrorCode); if (Exception.FErrorCode = 401) and Assigned(FOnConnectionLost) then FOnConnectionLost(Self); raise Exception; end; end; //****************************************************************************** // Database //****************************************************************************** constructor TUIBLibrary.Create; begin inherited; FRaiseErrors := True; FSegmentSize := 16*1024; end; function GetClientLibrary: string; {$IFDEF DLLREGISTRY} var Key: HKEY; Size: Cardinal; HR: Integer; {$ENDIF DLLREGISTRY} begin {$IFDEF DLLREGISTRY} HR := RegOpenKeyEx(HKEY_LOCAL_MACHINE, FBINSTANCES, 0, KEY_READ, Key); if (HR = ERROR_SUCCESS) then begin HR := RegQueryValueEx(Key, 'DefaultInstance', nil, nil, nil, @Size); if (HR = ERROR_SUCCESS) then begin SetLength(Result, Size); HR := RegQueryValueEx(Key, 'DefaultInstance', nil, nil, Pointer(Result), @Size); if (HR = ERROR_SUCCESS) then Result := Trim(Result)+ 'bin\' + GDS32DLL; end; RegCloseKey(Key); end; if (HR <> ERROR_SUCCESS) then {$ENDIF DLLREGISTRY} Result := GDS32DLL; end; function CreateDBParams(Params: String; Delimiter: Char = ';'): string; var BufferSize: Integer; CurPos, NextPos: PChar; CurStr, CurValue: String; EqualPos: Integer; Code: Byte; AValue: Integer; FinalSize: Integer; function Min(v1, v2: Integer): Integer; begin if v1 > v2 then Result := v2 else Result := v1; end; // dont reallocate memory each time, step by step ... procedure CheckBufferSize; begin while (FinalSize > BufferSize) do begin Inc(BufferSize, 32); SetLength(Result, BufferSize); end; end; procedure AddByte(AByte: Byte); begin inc(FinalSize); CheckBufferSize; Result[FinalSize] := chr(AByte); end; procedure AddWord(AWord: Word); begin inc(FinalSize,2); CheckBufferSize; PWord(@Result[FinalSize-1])^ := AWord; end; procedure AddCard(ACard: Cardinal); begin case ACard of 0 .. 255 : begin AddByte(1); AddByte(Byte(ACard)) end; 256.. 65535 : begin AddByte(2); AddWord(Word(ACard)) end; else AddByte(4); inc(FinalSize,4); CheckBufferSize; PCardinal(@Result[FinalSize-3])^ := ACard; end; end; procedure AddString(var AString: String); var l: Integer; begin l := Min(Length(AString), 255); inc(FinalSize,l+1); CheckBufferSize; Result[FinalSize-l] := chr(l); Move(PChar(AString)^, Result[FinalSize-l+1], l); end; begin FinalSize := 1; BufferSize := 32; SetLength(Result, BufferSize); Result[1] := chr(isc_dpb_version1); CurPos := PChar(Params); while (CurPos <> nil) do begin NextPos := StrScan(CurPos, Delimiter); if (NextPos = nil) then CurStr := CurPos else begin CurStr := Copy(CurPos, 0, NextPos-CurPos); Inc(NextPos); end; CurPos := NextPos; if (CurStr = '') then Continue; begin CurValue := ''; EqualPos := Pos('=', CurStr); if EqualPos <> 0 then begin CurValue := Copy(CurStr, EqualPos+1, Length(CurStr) - EqualPos); CurStr := Copy(CurStr, 0, EqualPos-1); end; CurStr := Trim(LowerCase(CurStr)); CurValue := Trim(CurValue); for Code := 1 to isc_dpb_Max_Value do with DPBInfos[Code] do if (Name = CurStr) then begin case ParamType of prNone : AddByte(Code); prByte : if TryStrToInt(CurValue, AValue) and (AValue >= 0) and (AValue <= 255) then begin AddByte(Code); AddByte(Byte(AValue)); end; prCard : if TryStrToInt(CurValue, AValue) and (AValue > 0) then begin AddByte(Code); AddCard(AValue); end; prStrg : if (Length(CurValue) > 0) then begin AddByte(Code); AddString(CurValue) end; end; break; end; end; end; SetLength(Result, FinalSize); end; procedure TUIBLibrary.AttachDatabase(FileName: String; var DbHandle: IscDbHandle; Params: String; Sep: Char = ';'); begin Params := CreateDBParams(Params, Sep); Lock; try CheckUIBApiCall(isc_attach_database(@FStatusVector, Length(FileName), Pointer(FileName), @DBHandle, Length(Params), PChar(Params))); finally UnLock; end; end; procedure TUIBLibrary.DetachDatabase(var DBHandle: IscDbHandle); begin Lock; try CheckUIBApiCall(isc_detach_database(@FStatusVector, @DBHandle)); // if connection lost DBHandle must be set manually to nil. DBHandle := nil; finally UnLock; end; end; function StrToCharacterSet(const CharacterSet: string): TCharacterSet; var len: Integer; begin len := length(CharacterSet); for Result := low(TCharacterSet) to High(TCharacterSet) do if (len = Length(CharacterSetStr[Result])) and (CompareText(CharacterSetStr[Result], CharacterSet) = 0) then Exit; raise Exception.CreateFmt(EUIB_CHARSETNOTFOUND, [CharacterSet]); end; //****************************************************************************** // Transaction //****************************************************************************** procedure TUIBLibrary.TransactionStart(var TraHandle: IscTrHandle; var DbHandle: IscDbHandle; const TPB: string = ''); var Vector: TISCTEB; begin Vector.Handle := @DbHandle; Vector.Len := Length(TPB); Vector.Address := PChar(TPB); TransactionStartMultiple(TraHandle, 1, @Vector); end; procedure TUIBLibrary.TransactionStartMultiple(var TraHandle: IscTrHandle; DBCount: Smallint; Vector: PISCTEB); begin Lock; try CheckUIBApiCall(isc_start_multiple(@FStatusVector, @TraHandle, DBCount, Vector)); finally UnLock; end; end; procedure TUIBLibrary.TransactionCommit(var TraHandle: IscTrHandle); begin Lock; try CheckUIBApiCall(isc_commit_transaction(@FStatusVector, @TraHandle)); // if connection lost TraHandle must be set manually to nil. TraHandle := nil; finally UnLock; end; end; procedure TUIBLibrary.TransactionRollback(var TraHandle: IscTrHandle); begin Lock; try CheckUIBApiCall(isc_rollback_transaction(@FStatusVector, @TraHandle)); // if connection lost TraHandle must be set manually to nil. TraHandle := nil; finally UnLock; end; end; procedure TUIBLibrary.TransactionCommitRetaining(var TraHandle: IscTrHandle); begin Lock; try CheckUIBApiCall(isc_commit_retaining(@FStatusVector, @TraHandle)); finally UnLock; end; end; procedure TUIBLibrary.TransactionPrepare(var TraHandle: IscTrHandle); begin Lock; try CheckUIBApiCall(isc_prepare_transaction(@FStatusVector, @TraHandle)); finally UnLock; end; end; procedure TUIBLibrary.TransactionRollbackRetaining(var TraHandle: IscTrHandle); begin Lock; try CheckUIBApiCall(isc_rollback_retaining(@FStatusVector, @TraHandle)); finally UnLock; end; end; //****************************************************************************** // DSQL //****************************************************************************** function GetSQLDAData(SQLDA: TSQLDA): Pointer; begin if (SQLDA <> nil) then Result := SQLDA.FXSQLDA else Result := nil; end; //**************************************** // API CALLS //**************************************** procedure TUIBLibrary.DSQLExecuteImmediate(var DBHandle: IscDbHandle; var TraHandle: IscTrHandle; const Statement: string; Dialect: Word; Sqlda: TSQLDA = nil); begin Lock; try CheckUIBApiCall(isc_dsql_execute_immediate(@FStatusVector, @DBHandle, @TraHandle, length(Statement), Pointer(Statement), Dialect, GetSQLDAData(Sqlda))); finally UnLock; end; end; procedure TUIBLibrary.DSQLExecuteImmediate(const Statement: string; Dialect: Word; Sqlda: TSQLDA = nil); var p: pointer; begin Lock; try p := nil; CheckUIBApiCall(isc_dsql_execute_immediate(@FStatusVector, @p, @p, length(Statement), Pointer(Statement), Dialect, GetSQLDAData(Sqlda))); finally UnLock; end; end; procedure TUIBLibrary.DSQLAllocateStatement(var DBHandle: IscDbHandle; var StmtHandle: IscStmtHandle); begin Lock; try CheckUIBApiCall(isc_dsql_allocate_statement(@FStatusVector, @DBHandle, @StmtHandle)); finally UnLock; end; end; function TUIBLibrary.DSQLPrepare(var TraHandle: IscTrHandle; var StmtHandle: IscStmtHandle; Statement: string; Dialect: Word; Sqlda: TSQLResult = nil): TUIBStatementType; var STInfo: packed record InfoCode: byte; InfoLen : Word; // isc_portable_integer convert a SmallInt to Word ??? so just say it is a word InfoType: TUIBStatementType; InfoIn: byte; end; begin Lock; try CheckUIBApiCall(isc_dsql_prepare(@FStatusVector, @TraHandle, @StmtHandle, Length(Statement), PChar(Statement), Dialect, GetSQLDAData(Sqlda))); STInfo.InfoIn := isc_info_sql_stmt_type; isc_dsql_sql_info(@FStatusVector, @StmtHandle, 1, @STInfo.InfoIn, SizeOf(STInfo), @STInfo); dec(STInfo.InfoType); Result := STInfo.InfoType; finally UnLock; end; if (Sqlda <> nil) then begin Sqlda.ClearRecords; if (Sqlda.GetActualFields <> Sqlda.GetAllocatedFields) then begin Sqlda.SetAllocatedFields(Sqlda.FXSQLDA.sqld); DSQLDescribe(StmtHandle, Dialect, Sqlda); end else Sqlda.AllocateDataBuffer; end; end; procedure TUIBLibrary.DSQLExecute(var TraHandle: IscTrHandle; var StmtHandle: IscStmtHandle; Dialect: Word; Sqlda: TSQLParams = nil); begin Lock; try CheckUIBApiCall(isc_dsql_execute(@FStatusVector, @TraHandle, @StmtHandle, Dialect, GetSQLDAData(Sqlda))); finally UnLock; end; end; procedure TUIBLibrary.DSQLExecute2(var TraHandle: IscTrHandle; var StmtHandle: IscStmtHandle; Dialect: Word; InSqlda: TSQLParams; OutSqlda: TSQLResult); begin Lock; try CheckUIBApiCall(isc_dsql_execute2(@FStatusVector, @TraHandle, @StmtHandle, Dialect, GetSQLDAData(InSqlda), GetSQLDAData(OutSqlda))); finally UnLock; end; end; procedure TUIBLibrary.DSQLFreeStatement(var StmtHandle: IscStmtHandle; Option: Word); begin Lock; try CheckUIBApiCall(isc_dsql_free_statement(@FStatusVector, @StmtHandle, Option)); // if connection lost StmtHandle must be set manually to nil. if option = DSQL_DROP then StmtHandle := nil; finally UnLock; end; end; function TUIBLibrary.DSQLFetch(var StmtHandle: IscStmtHandle; Dialect: Word; Sqlda: TSQLResult): boolean; var Status: ISCStatus; begin Result := True; if (Sqlda <> nil) then Sqlda.FScrollEOF := False; Lock; try Status := isc_dsql_fetch(@FStatusVector, @StmtHandle, Dialect, GetSQLDAData(Sqlda)); finally UnLock; end; case Status of 0 : if (Sqlda <> nil) then if Sqlda.FCachedFetch then Sqlda.AddCurrentRecord; 100 : begin Result := False; // end of fetch if (Sqlda <> nil) then begin Sqlda.FScrollEOF := True; end; end; else CheckUIBApiCall(Status); end; end; function TUIBLibrary.DSQLFetchWithBlobs(var DBHhandle: IscDbHandle; var TraHandle: IscTrHandle; var StmtHandle: IscStmtHandle; Dialect: Word; Sqlda: TSQLResult): boolean; var Status: ISCStatus; BlobHandle: IscBlobHandle; i: Integer; begin Result := True; if (Sqlda <> nil) then sqlda.FScrollEOF := False; Lock; try Status := isc_dsql_fetch(@FStatusVector, @StmtHandle, Dialect, GetSQLDAData(Sqlda)); finally UnLock; end; case Status of 0 : begin if (Sqlda <> nil) then begin // read blobs for i := 0 to Length(Sqlda.FBlobsIndex) - 1 do begin // free previous blobs if not stored if (not Sqlda.FCachedFetch) and // not stored (Sqlda.FBlobArray[i].Size > 0) then // not null (null if the first one) FreeMem(Sqlda.FBlobArray[i].Buffer); if Sqlda.IsNull[Sqlda.FBlobsIndex[i]] then begin Sqlda.FBlobArray[i].Size := 0; Sqlda.FBlobArray[i].Buffer := nil; end else begin BlobHandle := nil; BlobOpen(DBHhandle, TraHandle, BlobHandle, Sqlda.AsQuad[Sqlda.FBlobsIndex[i]]); try BlobReadBuffer(BlobHandle, Sqlda.FBlobArray[i].Size, Sqlda.FBlobArray[i].Buffer); // memory allocated here !! finally BlobClose(BlobHandle); end; end; end; // add to list after the blobs are fetched if Sqlda.FCachedFetch then Sqlda.AddCurrentRecord; end; end; 100 : begin Result := False; // end of fetch if (Sqlda <> nil) then Sqlda.FScrollEOF := True; end; else CheckUIBApiCall(Status); end; end; procedure TUIBLibrary.DSQLDescribe(var StmtHandle: IscStmtHandle; Dialect: Word; Sqlda: TSQLResult); begin Lock; try CheckUIBApiCall(isc_dsql_describe(@FStatusVector, @StmtHandle, Dialect, GetSQLDAData(Sqlda))); finally UnLock; end; if (Sqlda <> nil) then Sqlda.AllocateDataBuffer; end; procedure TUIBLibrary.DSQLDescribeBind(var StmtHandle: IscStmtHandle; Dialect: Word; Sqlda: TSQLDA); begin Lock; try CheckUIBApiCall(isc_dsql_describe_bind(@FStatusVector, @StmtHandle, Dialect, GetSQLDAData(Sqlda))); finally UnLock; end; end; procedure TUIBLibrary.DSQLSetCursorName(var StmtHandle: IscStmtHandle; const cursor: string); begin Lock; try CheckUIBApiCall(isc_dsql_set_cursor_name(@FStatusVector, @StmtHandle, PChar(cursor), 0)); finally UnLock; end; end; procedure TUIBLibrary.DSQLExecImmed2(var DBHhandle: IscDbHandle; var TraHandle: IscTrHandle; const Statement: string; dialect: Word; InSqlda, OutSqlda: TSQLDA); begin Lock; try CheckUIBApiCall(isc_dsql_exec_immed2(@FStatusVector, @DBHhandle, @TraHandle, Length(Statement), PChar(Statement), dialect, GetSQLDAData(InSqlda), GetSQLDAData(OutSqlda))); finally UnLock; end; end; procedure TUIBLibrary.DSQLInfo(var StmtHandle: IscStmtHandle; const Items: array of byte; var buffer: String); begin Lock; try CheckUIBApiCall(isc_dsql_sql_info(@FStatusVector, @StmtHandle, Length(Items), @Items[0], Length(buffer), PChar(buffer))); finally UnLock; end; end; function TUIBLibrary.DSQLInfoPlan(var StmtHandle: IscStmtHandle): string; var STInfo : packed record InfoCode: byte; InfoLen : Word; PlanDesc: array[0..1024] of Char; end; InfoType: Byte; begin InfoType := isc_info_sql_get_plan; Lock; try CheckUIBApiCall(isc_dsql_sql_info(@FStatusVector, @StmtHandle, 1, @InfoType, SizeOf(STInfo), @STInfo)); finally UnLock; end; SetString(Result, PChar(@STInfo.PlanDesc[1]), STInfo.InfoLen - 1); end; function TUIBLibrary.DSQLInfoStatementType(var StmtHandle: IscStmtHandle): TUIBStatementType; var STInfo: packed record InfoCode: byte; InfoLen : Word; InfoType: TUIBStatementType; InfoIn: byte; end; begin STInfo.InfoIn := isc_info_sql_stmt_type; Lock; try CheckUIBApiCall(isc_dsql_sql_info(@FStatusVector, @StmtHandle, 1, @STInfo.InfoIn, SizeOf(STInfo), @STInfo)); finally UnLock; end; dec(STInfo.InfoType); Result := STInfo.InfoType; end; function TUIBLibrary.DSQLInfoRowsAffected(var StmtHandle: IscStmtHandle; StatementType: TUIBStatementType): Cardinal; var InfoData : packed record InfoCode: byte; InfoLen : Word; Infos: packed array[0..3] of record InfoCode: byte; InfoLen : Word; Rows: Cardinal; end; Command: Word; end; begin if not (StatementType in [stUpdate, stDelete, stInsert]) then Result := 0 else begin Lock; try InfoData.Command := isc_info_sql_records; CheckUIBApiCall(isc_dsql_sql_info(@FStatusVector, @StmtHandle, 1, @InfoData.Command, SizeOf(InfoData), @InfoData)); case StatementType of stUpdate: Result := InfoData.Infos[0].Rows; stDelete: Result := InfoData.Infos[1].Rows; stInsert: Result := InfoData.Infos[3].Rows; else Result := 0; end; finally UnLock; end; end; end; procedure TUIBLibrary.DDLExecute(var DBHandle: IscDbHandle; var TraHandle: IscTrHandle; const ddl: string); begin Lock; try CheckUIBApiCall(isc_ddl(@FStatusVector, @DBHandle, @TraHandle, length(ddl), Pointer(ddl))); finally UnLock; end; end; //****************************************************************************** // Array //****************************************************************************** function TUIBLibrary.ArrayLookupBounds(var DBHandle: IscDbHandle; var TransHandle: IscTrHandle; const RelationName, FieldName: String): TArrayDesc; begin Lock; try {$IFDEF IB7_UP} CheckUIBApiCall(isc_array_lookup_bounds2(@FStatusVector, @DBHandle, @TransHandle, PChar(RelationName), PChar(FieldName), @Result)); {$ELSE} CheckUIBApiCall(isc_array_lookup_bounds(@FStatusVector, @DBHandle, @TransHandle, PChar(RelationName), PChar(FieldName), @Result)); {$ENDIF IB7_UP} finally UnLock; end; end; procedure TUIBLibrary.ArrayGetSlice(var DBHandle: IscDbHandle; var TransHandle: IscTrHandle; ArrayId: TISCQuad; var desc: TArrayDesc; DestArray: PPointer; var SliceLength: Integer); begin Lock; try {$IFDEF IB7_UP} CheckUIBApiCall(isc_array_get_slice2(@FStatusVector, @DBHandle, @TransHandle, @ArrayId, @desc, DestArray, @SliceLength)); {$ELSE} CheckUIBApiCall(isc_array_get_slice(@FStatusVector, @DBHandle, @TransHandle, @ArrayId, @desc, DestArray, @SliceLength)); {$ENDIF IB7_UP} finally UnLock; end; end; procedure TUIBLibrary.ArrayPutSlice(var DBHandle: IscDbHandle; var TransHandle: IscTrHandle; var ArrayId: TISCQuad; var desc: TArrayDesc; DestArray: PPointer; var SliceLength: Integer); begin Lock; try {$IFDEF IB7_UP} CheckUIBApiCall(isc_array_put_slice2(@FStatusVector, @DBHandle, @TransHandle, @ArrayId, @desc, DestArray, @SliceLength)); {$ELSE} CheckUIBApiCall(isc_array_put_slice(@FStatusVector, @DBHandle, @TransHandle, @ArrayId, @desc, DestArray, @SliceLength)); {$ENDIF IB7_UP} finally UnLock; end; end; //****************************************************************************** // Error-handling //****************************************************************************** function TUIBLibrary.ErrSqlcode: ISCLong; begin Lock; try Result := isc_sqlcode(@FStatusVector); finally UnLock; end; end; function TUIBLibrary.ErrInterprete: String; var StatusVector: PStatusVector; len: Integer; buffer: array[0..512] of char; begin StatusVector := @FStatusVector; Lock; try repeat len := isc_interprete(buffer, @StatusVector); if len > 0 then Result := Result + copy(buffer, 0, len) + BreakLine else Break; until False; finally UnLock; end; end; function TUIBLibrary.ErrSQLInterprete(SQLCODE: Smallint): String; var i : Integer; begin SetLength(Result, 255); Lock; try isc_sql_interprete(SQLCODE, PChar(Result), 255); finally UnLock; end; for i := 1 to 255 do if Result[i] = #0 then Break; // Quick trim SetLength(Result, i-1); end; //****************************************************************************** // Services //****************************************************************************** procedure TUIBLibrary.ServiceAttach(const ServiceName: string; var SvcHandle: IscSvcHandle; const Spb: string); begin Lock; try CheckUIBApiCall(isc_service_attach(@FStatusVector, Length(ServiceName), PChar(ServiceName), @SvcHandle, Length(Spb), PChar(Spb))); finally UnLock; end; end; procedure TUIBLibrary.ServiceDetach(var SvcHandle: IscSvcHandle); begin Lock; try CheckUIBApiCall(isc_service_detach(@FStatusVector, @SvcHandle)); finally UnLock; end; end; procedure TUIBLibrary.ServiceQuery(var SvcHandle: IscSvcHandle; const SendSpb, RequestSpb: string; var Buffer: string); begin Lock; try CheckUIBApiCall(isc_service_query(@FStatusVector, @SvcHandle, nil, Length(SendSpb), PChar(SendSpb), Length(RequestSpb), PChar(RequestSpb), Length(Buffer), PChar(Buffer))); finally UnLock; end; end; procedure TUIBLibrary.ServiceStart(var SvcHandle: IscSvcHandle; const Spb: string); begin Lock; try CheckUIBApiCall(isc_service_start(@FStatusVector, @SvcHandle, nil, Length(Spb), PChar(Spb))); finally UnLock; end; end; //****************************************************************************** // Blob //****************************************************************************** procedure TUIBLibrary.BlobOpen(var DBHandle: IscDbHandle; var TraHandle: IscTrHandle; var BlobHandle: IscBlobHandle; BlobId: TISCQuad; BPB: string = ''); begin Lock; try CheckUIBApiCall(isc_open_blob2(@FStatusVector, @DBHandle, @TraHandle, @BlobHandle, @BlobId, Length(BPB), PChar(BPB))); finally UnLock; end; end; function TUIBLibrary.BlobGetSegment(var BlobHandle: IscBlobHandle; out length: Word; BufferLength: Cardinal; Buffer: PChar): boolean; var AStatus: ISCStatus; begin if BufferLength > High(Word) then BufferLength := High(Word); Lock; try AStatus := isc_get_segment(@FStatusVector, @BlobHandle, @length, Word(BufferLength), Buffer); finally UnLock; end; Result := (AStatus = 0) or (FStatusVector[1] = isc_segment); if not Result then if (FStatusVector[1] <> isc_segstr_eof) then CheckUIBApiCall(AStatus); end; procedure TUIBLibrary.BlobClose(var BlobHandle: IscBlobHandle); begin Lock; try CheckUIBApiCall(isc_close_blob(@FStatusVector, @BlobHandle)); finally UnLock; end; end; type TBlobInfo = packed record Info: Char; Length: Word; case byte of 0: (CardType: Cardinal); 1: (ByteType: Byte); end; procedure TUIBLibrary.BlobSize(var BlobHandle: IscBlobHandle; out Size: Cardinal); var BlobInfo : packed record Code: Char; Length: Word; Value: Cardinal; reserved: Word; // alignement (8) end; begin Lock; try CheckUIBApiCall(isc_blob_info(@FStatusVector, @BlobHandle, 1, isc_info_blob_total_length, SizeOf(BlobInfo), @BlobInfo)); Size := BlobInfo.Value; finally UnLock; end; end; procedure TUIBLibrary.BlobMaxSegment(var BlobHandle: IscBlobHandle; out Size: Cardinal); var BlobInfo: array[0..1] of TBlobInfo; begin Lock; try CheckUIBApiCall(isc_blob_info(@FStatusVector, @BlobHandle, 1, isc_info_blob_max_segment, SizeOf(BlobInfo), @BlobInfo)); Size := BlobInfo[0].CardType; finally UnLock; end; end; procedure TUIBLibrary.BlobInfo(var BlobHandle: IscBlobHandle; out NumSegments, MaxSegment, TotalLength: Cardinal; out btype : byte); var BlobInfos: array[0..3] of TBlobInfo; begin Lock; try CheckUIBApiCall(isc_blob_info(@FStatusVector, @BlobHandle, 4, isc_info_blob_num_segments + isc_info_blob_max_segment + isc_info_blob_total_length + isc_info_blob_type, SizeOf(BlobInfos), @BlobInfos)); finally UnLock; end; NumSegments := BlobInfos[0].CardType; MaxSegment := BlobInfos[1].CardType; TotalLength := BlobInfos[2].CardType; btype := BlobInfos[3].ByteType; end; procedure TUIBLibrary.BlobDefaultDesc(var Desc: TBlobDesc; const RelationName, FieldName: string); begin Lock; try {$IFDEF IB7_UP} isc_blob_default_desc2(@Desc, PChar(RelationName), PChar(FieldName)); {$ELSE} isc_blob_default_desc(@Desc, PChar(RelationName), PChar(FieldName)); {$ENDIF IB7_UP} finally UnLock; end; end; procedure TUIBLibrary.BlobSaveToStream(var BlobHandle: IscBlobHandle; Stream: TStream); var BlobInfos: array[0..2] of TBlobInfo; Buffer: Pointer; CurrentLength: Word; begin Lock; try CheckUIBApiCall(isc_blob_info(@FStatusVector, @BlobHandle, 2, isc_info_blob_max_segment + isc_info_blob_total_length, SizeOf(BlobInfos), @BlobInfos)); finally UnLock; end; Stream.Seek(0, soFromBeginning); Getmem(Buffer, BlobInfos[0].CardType); try while BlobGetSegment(BlobHandle, CurrentLength, BlobInfos[0].CardType, Buffer) do Stream.Write(Buffer^, CurrentLength); finally FreeMem(Buffer); end; Stream.Seek(0, soFromBeginning); end; function TUIBLibrary.BlobReadString(var BlobHandle: IscBlobHandle): string; begin BlobReadString(BlobHandle, Result); end; procedure TUIBLibrary.BlobReadString(var BlobHandle: IscBlobHandle; var Str: String); var BlobInfos: array[0..2] of TBlobInfo; CurrentLength: Word; Buffer: Pointer; Len: Cardinal; begin Lock; try CheckUIBApiCall(isc_blob_info(@FStatusVector, @BlobHandle, 2, isc_info_blob_max_segment + isc_info_blob_total_length, SizeOf(BlobInfos), @BlobInfos)); finally UnLock; end; SetLength(Str, BlobInfos[1].CardType); Buffer := PChar(Str); len := 0; while BlobGetSegment(BlobHandle, CurrentLength, BlobInfos[1].CardType - len, Buffer) do begin inc(Integer(Buffer), CurrentLength); inc(len, CurrentLength); if len = BlobInfos[1].CardType then Break; end; end; procedure TUIBLibrary.BlobReadBuffer(var BlobHandle: IscBlobHandle; var Size: Cardinal; var Buffer: Pointer); var BlobInfos: array[0..2] of TBlobInfo; CurrentLength: Word; TMP: Pointer; Len: Cardinal; begin Lock; try CheckUIBApiCall(isc_blob_info(@FStatusVector, @BlobHandle, 2, isc_info_blob_max_segment + isc_info_blob_total_length, SizeOf(BlobInfos), @BlobInfos)); finally UnLock; end; Size := BlobInfos[1].CardType; GetMem(Buffer, Size); TMP := Buffer; Len := 0; while BlobGetSegment(BlobHandle, CurrentLength, BlobInfos[1].CardType - len, TMP) do begin inc(Integer(TMP), CurrentLength); inc(Len, CurrentLength); if len = Size then break; end; end; procedure TUIBLibrary.BlobReadSizedBuffer(var BlobHandle: IscBlobHandle; Buffer: Pointer); var BlobInfos: array[0..2] of TBlobInfo; CurrentLength: Word; TMP: Pointer; Len: Cardinal; begin Lock; try CheckUIBApiCall(isc_blob_info(@FStatusVector, @BlobHandle, 2, isc_info_blob_max_segment + isc_info_blob_total_length, SizeOf(BlobInfos), @BlobInfos)); finally UnLock; end; TMP := Buffer; Len := 0; while BlobGetSegment(BlobHandle, CurrentLength, BlobInfos[1].CardType - len, TMP) do begin inc(Integer(TMP), CurrentLength); inc(Len, CurrentLength); if len = BlobInfos[1].CardType then break; end; end; procedure TUIBLibrary.BlobReadSizedBuffer(var BlobHandle: IscBlobHandle; Buffer: Pointer; MaxSize: Cardinal); var BlobInfos: array[0..2] of TBlobInfo; CurrentLength: Word; TMP: Pointer; Len: Cardinal; begin Lock; try CheckUIBApiCall(isc_blob_info(@FStatusVector, @BlobHandle, 2, isc_info_blob_max_segment + isc_info_blob_total_length, SizeOf(BlobInfos), @BlobInfos)); finally UnLock; end; if MaxSize > BlobInfos[1].CardType then MaxSize := BlobInfos[1].CardType; TMP := Buffer; Len := 0; while BlobGetSegment(BlobHandle, CurrentLength, MaxSize - len, TMP) do begin inc(Integer(TMP), CurrentLength); inc(Len, CurrentLength); if len = MaxSize then break; end; end; procedure TUIBLibrary.BlobReadVariant(var BlobHandle: IscBlobHandle; var Value: Variant); var BlobInfos: array[0..2] of TBlobInfo; CurrentLength: Word; Len: Cardinal; Buffer: Pointer; begin Lock; try CheckUIBApiCall(isc_blob_info(@FStatusVector, @BlobHandle, 2, isc_info_blob_max_segment + isc_info_blob_total_length, SizeOf(BlobInfos), @BlobInfos)); finally UnLock; end; Value := VarArrayCreate([0, BlobInfos[1].CardType - 1], varByte); Len := 0; Buffer := VarArrayLock(Value); try while BlobGetSegment(BlobHandle, CurrentLength, BlobInfos[1].CardType - len, Buffer) do begin inc(Integer(Buffer), CurrentLength); inc(Len, CurrentLength); if Len = BlobInfos[1].CardType then Break; end; finally VarArrayUnlock(Value); end; end; function TUIBLibrary.BlobCreate(var DBHandle: IscDbHandle; var TraHandle: IscTrHandle; var BlobHandle: IscBlobHandle; BPB: string = ''): TISCQuad; begin Lock; try CheckUIBApiCall(isc_create_blob2(@FStatusVector, @DBHandle, @TraHandle, @BlobHandle, @Result, Length(BPB), PChar(BPB))); finally UnLock; end; end; procedure TUIBLibrary.BlobWriteSegment(var BlobHandle: IscBlobHandle; BufferLength: Cardinal; Buffer: PChar); var size: Word; begin Lock; try while BufferLength > 0 do begin if BufferLength > FSegmentSize then size := FSegmentSize else size := Word(BufferLength); CheckUIBApiCall(isc_put_segment(@FStatusVector, @BlobHandle, Size, Buffer)); dec(BufferLength, size); inc(Buffer, size); end; finally UnLock; end; end; procedure TUIBLibrary.BlobWriteString(var BlobHandle: IscBlobHandle; var Str: String); begin BlobWriteSegment(BlobHandle, Length(Str), PChar(Str)); end; procedure TUIBLibrary.BlobWriteStream(var BlobHandle: IscBlobHandle; Stream: TStream); var Buffer: PChar; begin Stream.Seek(0, soFromBeginning); if Stream is TCustomMemoryStream then BlobWriteSegment(BlobHandle, Cardinal(TCustomMemoryStream(Stream).Size), TCustomMemoryStream(Stream).Memory) else begin GetMem(Buffer, Cardinal(Stream.Size)); try Stream.Read(Buffer^, Cardinal(Stream.Size)); BlobWriteSegment(BlobHandle, Cardinal(Stream.Size), Buffer); Stream.Seek(0, soFromBeginning); finally FreeMem(buffer); end; end; end; function TUIBLibrary.StreamBlobOpen(var BlobId: TISCQuad; var Database: IscDbHandle; var Transaction: IscTrHandle; Mode: Char): PBStream; begin Lock; try Result := Bopen(@BlobId, @Database, @Transaction, @Mode); finally UnLock; end; end; function TUIBLibrary.StreamBlobClose(Stream: PBStream): integer; begin Lock; try Result := BLOB_close(Stream); finally UnLock; end; end; {$IFDEF IB71_UP} procedure TUIBLibrary.SavepointRelease(var TrHandle: IscTrHandle; const Name: string); begin Lock; try CheckUIBApiCall(isc_release_savepoint(@FStatusVector, @TrHandle, PChar(Name))); finally UnLock; end; end; procedure TUIBLibrary.SavepointRollback(var TrHandle: IscTrHandle; const Name: string; Option: Word); begin Lock; try CheckUIBApiCall(isc_rollback_savepoint(@FStatusVector, @TrHandle, PChar(Name), Option)); finally UnLock; end; end; procedure TUIBLibrary.SavepointStart(var TrHandle: IscTrHandle; const Name: string); begin Lock; try CheckUIBApiCall(isc_start_savepoint(@FStatusVector, @TrHandle, PChar(Name))); finally UnLock; end; end; {$ENDIF IB71_UP} function TUIBLibrary.GetSegmentSize: Word; begin Lock; try Result := FSegMentSize; finally UnLock; end; end; procedure TUIBLibrary.SetSegmentSize(Value: Word); begin Lock; try Assert(Value > 0); FSegmentSize := Value; finally UnLock; end; end; //****************************************************************************** // Conversion // Making a delphi conversion will help to transport data buffer and use it // without GDS32 ;) //****************************************************************************** procedure DecodeSQLDate(const v: Integer; out Date: Double); var year: SmallInt; month, day: Word; begin DecodeSQLDate(v, year, month, day); Date := EncodeDate(Year, month, day) end; procedure DecodeSQLDate(v: Integer; out Year: SmallInt; out Month, Day: Word); var c: Word; begin inc(v, 678882); c := (4 * v - 1) div 146097; // century v := 4 * v - 1 - 146097 * c; day := v div 4; v := (4 * day + 3) div 1461; day := 4 * day + 3 - 1461 * v; day := (day + 4) div 4; month := (5 * day - 3) div 153; day := 5 * day - 3 - 153 * month; day := (day + 5) div 5; year := 100 * c + v; if (month < 10) then inc(month, 3) else begin dec(month, 9); inc(year, 1); end; end; {$IFDEF FPC} {$IFDEF LINUX} const MonthDays: array [Boolean] of TDayTable = ((31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31), (31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)); {$ENDIF LINUX} {$ENDIF FPC} procedure EncodeDate(const Year: Smallint; const Month: Word; Day: Word; out Date: Integer); var I: Integer; DayTable: PDayTable; begin Date := 0; DayTable := @MonthDays[IsLeapYear(Year)]; if (Year >= 1) and (Year <= 9999) and (Month >= 1) and (Month <= 12) and (Day >= 1) and (Day <= DayTable^[Month]) then begin for I := 1 to Month - 1 do Inc(Day, DayTable^[I]); I := Year - 1; Date := I * 365 + I div 4 - I div 100 + I div 400 + Day - DateDelta; end; end; procedure DecodeSQLDate(const v: Integer; out Date: Integer); var year: SmallInt; month, day: Word; begin DecodeSQLDate(v, year, month, day); EncodeDate(Year, month, day, Date) end; function DecodeSQLDate(const v: Integer): Integer; begin DecodeSQLDate(v, Result); end; procedure EncodeSQLDate(date: TDateTime; out v: Integer); var day, month: Word; year: Word; c, ya: Integer; begin DecodeDate(Date, year, month, day); if (month > 2) then dec(month, 3) else begin inc(month, 9); dec(year); end; c := year div 100; ya := year - (100 * c); v := ((146097 * c) div 4 + (1461 * ya) div 4 + (153 * month + 2) div 5 + day - 678882); end; procedure EncodeSQLDate(date: Integer; out v: Integer); overload; var day, month: Word; year: Word; c, ya: Integer; begin DecodeDate(Date, year, month, day); if (month > 2) then dec(month, 3) else begin inc(month, 9); dec(year); end; c := year div 100; ya := year - (100 * c); v := ((146097 * c) div 4 + (1461 * ya) div 4 + (153 * month + 2) div 5 + day - 678882); end; procedure EncodeSQLDate(Year: SmallInt; Month, Day: Word; out v: Integer); overload; var c, ya: Integer; begin if (month > 2) then dec(month, 3) else begin inc(month, 9); dec(year); end; c := year div 100; ya := year - (100 * c); v := ((146097 * c) div 4 + (1461 * ya) div 4 + (153 * month + 2) div 5 + day - 678882); end; procedure DecodeTimeStamp(v: PISCTimeStamp; out DateTime: Double); begin DecodeSQLDate(v.timestamp_date, DateTime); DateTime := DateTime + (v.timestamp_time / 864000000); end; procedure DecodeTimeStamp(v: PISCTimeStamp; out TimeStamp: TTimeStamp); begin TimeStamp.Date := DecodeSQLDate(v.timestamp_date) + 693594; TimeStamp.Time := v.timestamp_time div 10; end; function DecodeTimeStamp(v: PISCTimeStamp): Double; begin DecodeTimeStamp(v, Result); end; procedure EncodeTimeStamp(const DateTime: TDateTime; v: PISCTimeStamp); begin EncodeSQLDate(DateTime, v.timestamp_date); v.timestamp_time := ISC_TIME(Round(Frac(DateTime) * 864000000)); end; procedure EncodeTimeStamp(const Date: Integer; v: PISCTimeStamp); begin EncodeSQLDate(Date, v.timestamp_date); v.timestamp_time := 0; end; procedure EncodeTimeStamp(const Time: Cardinal; v: PISCTimeStamp); begin EncodeSQLDate(0, v.timestamp_date); v.timestamp_time := Time; end; procedure DecodeSQLTime(v: Cardinal; out Hour, Minute, Second: Word; out Fractions: LongWord); begin Hour := v div 36000000; v := v mod 36000000; if (v > 0) then begin Minute := v div 600000; v := v mod 600000; if (v > 0) then begin Second := v div 10000; v := v mod 10000; if (v > 0) then Fractions := v div 10 else Fractions := 0; end else begin Second := 0; Fractions := 0; end; end else begin Minute := 0; Second := 0; Fractions := 0; end; end; procedure EncodeSQLTime(const Hour, Minute, Second: Word; const Fractions: LongWord; out v: Cardinal); begin {$IFDEF FPC} // strange fpc warning ! v := Hour * Cardinal(36000000) + Minute * Cardinal(600000) + Second * Cardinal(10000) + Fractions * 10; {$ELSE} v := Hour * 36000000 + Minute * 600000 + Second * 10000 + Fractions * 10; {$ENDIF FPC} end; { TSQLDA } function TSQLDA.GetActualFields: Word; begin Result := FXSQLDA.sqld; end; function TSQLDA.GetAllocatedFields: Word; begin Result := FXSQLDA.sqln; end; function TSQLDA.GetPointer: PUIBSQLDa; begin result := FXSQLDA; end; procedure TSQLDA.SetAllocatedFields(Fields: Word); begin if Fields <= 0 then Fields := 1; ReallocMem(FXSQLDA, XSQLDA_LENGTH(Fields)); FXSQLDA.sqln := Fields; FXSQLDA.sqld := Fields; FXSQLDA.version := SQLDA_CURRENT_VERSION; end; function TSQLDA.GetSqlName(const Index: Word): string; begin CheckRange(Index); SetString(Result, FXSQLDA.sqlvar[Index].SqlName, FXSQLDA.sqlvar[Index].SqlNameLength); end; function TSQLDA.GetAliasName(const Index: Word): string; begin CheckRange(Index); SetString(Result, FXSQLDA.sqlvar[Index].AliasName, FXSQLDA.sqlvar[Index].AliasNameLength); end; function TSQLDA.GetOwnName(const Index: Word): string; begin CheckRange(Index); SetString(Result, FXSQLDA.sqlvar[Index].OwnName, FXSQLDA.sqlvar[Index].OwnNameLength); end; function TSQLDA.GetRelName(const Index: Word): string; begin CheckRange(Index); SetString(Result, FXSQLDA.sqlvar[Index].RelName, FXSQLDA.sqlvar[Index].RelNameLength); end; function TSQLDA.GetIsNull(const Index: Word): boolean; begin CheckRange(Index); Result := (FXSQLDA.sqlvar[Index].sqlind <> nil) and (FXSQLDA.sqlvar[Index].sqlind^ = -1) end; procedure TSQLDA.CheckRange(const Index: Word); begin if Index >= Word(FXSQLDA.sqln) then raise Exception.CreateFmt(EUIB_FIELDNUMNOTFOUND, [Index]); end; function TSQLDA.DecodeString(const Code: Smallint; Index: Word): String; begin with FXSQLDA.sqlvar[Index] do case Code of SQL_TEXT : SetString(Result, sqldata, sqllen); SQL_VARYING : SetString(Result, PVary(sqldata).vary_string, PVary(sqldata).vary_length); end; end; procedure TSQLDA.DecodeString(const Code: Smallint; Index: Word; out Str: String); begin with FXSQLDA.sqlvar[Index] do case Code of SQL_TEXT : SetString(Str, sqldata, sqllen); SQL_VARYING : SetString(Str, PVary(sqldata).vary_string, PVary(sqldata).vary_length); end; end; procedure TSQLDA.DecodeWideString(const Code: Smallint; Index: Word; out Str: WideString); procedure SetWideString(var s: WideString; buffer: PChar; len: Integer); begin SetLength(s, len div 2); move(buffer^, PWideChar(s)^, len); end; begin with FXSQLDA.sqlvar[Index] do case Code of SQL_TEXT : SetWideString(Str, sqldata, sqllen); SQL_VARYING : SetWideString(Str, PVary(sqldata).vary_string, PVary(sqldata).vary_length); end; end; function TSQLDA.GetAsDouble(const Index: Word): Double; var ASQLCode: SmallInt; begin CheckRange(Index); with FXSQLDA.sqlvar[Index] do begin Result := 0; if (sqlind <> nil) and (sqlind^ = -1) then Exit; ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : Result := PSmallInt(sqldata)^ / ScaleDivisor[sqlscale]; SQL_LONG : Result := PInteger(sqldata)^ / ScaleDivisor[sqlscale]; SQL_INT64, SQL_QUAD : Result := PInt64(sqldata)^ / ScaleDivisor[sqlscale]; SQL_DOUBLE : Result := PDouble(sqldata)^; else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : Result := PDouble(sqldata)^; SQL_TIMESTAMP : DecodeTimeStamp(PISCTimeStamp(sqldata), Result); SQL_TYPE_DATE : DecodeSQLDate(PInteger(sqldata)^, Result); SQL_TYPE_TIME : Result := PCardinal(sqldata)^ / 864000000; SQL_LONG : Result := PInteger(sqldata)^; SQL_D_FLOAT, SQL_FLOAT : Result := PSingle(sqldata)^; {$IFDEF IB7_UP} SQL_BOOLEAN, {$ENDIF IB7_UP} SQL_SHORT : Result := PSmallint(sqldata)^; SQL_INT64 : Result := PInt64(sqldata)^; SQL_TEXT : Result := StrToFloat(DecodeString(SQL_TEXT, Index)); SQL_VARYING : Result := StrToFloat(DecodeString(SQL_VARYING, Index)); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; end; end; function TSQLDA.GetAsInt64(const Index: Word): Int64; var ASQLCode: SmallInt; begin CheckRange(Index); with FXSQLDA.sqlvar[Index] do begin Result := 0; if (sqlind <> nil) and (sqlind^ = -1) then Exit; ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : Result := PSmallInt(sqldata)^ div ScaleDivisor[sqlscale]; SQL_LONG : Result := PInteger(sqldata)^ div ScaleDivisor[sqlscale]; SQL_INT64, SQL_QUAD : Result := PInt64(sqldata)^ div ScaleDivisor[sqlscale]; SQL_DOUBLE : Result := Trunc(PDouble(sqldata)^); else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : Result := Trunc(PDouble(sqldata)^); SQL_TIMESTAMP : Result := DecodeSQLDate(PISCTimeStamp(sqldata).timestamp_date); // Only Date SQL_TYPE_DATE : Result := DecodeSQLDate(PInteger(sqldata)^); SQL_TYPE_TIME : ; // Result := 0; What else ?? SQL_LONG : Result := PInteger(sqldata)^; SQL_D_FLOAT, SQL_FLOAT : Result := Trunc(PSingle(sqldata)^); {$IFDEF IB7_UP} SQL_BOOLEAN, {$ENDIF IB7_UP} SQL_SHORT : Result := PSmallint(sqldata)^; SQL_INT64 : Result := PInt64(sqldata)^; SQL_TEXT : Result := StrToInt64(DecodeString(SQL_TEXT, Index)); SQL_VARYING : Result := StrToInt64(DecodeString(SQL_VARYING, Index)); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; end; end; function TSQLDA.GetAsInteger(const Index: Word): Integer; var ASQLCode: SmallInt; begin CheckRange(Index); with FXSQLDA.sqlvar[Index] do begin Result := 0; if (sqlind <> nil) and (sqlind^ = -1) then Exit; ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : Result := PSmallInt(sqldata)^ div ScaleDivisor[sqlscale]; SQL_LONG : Result := PInteger(sqldata)^ div ScaleDivisor[sqlscale]; SQL_INT64, SQL_QUAD : Result := PInt64(sqldata)^ div ScaleDivisor[sqlscale]; SQL_DOUBLE : Result := Trunc(PDouble(sqldata)^); else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : Result := Trunc(PDouble(sqldata)^); SQL_TIMESTAMP : Result := DecodeSQLDate(PISCTimeStamp(sqldata).timestamp_date); // Only Date SQL_TYPE_DATE : Result := DecodeSQLDate(PInteger(sqldata)^); SQL_TYPE_TIME : ; // Result := 0; What else ?? SQL_LONG : Result := PInteger(sqldata)^; SQL_D_FLOAT, SQL_FLOAT : Result := Trunc(PSingle(sqldata)^); {$IFDEF IB7_UP} SQL_BOOLEAN, {$ENDIF IB7_UP} SQL_SHORT : Result := PSmallint(sqldata)^; SQL_INT64 : Result := PInt64(sqldata)^; SQL_TEXT : Result := StrToInt(DecodeString(SQL_TEXT, Index)); SQL_VARYING : Result := StrToInt(DecodeString(SQL_VARYING, Index)); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; end; end; function TSQLDA.GetAsSingle(const Index: Word): Single; var ASQLCode: SmallInt; begin CheckRange(Index); with FXSQLDA.sqlvar[Index] do begin Result := 0; if (sqlind <> nil) and (sqlind^ = -1) then Exit; ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : Result := PSmallInt(sqldata)^ / ScaleDivisor[sqlscale]; SQL_LONG : Result := PInteger(sqldata)^ / ScaleDivisor[sqlscale]; SQL_INT64, SQL_QUAD : Result := PInt64(sqldata)^ / ScaleDivisor[sqlscale]; SQL_DOUBLE : Result := PDouble(sqldata)^; else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : Result := PDouble(sqldata)^; SQL_TIMESTAMP : Result := DecodeTimeStamp(PISCTimeStamp(sqldata)); SQL_TYPE_DATE : Result := DecodeSQLDate(PInteger(sqldata)^); SQL_TYPE_TIME : Result := PCardinal(sqldata)^ / 864000000; SQL_LONG : Result := PInteger(sqldata)^; SQL_D_FLOAT, SQL_FLOAT : Result := PSingle(sqldata)^; {$IFDEF IB7_UP} SQL_BOOLEAN, {$ENDIF IB7_UP} SQL_SHORT : Result := PSmallint(sqldata)^; SQL_INT64 : Result := PInt64(sqldata)^; SQL_TEXT : Result := StrToFloat(DecodeString(SQL_TEXT, Index)); SQL_VARYING : Result := StrToFloat(DecodeString(SQL_VARYING, Index)); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; end; end; function TSQLDA.GetAsSmallint(const Index: Word): Smallint; var ASQLCode: SmallInt; begin CheckRange(Index); with FXSQLDA.sqlvar[Index] do begin Result := 0; if (sqlind <> nil) and (sqlind^ = -1) then Exit; ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : Result := PSmallInt(sqldata)^ div ScaleDivisor[sqlscale]; SQL_LONG : Result := PInteger(sqldata)^ div ScaleDivisor[sqlscale]; SQL_INT64, SQL_QUAD : Result := PInt64(sqldata)^ div ScaleDivisor[sqlscale]; SQL_DOUBLE : Result := Trunc(PDouble(sqldata)^); else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : Result := Trunc(PDouble(sqldata)^); SQL_TIMESTAMP : Result := DecodeSQLDate(PISCTimeStamp(sqldata).timestamp_date); // Only Date SQL_TYPE_DATE : Result := DecodeSQLDate(PInteger(sqldata)^); SQL_TYPE_TIME : ; // Result := 0; What else ?? SQL_LONG : Result := PInteger(sqldata)^; SQL_D_FLOAT, SQL_FLOAT : Result := Trunc(PSingle(sqldata)^); {$IFDEF IB7_UP} SQL_BOOLEAN, {$ENDIF IB7_UP} SQL_SHORT : Result := PSmallint(sqldata)^; SQL_INT64 : Result := PInt64(sqldata)^; SQL_TEXT : Result := StrToInt(DecodeString(SQL_TEXT, Index)); SQL_VARYING : Result := StrToInt(DecodeString(SQL_VARYING, Index)); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; end; end; function TSQLDA.GetAsString(const Index: Word): String; function BoolToStr(const Value: boolean): string; begin if Value then result := sUIBTrue else result := sUIBFalse; end; var ASQLCode: SmallInt; begin CheckRange(Index); Result := ''; with FXSQLDA.sqlvar[Index] do begin if (sqlind <> nil) and (sqlind^ = -1) then Exit; ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : Result := FloatToStr(PSmallInt(sqldata)^ / ScaleDivisor[sqlscale]); SQL_LONG : Result := FloatToStr(PInteger(sqldata)^ / ScaleDivisor[sqlscale]); SQL_INT64, SQL_QUAD : Result := FloatToStr(PInt64(sqldata)^ / ScaleDivisor[sqlscale]); SQL_DOUBLE : Result := FloatToStr(PDouble(sqldata)^); else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : Result := FloatToStr(PDouble(sqldata)^); SQL_TIMESTAMP : Result := DateTimeToStr(DecodeTimeStamp(PISCTimeStamp(sqldata))); SQL_TYPE_DATE : Result := DateToStr(DecodeSQLDate(PInteger(sqldata)^)); SQL_TYPE_TIME : Result := TimeToStr(PCardinal(sqldata)^ / 864000000); SQL_LONG : Result := IntToStr(PInteger(sqldata)^); SQL_D_FLOAT, SQL_FLOAT : Result := FloatToStr(PSingle(sqldata)^); {$IFDEF IB7_UP} SQL_BOOLEAN : Result := BoolToStr(PSmallint(sqldata)^ = 1); {$ENDIF IB7_UP} SQL_SHORT : Result := IntToStr(PSmallint(sqldata)^); SQL_INT64 : Result := IntToStr(PInt64(sqldata)^); SQL_TEXT : DecodeString(SQL_TEXT, Index, Result); SQL_VARYING : DecodeString(SQL_VARYING, Index, Result); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; end; end; function TSQLDA.GetAsQuad(const Index: Word): TISCQuad; begin CheckRange(Index); with FXSQLDA.sqlvar[Index] do if not ((sqlind <> nil) and (sqlind^ = -1)) then case (sqltype and not(1)) of SQL_QUAD, SQL_DOUBLE, SQL_INT64, SQL_BLOB, SQL_ARRAY: result := PISCQuad(sqldata)^; else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end else Result := QuadNull; end; function TSQLDA.GetFieldCount: Integer; begin Result := FXSQLDA.sqln; end; function TSQLDA.GetSQLType(const Index: Word): Smallint; begin CheckRange(Index); result := FXSQLDA.sqlvar[Index].sqltype and not (1); end; function TSQLDA.GetSQLLen(const Index: Word): Smallint; begin CheckRange(Index); result := FXSQLDA.sqlvar[Index].sqllen; end; function TSQLDA.GetIsBlob(const Index: Word): boolean; begin CheckRange(Index); result := ((FXSQLDA.sqlvar[Index].sqltype and not(1)) = SQL_BLOB); end; function TSQLDA.GetFieldIndex(const name: String): Word; begin for Result := 0 to GetAllocatedFields - 1 do if FXSQLDA.sqlvar[Result].AliasNameLength = Length(name) then if StrLIComp(@FXSQLDA.sqlvar[Result].aliasname, PChar(Name), FXSQLDA.sqlvar[Result].AliasNameLength) = 0 then Exit; raise Exception.CreateFmt(EUIB_FIELDSTRNOTFOUND, [name]); end; function TSQLDA.GetByNameAsDouble(const Name: String): Double; begin Result := GetAsDouble(GetFieldIndex(Name)); end; function TSQLDA.GetByNameAsInt64(const Name: String): Int64; begin Result := GetAsInt64(GetFieldIndex(Name)); end; function TSQLDA.GetByNameAsInteger(const Name: String): Integer; begin Result := GetAsInteger(GetFieldIndex(Name)); end; function TSQLDA.GetByNameAsQuad(const Name: String): TISCQuad; begin Result := GetAsQuad(GetFieldIndex(Name)); end; function TSQLDA.GetByNameAsSingle(const Name: String): Single; begin Result := GetAsSingle(GetFieldIndex(Name)); end; function TSQLDA.GetByNameAsSmallint(const Name: String): Smallint; begin Result := GetAsSmallint(GetFieldIndex(Name)); end; function TSQLDA.GetByNameAsString(const Name: String): String; begin Result := GetAsString(GetFieldIndex(Name)); end; function TSQLDA.GetAsVariant(const Index: Word): Variant; var ASQLCode: SmallInt; Dbl: Double; begin CheckRange(Index); with FXSQLDA.sqlvar[Index] do begin Result := NULL; if (sqlind <> nil) and (sqlind^ = -1) then Exit; ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : Result := PSmallInt(sqldata)^ / ScaleDivisor[sqlscale]; SQL_LONG : Result := PInteger(sqldata)^ / ScaleDivisor[sqlscale]; SQL_INT64, SQL_QUAD : Result := PInt64(sqldata)^ / ScaleDivisor[sqlscale]; SQL_DOUBLE : Result := PDouble(sqldata)^; else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : Result := PDouble(sqldata)^; SQL_TIMESTAMP : Result := TDateTime(DecodeTimeStamp(PISCTimeStamp(sqldata))); SQL_TYPE_DATE : begin Dbl := DecodeSQLDate(PInteger(sqldata)^); Result := TDateTime(Dbl); end; SQL_TYPE_TIME : Result := PCardinal(sqldata)^ / 864000000; SQL_LONG : Result := PInteger(sqldata)^; SQL_D_FLOAT, SQL_FLOAT : Result := PSingle(sqldata)^; {$IFDEF IB7_UP} SQL_BOOLEAN : Result := PSmallint(sqldata)^ = 1; {$ENDIF IB7_UP} SQL_SHORT : Result := PSmallint(sqldata)^; {$IFDEF COMPILER6_UP} SQL_INT64 : Result := PInt64(sqldata)^; {$ELSE} SQL_INT64 : Result := Integer(PInt64(sqldata)^); {$ENDIF COMPILER6_UP} SQL_TEXT : Result := DecodeString(SQL_TEXT, Index); SQL_VARYING : Result := DecodeString(SQL_VARYING, Index); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; end; end; function TSQLDA.GetByNameAsVariant(const Name: String): Variant; begin Result := GetAsVariant(GetFieldIndex(Name)); end; { TSQLDAResult } constructor TSQLResult.Create(Fields: SmallInt = 0; CachedFetch: Boolean = False; FetchBlobs: boolean = false; BufferChunks: Cardinal = 1000); begin inherited Create; FCachedFetch := CachedFetch; FFetchBlobs := FetchBlobs; FDataBufferLength := 0; FDataBuffer := nil; if Fields <= 0 then Fields := 0; GetMem(FXSQLDA, XSQLDA_LENGTH(Fields)); FXSQLDA.sqln := Fields; FXSQLDA.sqld := Fields; FXSQLDA.version := SQLDA_CURRENT_VERSION; FBufferChunks := BufferChunks; end; destructor TSQLResult.Destroy; begin ClearRecords; FreeMem(FXSQLDA); if FDataBuffer <> nil then begin if (not FCachedFetch) and FFetchBlobs then FreeBlobs(FDataBuffer); FreeMem(FDataBuffer) end; inherited; end; procedure TSQLResult.AddCurrentRecord; begin if not Assigned(FMemoryPool) then FMemoryPool := TMemoryPool.Create(FDataBufferLength, FBufferChunks); Move(FDataBuffer^, FMemoryPool.New^, FDataBufferLength); FCurrentRecord := FMemoryPool.Count - 1; end; procedure TSQLResult.ClearRecords; var i: Integer; begin FScrollEOF := False; if Assigned(FMemoryPool) then begin if FFetchBlobs then for i := 0 to FMemoryPool.Count - 1 do FreeBlobs(FMemoryPool.Items[i]); FMemoryPool.Free; FMemoryPool := nil; end; end; procedure TSQLResult.GetRecord(const Index: Integer); begin if (Index <> FCurrentRecord) and (FMemoryPool <> nil) then begin Move(FMemoryPool.Items[Index]^, FDataBuffer^, FDataBufferLength); FCurrentRecord := Index; end; end; function TSQLResult.GetRecordCount: Integer; begin if Assigned(FMemoryPool) then Result := FMemoryPool.Count else Result := 0; end; procedure TSQLResult.AllocateDataBuffer; var i, LastLen: SmallInt; BlobCount: Word; begin FDataBufferLength := 0; LastLen := 0; BlobCount := 0; SetLength(FBlobsIndex, BlobCount); // calculate offsets and store them instead of pointers ;) for i := 0 to FXSQLDA.sqln - 1 do begin Inc(FDataBufferLength, LastLen); FXSQLDA.sqlvar[i].sqldata := Pointer(FDataBufferLength); if FXSQLDA.sqlvar[i].sqltype and not (1) = SQL_VARYING then LastLen := FXSQLDA.sqlvar[i].sqllen + 2 else LastLen := FXSQLDA.sqlvar[i].sqllen; if ((FXSQLDA.sqlvar[i].sqltype and 1) = 1) then begin Inc(FDataBufferLength, LastLen); FXSQLDA.sqlvar[i].sqlind := Pointer(FDataBufferLength); LastLen := 2; // SizeOf(SmallInt) end else FXSQLDA.sqlvar[i].sqlind := nil; // count blobs if FFetchBlobs and ((FXSQLDA.sqlvar[i].sqltype and not 1) = SQL_BLOB) then begin inc(BlobCount); SetLength(FBlobsIndex, BlobCount); FBlobsIndex[BlobCount-1] := i; end; end; Inc(FDataBufferLength, LastLen); Inc(FDataBufferLength, BlobCount * SizeOf(TBlobData)); // Size + Pointer // Now we have the total length needed if (FDataBuffer = nil) then GetMem(FDataBuffer, FDataBufferLength {+ (FXSQLDA.sqln * 2)}) else ReallocMem(FDataBuffer, FDataBufferLength {+ (FXSQLDA.sqln * 2)}); FillChar(FDataBuffer^, FDataBufferLength, 0); FBlobArray := FDataBuffer; Inc(Integer(FBlobArray), FDataBufferLength - BlobCount * SizeOf(TBlobData)); // increment Offsets with the buffer for i := 0 to FXSQLDA.sqln - 1 do begin // I don't use cardinal for FPC compatibility {$IFDEF FPC} inc(FXSQLDA.sqlvar[i].sqldata, FDataBuffer); if (FXSQLDA.sqlvar[i].sqlind <> nil) then inc(FXSQLDA.sqlvar[i].sqlind, FDataBuffer); {$ELSE} inc(Integer(FXSQLDA.sqlvar[i].sqldata), Integer(FDataBuffer)); if (FXSQLDA.sqlvar[i].sqlind <> nil) then inc(Integer(FXSQLDA.sqlvar[i].sqlind), Integer(FDataBuffer)); {$ENDIF FPC} end; end; procedure TSQLResult.SaveToStream(Stream: TStream); var RecCount, i, j: Integer; BlobArray: PBlobDataArray; begin Stream.Write(FCachedFetch, SizeOf(FCachedFetch)); Stream.Write(FFetchBlobs, SizeOf(FFetchBlobs)); Stream.Write(FXSQLDA.sqln, SizeOf(FXSQLDA.sqln)); Stream.Write(FXSQLDA^, XSQLDA_LENGTH(FXSQLDA.sqln)); // MetaData RecCount := RecordCount; Stream.Write(RecCount, SizeOf(RecCount)); for i := 0 to RecCount - 1 do begin Stream.Write(FMemoryPool.Items[i]^, FDataBufferLength); for j := 0 to Length(FBlobsIndex) - 1 do begin BlobArray := Pointer(Integer(FMemoryPool.Items[i]) + FDataBufferLength - (Length(FBlobsIndex)*8)); Stream.Write(BlobArray[j].Size, 4); Stream.Write(BlobArray[j].Buffer^, BlobArray[j].Size); end; end; end; procedure TSQLResult.LoadFromStream(Stream: TStream); var Fields: SmallInt; RecCount, i, j: Integer; begin // CleanUp ClearRecords; if (not FCachedFetch) and FFetchBlobs then FreeBlobs(FDataBuffer); Stream.Read(FCachedFetch, SizeOf(FCachedFetch)); Stream.Read(FFetchBlobs, SizeOf(FFetchBlobs)); Stream.Read(Fields, SizeOf(Fields)); SetAllocatedFields(Fields); Stream.Read(FXSQLDA^, XSQLDA_LENGTH(Fields)); // realloc & index buffer AllocateDataBuffer; Stream.Read(RecCount, SizeOf(RecCount)); FBufferChunks := RecCount; // Inprove memory allocation for i := 0 to RecCount - 1 do begin Stream.Read(FDataBuffer^, FDataBufferLength); for j := 0 to Length(FBlobsIndex) - 1 do begin Stream.Read(FBlobArray[j].Size, 4); if FBlobArray[j].Size > 0 then begin GetMem(FBlobArray[j].Buffer, FBlobArray[j].Size); Stream.Read(FBlobArray[j].Buffer^, FBlobArray[j].Size); end else FBlobArray[j].Buffer := nil; end; AddCurrentRecord; end; FScrollEOF := True; end; function TSQLResult.GetCurrentRecord: Integer; begin if (FMemoryPool = nil) then Result := -1 else Result := FCurrentRecord; end; procedure TSQLResult.FreeBlobs(Buffer: Pointer); var BlobArray: PBlobDataArray; I: integer; begin BlobArray := Pointer(Integer(Buffer) + FDataBufferLength - (Length(FBlobsIndex)*8)); for I := 0 to Length(FBlobsIndex) - 1 do if BlobArray[I].Size > 0 then FreeMem(BlobArray[I].Buffer); end; function TSQLResult.GetBlobIndex(const Index: Word): Word; begin if FFetchBlobs then begin for Result := 0 to Length(FBlobsIndex) - 1 do if (FBlobsIndex[Result] = Index) then Exit; raise Exception.CreateFmt(EUIB_BLOBFIELDNOTFOUND, [Index]); end else raise Exception.Create(EUIB_FETCHBLOBNOTSET); end; function TSQLResult.GetEof: boolean; begin Result := FScrollEOF and ( (not CachedFetch) or (RecordCount = 0) or (FCurrentRecord = RecordCount - 1)); end; function TSQLResult.GetBof: boolean; begin Result := (FCurrentRecord = 0) or (RecordCount = 0); end; procedure TSQLResult.ReadBlob(const Index: Word; var str: string); begin CheckRange(Index); with FBlobArray[GetBlobIndex(Index)] do begin SetLength(str, Size); Move(Buffer^, PChar(Str)^, Size); end; end; procedure TSQLResult.ReadBlob(const Index: Word; Stream: TStream); begin CheckRange(Index); with FBlobArray[GetBlobIndex(Index)] do begin Stream.Seek(0, 0); Stream.Write(Buffer^, Size); Stream.Seek(0, 0); end; end; procedure TSQLResult.ReadBlob(const Index: Word; var Value: Variant); var PData: Pointer; begin CheckRange(Index); with FBlobArray[GetBlobIndex(Index)] do begin Value := VarArrayCreate([0, Size-1], varByte); PData := VarArrayLock(Value); try move(Buffer^, PData^, Size); finally VarArrayUnlock(Value); end; end; end; procedure TSQLResult.ReadBlob(const Index: Word; var str: WideString); begin CheckRange(Index); with FBlobArray[GetBlobIndex(Index)] do begin SetLength(str, Size); Move(Buffer^, PWideChar(Str)^, Size); end; end; procedure TSQLResult.ReadBlob(const Index: Word; Data: Pointer); begin CheckRange(Index); with FBlobArray[GetBlobIndex(Index)] do Move(Buffer^, Data^, Size); end; procedure TSQLResult.ReadBlob(const name: string; Data: Pointer); begin ReadBlob(GetFieldIndex(name), Data); end; procedure TSQLResult.ReadBlob(const name: string; var str: WideString); begin ReadBlob(GetFieldIndex(name), str); end; procedure TSQLResult.ReadBlob(const name: string; var str: string); begin ReadBlob(GetFieldIndex(name), str); end; procedure TSQLResult.ReadBlob(const name: string; Stream: TStream); begin ReadBlob(GetFieldIndex(name), Stream); end; procedure TSQLResult.ReadBlob(const name: string; var Value: Variant); begin ReadBlob(GetFieldIndex(name), Value); end; function TSQLResult.GetBlobSize(const Index: Word): Cardinal; begin CheckRange(Index); Result := FBlobArray[GetBlobIndex(Index)].Size; end; function TSQLResult.GetAsString(const Index: Word): String; function BoolToStr(const Value: boolean): string; begin if Value then result := sUIBTrue else result := sUIBFalse; end; var ASQLCode: SmallInt; begin CheckRange(Index); Result := ''; with FXSQLDA.sqlvar[Index] do begin if (sqlind <> nil) and (sqlind^ = -1) then Exit; ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : Result := FloatToStr(PSmallInt(sqldata)^ / ScaleDivisor[sqlscale]); SQL_LONG : Result := FloatToStr(PInteger(sqldata)^ / ScaleDivisor[sqlscale]); SQL_INT64, SQL_QUAD : Result := FloatToStr(PInt64(sqldata)^ / ScaleDivisor[sqlscale]); SQL_DOUBLE : Result := FloatToStr(PDouble(sqldata)^); else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : Result := FloatToStr(PDouble(sqldata)^); SQL_TIMESTAMP : Result := DateTimeToStr(DecodeTimeStamp(PISCTimeStamp(sqldata))); SQL_TYPE_DATE : Result := DateToStr(DecodeSQLDate(PInteger(sqldata)^)); SQL_TYPE_TIME : Result := TimeToStr(PCardinal(sqldata)^ / 864000000); SQL_LONG : Result := IntToStr(PInteger(sqldata)^); SQL_D_FLOAT, SQL_FLOAT : Result := FloatToStr(PSingle(sqldata)^); {$IFDEF IB7_UP} SQL_BOOLEAN : Result := BoolToStr(PSmallint(sqldata)^ = 1); {$ENDIF IB7_UP} SQL_SHORT : Result := IntToStr(PSmallint(sqldata)^); SQL_INT64 : Result := IntToStr(PInt64(sqldata)^); SQL_TEXT : DecodeString(SQL_TEXT, Index, Result); SQL_VARYING : DecodeString(SQL_VARYING, Index, Result); SQL_BLOB : ReadBlob(Index, Result); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; end; end; function TSQLResult.GetAsWideString(const Index: Word): WideString; function BoolToStr(const Value: boolean): string; begin if Value then result := sUIBTrue else result := sUIBFalse; end; var ASQLCode: SmallInt; begin CheckRange(Index); Result := ''; with FXSQLDA.sqlvar[Index] do begin if (sqlind <> nil) and (sqlind^ = -1) then Exit; ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : Result := FloatToStr(PSmallInt(sqldata)^ / ScaleDivisor[sqlscale]); SQL_LONG : Result := FloatToStr(PInteger(sqldata)^ / ScaleDivisor[sqlscale]); SQL_INT64, SQL_QUAD : Result := FloatToStr(PInt64(sqldata)^ / ScaleDivisor[sqlscale]); SQL_DOUBLE : Result := FloatToStr(PDouble(sqldata)^); else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : Result := FloatToStr(PDouble(sqldata)^); SQL_TIMESTAMP : Result := DateTimeToStr(DecodeTimeStamp(PISCTimeStamp(sqldata))); SQL_TYPE_DATE : Result := DateToStr(DecodeSQLDate(PInteger(sqldata)^)); SQL_TYPE_TIME : Result := TimeToStr(PCardinal(sqldata)^ / 864000000); SQL_LONG : Result := IntToStr(PInteger(sqldata)^); SQL_D_FLOAT, SQL_FLOAT : Result := FloatToStr(PSingle(sqldata)^); {$IFDEF IB7_UP} SQL_BOOLEAN : Result := BoolToStr(PSmallint(sqldata)^ = 1); {$ENDIF IB7_UP} SQL_SHORT : Result := IntToStr(PSmallint(sqldata)^); SQL_INT64 : Result := IntToStr(PInt64(sqldata)^); SQL_TEXT : DecodeWideString(SQL_TEXT, Index, Result); SQL_VARYING : DecodeWideString(SQL_VARYING, Index, Result); SQL_BLOB : ReadBlob(Index, Result); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; end; end; function TSQLResult.GetAsVariant(const Index: Word): Variant; var ASQLCode: SmallInt; Dbl: Double; begin CheckRange(Index); with FXSQLDA.sqlvar[Index] do begin Result := NULL; if (sqlind <> nil) and (sqlind^ = -1) then Exit; ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : Result := PSmallInt(sqldata)^ / ScaleDivisor[sqlscale]; SQL_LONG : Result := PInteger(sqldata)^ / ScaleDivisor[sqlscale]; SQL_INT64, SQL_QUAD : Result := PInt64(sqldata)^ / ScaleDivisor[sqlscale]; SQL_DOUBLE : Result := PDouble(sqldata)^; else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : Result := PDouble(sqldata)^; SQL_TIMESTAMP : Result := TDateTime(DecodeTimeStamp(PISCTimeStamp(sqldata))); SQL_TYPE_DATE : begin Dbl := DecodeSQLDate(PInteger(sqldata)^); Result := TDateTime(Dbl); end; SQL_TYPE_TIME : Result := PCardinal(sqldata)^ / 864000000; SQL_LONG : Result := PInteger(sqldata)^; SQL_D_FLOAT, SQL_FLOAT : Result := PSingle(sqldata)^; {$IFDEF IB7_UP} SQL_BOOLEAN : Result := WordBool(PSmallint(sqldata)^); {$ENDIF IB7_UP} SQL_SHORT : Result := PSmallint(sqldata)^; {$IFDEF COMPILER6_UP} SQL_INT64 : Result := PInt64(sqldata)^; {$ELSE} SQL_INT64 : Result := Integer(PInt64(sqldata)^); {$ENDIF COMPILER6_UP} SQL_TEXT : Result := DecodeString(SQL_TEXT, Index); SQL_VARYING : Result := DecodeString(SQL_VARYING, Index); SQL_BLOB : ReadBlob(Index, Result); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; end; end; function TSQLDA.GetByNameIsBlob(const Name: String): boolean; begin Result := GetIsBlob(GetFieldIndex(Name)); end; function TSQLDA.GetByNameIsNull(const Name: String): boolean; begin Result := GetIsNull(GetFieldIndex(Name)); end; function TSQLDA.GetAsDateTime(const Index: Word): TDateTime; var ASQLCode: SmallInt; begin CheckRange(Index); with FXSQLDA.sqlvar[Index] do begin Result := 0; if (sqlind <> nil) and (sqlind^ = -1) then Exit; ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : Result := PSmallInt(sqldata)^ / ScaleDivisor[sqlscale]; SQL_LONG : Result := PInteger(sqldata)^ / ScaleDivisor[sqlscale]; SQL_INT64, SQL_QUAD : Result := PInt64(sqldata)^ / ScaleDivisor[sqlscale]; SQL_DOUBLE : Result := PDouble(sqldata)^; else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : Result := PDouble(sqldata)^; SQL_TIMESTAMP : DecodeTimeStamp(PISCTimeStamp(sqldata), Double(Result)); SQL_TYPE_DATE : DecodeSQLDate(PInteger(sqldata)^, Double(Result)); SQL_TYPE_TIME : Result := PCardinal(sqldata)^ / 864000000; SQL_LONG : Result := PInteger(sqldata)^; SQL_D_FLOAT, SQL_FLOAT : Result := PSingle(sqldata)^; {$IFDEF IB7_UP} SQL_BOOLEAN, {$ENDIF IB7_UP} SQL_SHORT : Result := PSmallint(sqldata)^; SQL_INT64 : Result := PInt64(sqldata)^; SQL_TEXT : Result := StrToDateTime(DecodeString(SQL_TEXT, Index)); SQL_VARYING : Result := StrToDateTime(DecodeString(SQL_VARYING, Index)); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; end; end; function TSQLDA.GetByNameAsDateTime(const Name: String): TDateTime; begin Result := GetAsDateTime(GetFieldIndex(Name)); end; function TSQLDA.GetIsNullable(const Index: Word): boolean; begin CheckRange(Index); Result := (FXSQLDA.sqlvar[Index].sqlind <> nil); end; function TSQLDA.GetByNameIsNullable(const Name: String): boolean; begin Result := GetIsNullable(GetFieldIndex(Name)); end; function TSQLDA.GetAsCurrency(const Index: Word): Currency; var ASQLCode: SmallInt; begin CheckRange(Index); with FXSQLDA.sqlvar[Index] do begin Result := 0; if (sqlind <> nil) and (sqlind^ = -1) then Exit; ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : Result := PSmallInt(sqldata)^ / ScaleDivisor[sqlscale]; SQL_LONG : Result := PInteger(sqldata)^ / ScaleDivisor[sqlscale]; SQL_INT64, SQL_QUAD : Result := PInt64(sqldata)^ / ScaleDivisor[sqlscale]; SQL_DOUBLE : Result := PDouble(sqldata)^; else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : Result := PDouble(sqldata)^; SQL_TIMESTAMP : Result := DecodeTimeStamp(PISCTimeStamp(sqldata)); SQL_TYPE_DATE : Result := DecodeSQLDate(PInteger(sqldata)^); SQL_TYPE_TIME : Result := PCardinal(sqldata)^ / 864000000; SQL_LONG : Result := PInteger(sqldata)^; SQL_D_FLOAT, SQL_FLOAT : Result := PSingle(sqldata)^; {$IFDEF IB7_UP} SQL_BOOLEAN, {$ENDIF IB7_UP} SQL_SHORT : Result := PSmallint(sqldata)^; SQL_INT64 : Result := PInt64(sqldata)^; SQL_TEXT : Result := StrToFloat(DecodeString(SQL_TEXT, Index)); SQL_VARYING : Result := StrToFloat(DecodeString(SQL_VARYING, Index)); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; end; end; function TSQLDA.GetByNameAsCurrency(const Name: String): Currency; begin Result := GetAsCurrency(GetFieldIndex(Name)); end; function TSQLDA.GetAsBoolean(const Index: Word): boolean; var ASQLCode: SmallInt; begin CheckRange(Index); with FXSQLDA.sqlvar[Index] do begin Result := False; if (sqlind <> nil) and (sqlind^ = -1) then Exit; ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : Result := PSmallInt(sqldata)^ div ScaleDivisor[sqlscale] <> 0; SQL_LONG : Result := PInteger(sqldata)^ div ScaleDivisor[sqlscale] <> 0; SQL_INT64, SQL_QUAD : Result := PInt64(sqldata)^ div ScaleDivisor[sqlscale] <> 0; SQL_DOUBLE : Result := Trunc(PDouble(sqldata)^) > 0; else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : Result := Trunc(PDouble(sqldata)^) <> 0; SQL_LONG : Result := PInteger(sqldata)^ <> 0; SQL_D_FLOAT, SQL_FLOAT : Result := Trunc(PSingle(sqldata)^) <> 0; {$IFDEF IB7_UP} SQL_BOOLEAN, {$ENDIF IB7_UP} SQL_SHORT : Result := PSmallint(sqldata)^ <> 0; SQL_INT64 : Result := PInt64(sqldata)^ <> 0; SQL_TEXT : Result := StrToInt(DecodeString(SQL_TEXT, Index)) <> 0; SQL_VARYING : Result := StrToInt(DecodeString(SQL_VARYING, Index)) <> 0; else raise EUIBConvertError.Create(EUIB_CASTERROR); end; end; end; function TSQLDA.GetByNameAsBoolean(const Name: String): boolean; begin Result := GetAsBoolean(GetFieldIndex(Name)); end; function TSQLDA.GetByNameIsNumeric(const Name: String): boolean; begin result := GetIsNumeric(GetFieldIndex(Name)); end; function TSQLDA.GetIsNumeric(const Index: Word): boolean; begin CheckRange(Index); result := (FXSQLDA.sqlvar[Index].SqlScale < 0); end; function TSQLDA.GetAsWideString(const Index: Word): WideString; function BoolToStr(const Value: boolean): string; begin if Value then result := sUIBTrue else result := sUIBFalse; end; var ASQLCode: SmallInt; begin CheckRange(Index); Result := ''; with FXSQLDA.sqlvar[Index] do begin if (sqlind <> nil) and (sqlind^ = -1) then Exit; ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : Result := FloatToStr(PSmallInt(sqldata)^ / ScaleDivisor[sqlscale]); SQL_LONG : Result := FloatToStr(PInteger(sqldata)^ / ScaleDivisor[sqlscale]); SQL_INT64, SQL_QUAD : Result := FloatToStr(PInt64(sqldata)^ / ScaleDivisor[sqlscale]); SQL_DOUBLE : Result := FloatToStr(PDouble(sqldata)^); else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : Result := FloatToStr(PDouble(sqldata)^); SQL_TIMESTAMP : Result := DateTimeToStr(DecodeTimeStamp(PISCTimeStamp(sqldata))); SQL_TYPE_DATE : Result := DateToStr(DecodeSQLDate(PInteger(sqldata)^)); SQL_TYPE_TIME : Result := TimeToStr(PCardinal(sqldata)^ / 864000000); SQL_LONG : Result := IntToStr(PInteger(sqldata)^); SQL_D_FLOAT, SQL_FLOAT : Result := FloatToStr(PSingle(sqldata)^); {$IFDEF IB7_UP} SQL_BOOLEAN : Result := BoolToStr(PSmallint(sqldata)^ = 1); {$ENDIF IB7_UP} SQL_SHORT : Result := IntToStr(PSmallint(sqldata)^); SQL_INT64 : Result := IntToStr(PInt64(sqldata)^); SQL_TEXT : DecodeWideString(SQL_TEXT, Index, Result); SQL_VARYING : DecodeWideString(SQL_VARYING, Index, Result); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; end; end; function TSQLDA.GetByNameAsWideString(const Name: String): WideString; begin Result := GetAsWideString(GetFieldIndex(Name)); end; function TSQLDA.GetFieldType(const Index: Word): TUIBFieldType; begin CheckRange(Index); if (FXSQLDA.sqlvar[Index].SqlScale < 0) then begin if FXSQLDA.sqlvar[Index].sqltype and not (1) = SQL_DOUBLE then Result := uftDoublePrecision else Result := uftNumeric; end else case FXSQLDA.sqlvar[Index].sqltype and not (1) of SQL_TEXT : Result := uftChar; SQL_VARYING : Result := uftVarchar; SQL_SHORT : Result := uftSmallint; SQL_LONG : Result := uftInteger; SQL_FLOAT, SQL_D_FLOAT : Result := uftFloat; SQL_DOUBLE : Result := uftDoublePrecision; SQL_TIMESTAMP : Result := uftTimestamp; SQL_BLOB : Result := uftBlob; SQL_ARRAY, SQL_QUAD : Result := uftQuad; SQL_TYPE_TIME : Result := uftTime; SQL_TYPE_DATE : Result := uftDate; SQL_INT64 : Result := uftInt64; {$IFDEF IB7_UP} SQL_BOOLEAN : Result := uftBoolean; {$ENDIF IB7_UP} else Result := uftUnKnown; end; end; function TSQLDA.GetAsDate(const Index: Word): Integer; var ASQLCode: SmallInt; begin CheckRange(Index); with FXSQLDA.sqlvar[Index] do begin Result := 0; if (sqlind <> nil) and (sqlind^ = -1) then Exit; ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : Result := PSmallInt(sqldata)^ div ScaleDivisor[sqlscale]; SQL_LONG : Result := PInteger(sqldata)^ div ScaleDivisor[sqlscale]; SQL_INT64, SQL_QUAD : Result := PInt64(sqldata)^ div ScaleDivisor[sqlscale]; SQL_DOUBLE : Result := Trunc(PDouble(sqldata)^); else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : Result := Trunc(PDouble(sqldata)^); SQL_TIMESTAMP : DecodeSQLDate(PISCTimeStamp(sqldata).timestamp_date, Result); SQL_TYPE_DATE : DecodeSQLDate(PInteger(sqldata)^, Result); SQL_TYPE_TIME : Result := 0; SQL_LONG : Result := PInteger(sqldata)^; SQL_D_FLOAT, SQL_FLOAT : Result := Trunc(PSingle(sqldata)^); {$IFDEF IB7_UP} SQL_BOOLEAN, {$ENDIF IB7_UP} SQL_SHORT : Result := PSmallint(sqldata)^; SQL_INT64 : Result := PInt64(sqldata)^; SQL_TEXT : Result := Trunc(StrToDate(DecodeString(SQL_TEXT, Index))); SQL_VARYING : Result := Trunc(StrToDate(DecodeString(SQL_VARYING, Index))); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; end; end; function TSQLDA.GetByNameAsDate(const Name: String): Integer; begin Result := GetAsDate(GetFieldIndex(Name)); end; function TSQLDA.GetAsTime(const Index: Word): Cardinal; var ASQLCode: SmallInt; begin CheckRange(Index); with FXSQLDA.sqlvar[Index] do begin Result := 0; if (sqlind <> nil) and (sqlind^ = -1) then Exit; ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : Result := PSmallInt(sqldata)^ div ScaleDivisor[sqlscale]; SQL_LONG : Result := PInteger(sqldata)^ div ScaleDivisor[sqlscale]; SQL_INT64, SQL_QUAD : Result := PInt64(sqldata)^ div ScaleDivisor[sqlscale]; SQL_DOUBLE : Result := Trunc(PDouble(sqldata)^); else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : Result := Trunc(PDouble(sqldata)^); SQL_TIMESTAMP : Result := PISCTimeStamp(sqldata).timestamp_time; SQL_TYPE_DATE : Result := 0; SQL_TYPE_TIME : Result := PCardinal(sqldata)^; SQL_LONG : Result := PInteger(sqldata)^; SQL_D_FLOAT, SQL_FLOAT : Result := Trunc(PSingle(sqldata)^); {$IFDEF IB7_UP} SQL_BOOLEAN, {$ENDIF IB7_UP} SQL_SHORT : Result := PSmallint(sqldata)^; SQL_INT64 : Result := PInt64(sqldata)^; SQL_TEXT : Result := StrToInt(DecodeString(SQL_TEXT, Index)); SQL_VARYING : Result := StrToInt(DecodeString(SQL_VARYING, Index)); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; end; end; function TSQLDA.GetByNameAsTime(const Name: String): Cardinal; begin Result := GetAsTime(GetFieldIndex(Name)); end; { TMemoryPool } constructor TMemoryPool.Create(ItemSize, ItemsInPage: Integer); const PageSizeAdjustment = SizeOf(TPageInfo); MaxPageSize = (64 * 1024) + (PageSizeAdjustment * 2); var RealItemSize, TestSize: Integer; const MinItemSize = SizeOf(Word) + SizeOf(Pointer); function Max(a, b : Integer) : Integer; {$IFDEF FPC} begin if a > b then Result := a else Result := b; end; {$ELSE} asm cmp eax, edx jge @@Exit mov eax, edx @@Exit: end; {$ENDIF FPC} begin inherited Create; FList := TList.Create; FItemSize := Max(ItemSize, MinItemSize); FItemsInPage := ItemsInPage; RealItemSize := FItemSize + sizeof(Word); TestSize := (RealItemSize * FItemsInPage) + PageSizeAdjustment; if (TestSize > MaxPageSize) then begin FItemsInPage := (MaxPageSize - PageSizeAdjustment) div RealItemSize; TestSize := (RealItemSize * FItemsInPage) + PageSizeAdjustment; end; FPageSize := TestSize; end; function TSQLResult.GetUniqueRelationName: string; var i: integer; begin result := ''; if FXSQLDA.sqln > 1 then for i := 0 to FXSQLDA.sqln - 2 do if not ((FXSQLDA.sqlvar[i].RelNameLength = FXSQLDA.sqlvar[i+1].RelNameLength) and (CompareText(FXSQLDA.sqlvar[i].RelName, FXSQLDA.sqlvar[i+1].RelName) = 0)) then exit; if FXSQLDA.sqln > 0 then SetString(Result, FXSQLDA.sqlvar[0].RelName, FXSQLDA.sqlvar[0].RelNameLength); end; function TSQLParams.GetFieldName(const Index: Word): string; begin CheckRange(Index); SetString(Result, FXSQLDA.sqlvar[Index].ParamName, FXSQLDA.sqlvar[Index].ParamNameLength); end; procedure TSQLParams.AddFieldType(const Name: string; FieldType: TUIBFieldType; Scale: TScale = 1; Precision: byte = 0); begin case FieldType of uftNumeric : begin case Precision of 0..4: SetFieldType(AddField(name), SizeOf(Smallint), SQL_SHORT + 1, -scale); 5..7: SetFieldType(AddField(name), SizeOf(Integer) , SQL_LONG + 1 , -scale); else SetFieldType(AddField(name), SizeOf(Int64), SQL_INT64 + 1, -scale); end; end; uftChar, uftVarchar, uftCstring : SetFieldType(AddField(name), 0 , SQL_TEXT + 1, 0); uftSmallint : SetFieldType(AddField(name), SizeOf(Smallint) , SQL_SHORT + 1, 0); uftInteger : SetFieldType(AddField(name), SizeOf(Integer) , SQL_LONG + 1, 0); uftQuad : SetFieldType(AddField(name), SizeOf(TISCQuad) , SQL_QUAD + 1, 0); uftFloat : SetFieldType(AddField(name), SizeOf(Single) , SQL_FLOAT + 1, 0); uftDoublePrecision : SetFieldType(AddField(name), SizeOf(Double) , SQL_DOUBLE + 1, 0); uftTimestamp : SetFieldType(AddField(name), SizeOf(TISCTimeStamp), SQL_TIMESTAMP + 1, 0); uftBlob, uftBlobId : SetFieldType(AddField(name), SizeOf(TISCQuad) , SQL_BLOB + 1, 0); uftDate : SetFieldType(AddField(name), SizeOf(Integer) , SQL_TYPE_DATE + 1, 0); uftTime : SetFieldType(AddField(name), SizeOf(Cardinal) , SQL_TYPE_TIME + 1, 0); uftInt64 : SetFieldType(AddField(name), SizeOf(Int64) , SQL_INT64 + 1, 0); {$IFDEF IB7_UP} uftBoolean : SetFieldType(AddField(name), SizeOf(Smallint) , SQL_BOOLEAN + 1, 0); {$ENDIF IB7_UP} end; end; procedure TSQLParams.SetFieldType(const Index: Word; Size: Integer; Code, Scale: Smallint); var i: Word; begin CheckRange(Index); with FXSQLDA.sqlvar[Index] do if Init then // need to be set, cf addfield begin Init := False; // don't need to be set sqltype := Code; sqlscale := Scale; sqllen := Size; if (Size > 0) then GetMem(sqldata, Size) else sqldata := nil; if ParamNameLength > 0 then for i := 0 to GetAllocatedFields - 1 do if (i <> Index) and (ID = FXSQLDA.sqlvar[i].ID) then move(FXSQLDA.sqlvar[Index], FXSQLDA.sqlvar[i], SizeOf(TUIBSQLVar)-MaxParamLength-2); end; end; function TSQLParams.Parse(const SQL: string): string; const Identifiers: set of char = ['a'..'z', 'A'..'Z', '0'..'9', '_']; var Src: PChar; Dest, idlen: Word; procedure next; begin inc(dest); Result[dest] := Src^; inc(Src); end; procedure Skip(c: char); begin repeat next; if Src^ = c then begin Next; Break; end; until (Src^ = #0); end; {$IFDEF FPC} function PrevChar(c: pchar): char; begin dec(c); result := c^; end; {$ENDIF FPC} begin Clear; Src := PChar(SQL); Dest := 0; SetLength(Result, Length(SQL)); while true do case Src^ of // eof #0 : begin SetLength(Result, Dest); Exit; end; // normal comments '/' : if Src[1] = '*' then begin inc(Src, 2); while (Src^ <> #0) do if (Src^ = '*') and (Src[1] = '/') then begin inc(Src, 2); Break; end else inc(Src); end else next; // Firebird comments -- My comment + (eol or eof) {.$IFDEF FB15_UP} '-' : if Src[1] = '-' then begin inc(Src, 2); while not(Src^ in [#0, #13, #10]) do inc(Src); end else next; {.$ENDIF} // text '' '''': Skip(''''); // text "" '"' : Skip('"'); // Unnamed Input '?' : begin AddField(''); Next; end; // Named Input ':' : begin inc(dest); Result[dest] := '?'; inc(Src); idlen := 0; while Src[idlen] in Identifiers do inc(idlen); AddField(copy(Src, 0, idlen)); inc(Src, idlen); end; // skip everything when begin identifier found ! // in procedures 'b','B': begin if not ((dest > 0) and ({$IFDEF FPC}PrevChar(src){$ELSE}src[-1]{$ENDIF} in Identifiers)) and (CompareText(copy(Src, 0, 5), 'begin') = 0) and not (Src[5] in Identifiers) then while (Src^ <> #0) do Next else next; end; else next; end; end; function TSQLParams.GetFieldType(const Index: Word): TUIBFieldType; begin if IsNull[Index] and FXSQLDA.sqlvar[Index].Init then Result := uftUnKnown else Result := inherited GetFieldType(Index); end; function TSQLParams.GetFieldIndex(const name: String): Word; begin if not FindParam(name, Result) then raise Exception.CreateFmt(EUIB_PARAMSTRNOTFOUND, [name]); end; procedure TSQLParams.SetByNameAsBoolean(const Name: String; const Value: boolean); var Field: Word; begin if (Length(Name) > 0) and FindParam(Name, Field) then SetAsBoolean(Field, Value) else raise Exception.CreateFmt(EUIB_PARAMSTRNOTFOUND, [name]); end; procedure TSQLParams.SetByNameAsDate(const Name: String; const Value: Integer); var Field: Word; begin if (Length(Name) > 0) and FindParam(Name, Field) then SetAsDate(Field, Value) else raise Exception.CreateFmt(EUIB_PARAMSTRNOTFOUND, [name]); end; procedure TSQLParams.SetByNameAsCurrency(const Name: String; const Value: Currency); var Field: Word; begin if (Length(Name) > 0) and FindParam(Name, Field) then SetAsCurrency(Field, Value) else raise Exception.CreateFmt(EUIB_PARAMSTRNOTFOUND, [name]); end; procedure TSQLParams.SetByNameAsDateTime(const Name: String; const Value: TDateTime); var Field: Word; begin if (Length(Name) > 0) and FindParam(Name, Field) then SetAsDateTime(Field, Value) else raise Exception.CreateFmt(EUIB_PARAMSTRNOTFOUND, [name]); end; procedure TSQLParams.SetByNameAsDouble(const Name: String; const Value: Double); var Field: Word; begin if (Length(Name) > 0) and FindParam(Name, Field) then SetAsDouble(Field, Value) else raise Exception.CreateFmt(EUIB_PARAMSTRNOTFOUND, [name]); end; procedure TSQLParams.SetByNameAsInt64(const Name: String; const Value: Int64); var Field: Word; begin if (Length(Name) > 0) and FindParam(Name, Field) then SetAsInt64(Field, Value) else raise Exception.CreateFmt(EUIB_PARAMSTRNOTFOUND, [name]); end; procedure TSQLParams.SetByNameAsInteger(const Name: String; const Value: Integer); var Field: Word; begin if (Length(Name) > 0) and FindParam(Name, Field) then SetAsInteger(Field, Value) else raise Exception.CreateFmt(EUIB_PARAMSTRNOTFOUND, [name]); end; procedure TSQLParams.SetByNameAsQuad(const Name: String; const Value: TISCQuad); var Field: Word; begin if (Length(Name) > 0) and FindParam(Name, Field) then SetAsQuad(Field, Value) else raise Exception.CreateFmt(EUIB_PARAMSTRNOTFOUND, [name]); end; procedure TSQLParams.SetByNameAsSingle(const Name: String; const Value: Single); var Field: Word; begin if (Length(Name) > 0) and FindParam(Name, Field) then SetAsSingle(Field, Value) else raise Exception.CreateFmt(EUIB_PARAMSTRNOTFOUND, [name]); end; procedure TSQLParams.SetByNameAsSmallint(const Name: String; const Value: Smallint); var Field: Word; begin if (Length(Name) > 0) and FindParam(Name, Field) then SetAsSmallint(Field, Value) else raise Exception.CreateFmt(EUIB_PARAMSTRNOTFOUND, [name]); end; procedure TSQLParams.SetByNameAsString(const Name, Value: String); var Field: Word; begin if (Length(Name) > 0) and FindParam(Name, Field) then SetAsString(Field, Value) else raise Exception.CreateFmt(EUIB_PARAMSTRNOTFOUND, [name]); end; procedure TSQLParams.SetByNameAsWideString(const Name: String; const Value: WideString); var Field: Word; begin if (Length(Name) > 0) and FindParam(Name, Field) then SetAsWideString(Field, Value) else raise Exception.CreateFmt(EUIB_PARAMSTRNOTFOUND, [name]); end; procedure TSQLParams.SetByNameIsNull(const Name: String; const Value: boolean); var Field: Word; begin if (Length(Name) > 0) and FindParam(Name, Field) then SetIsNull(Field, Value) else raise Exception.CreateFmt(EUIB_PARAMSTRNOTFOUND, [name]); end; destructor TMemoryPool.Destroy; var Temp, Next : PPageInfo; begin Temp := FFirstPage; while Assigned(Temp) do begin Next := Temp^.NextPage; FreeMem(Temp, FPageSize); Temp := Next; end; FList.Free; inherited destroy; end; procedure TMemoryPool.AddPage; var Page : PPageInfo; Temp : PAnsiChar; Prev : Pointer; i : Integer; begin GetMem(Page, FPageSize); Page^.NextPage := FFirstPage; Page^.UsageCounter := 0; FFirstPage := Page; Temp := PAnsiChar(Page); inc(Temp, sizeof(Pointer) + sizeOf(Integer)); Prev := nil; for i := 0 to pred(FItemsInPage) do begin PWord(Temp)^ := Temp - PAnsiChar(Page); inc(Temp, sizeOf(Word)); PPointer(Temp)^ := Prev; Prev := Temp; inc(Temp, FItemSize); end; FFreeList := Prev; end; function TMemoryPool.New: Pointer; var Page : PPageInfo; Temp : PAnsiChar; begin if not Assigned(FFreeList) then AddPage; Result := FFreeList; FFreeList := PPointer(Result)^; Temp := Result; dec(Temp, sizeOf(Word)); dec(Temp, PWord(Temp)^); Page := PPageInfo(Temp); inc(Page^.UsageCounter); FList.Add(Result); end; function TMemoryPool.PageCount : Integer; var Temp : PPageInfo; begin Result := 0; Temp := FFirstPage; while Assigned(Temp) do begin inc(Result); Temp := Temp^.NextPage; end; end; function TMemoryPool.PageUsageCount(const PageIndex: Integer): Integer; var Index : Integer; Temp : PPageInfo; begin Result := -1; Index := 0; Temp := FFirstPage; while Assigned(Temp) and (Index <= PageIndex) do begin if Index = PageIndex then begin Result := Temp^.UsageCounter; break; end else begin inc(Index); Temp := Temp^.NextPage; end; end; end; procedure TMemoryPool.Dispose(var P: Pointer); var Page: PPageInfo; Temp: PAnsiChar; begin PPointer(P)^ := FFreeList; FFreeList := P; Temp := FFreeList; dec(Temp, sizeOf(Word)); dec(Temp, PWord(Temp)^); Page := PPageInfo(Temp); dec(Page^.UsageCounter); P := nil; end; procedure TMemoryPool.CleanFreeList(const PageStart: Pointer); var PageEnd : Pointer; ItemsFound : Integer; Prev : Pointer; Temp : Pointer; begin PageEnd := PAnsiChar(PageStart) + FPageSize; ItemsFound := 0; Prev := nil; Temp := FFreeList; while assigned(Temp) and (ItemsFound < FItemsInPage) do begin if (PAnsiChar(Temp) > PageStart) and (PAnsiChar(Temp) <= PageEnd) then begin inc(ItemsFound); if Temp = FFreeList then FFreeList := PPointer(Temp)^ else PPointer(Prev)^ := PPointer(Temp)^; Temp := PPointer(Temp)^; end else begin Prev := Temp; Temp := PPointer(Temp)^; end; end; end; function TMemoryPool.RemoveUnusedPages: Integer; var Next, Prev, Temp: PPageInfo; begin Result := 0; Prev := nil; Temp := FFirstPage; while assigned(Temp) do begin Next := Temp^.NextPage; if Temp^.UsageCounter = 0 then begin if Temp = FFirstPage then FFirstPage := Next else if assigned(Prev) then Prev^.NextPage := Next; CleanFreeList(Temp); Freemem(Temp, FPageSize); inc(Result); end else Prev := Temp; Temp := Next; end; end; function TMemoryPool.GetCount: Integer; begin Result := FList.Count; end; function TMemoryPool.GetItems(const Index: Integer): Pointer; begin Result := FList.Items[Index]; end; { TSQLParams } procedure TSQLParams.EncodeString(Code: Smallint; Index: Word; const str: String); var i: smallint; OldLen: SmallInt; NewLen: Integer; begin OldLen := FXSQLDA.sqlvar[Index].SqlLen; with FXSQLDA.sqlvar[Index] do case Code of SQL_TEXT : begin NewLen := Length(str); if NewLen = 0 then begin // interbase need a valid pointer if sqldata = nil then getmem(sqldata, 4); sqllen := 0; end else begin if sqldata = nil then getmem(sqldata, NewLen) else ReallocMem(sqldata, NewLen); sqllen := NewLen; Move(PChar(str)^, sqldata^, sqllen); end; end; SQL_VARYING : begin NewLen := Length(str); if NewLen = 0 then begin if sqldata = nil then begin // interbase need a valid pointer :( getmem(sqldata, 4); sqllen := 2; end; PVary(sqldata).vary_length := 0; end else begin if sqldata = nil then getmem(sqldata, NewLen+2) else ReallocMem(sqldata, NewLen+2); sqllen := NewLen + 2; PVary(sqldata).vary_length := NewLen; Move(PChar(str)^, PVary(sqldata).vary_string,PVary(sqldata).vary_length); end; end; end; // named parametters share the same memory !! with FXSQLDA.sqlvar[Index] do if (ParamNameLength > 0) and (OldLen <> SqlLen) then for i := 0 to FXSQLDA.sqln - 1 do if (FXSQLDA.sqlvar[i].ID = ID) then begin FXSQLDA.sqlvar[i].SqlData := SqlData; FXSQLDA.sqlvar[i].SqlLen := SqlLen; end; end; procedure TSQLParams.EncodeWideString(Code: Smallint; Index: Word; const str: WideString); var i: smallint; OldLen: SmallInt; NewLen: Integer; begin OldLen := FXSQLDA.sqlvar[Index].SqlLen; with FXSQLDA.sqlvar[Index] do case Code of SQL_TEXT : begin NewLen := Length(str) * 2; if NewLen = 0 then begin // interbase need a valid pointer :( if sqldata = nil then getmem(sqldata, 4); sqllen := 0; end else begin if sqldata = nil then getmem(sqldata, NewLen) else ReallocMem(sqldata, NewLen); sqllen := NewLen; Move(PWideChar(str)^, sqldata^, sqllen); end; end; SQL_VARYING : begin NewLen := Length(str) * 2; if NewLen = 0 then begin if sqldata = nil then begin getmem(sqldata, 4); sqllen := 2; end; PVary(sqldata).vary_length := 0; end else begin if sqllen = 0 then getmem(sqldata, NewLen+2) else ReallocMem(sqldata, NewLen+2); sqllen := NewLen + 2; PVary(sqldata).vary_length := NewLen; Move(PWideChar(str)^, PVary(sqldata).vary_string, PVary(sqldata).vary_length); end; end; end; // named parametters share the same memory !! with FXSQLDA.sqlvar[Index] do if (ParamNameLength > 0) and (OldLen <> SqlLen) then for i := 0 to FXSQLDA.sqln - 1 do if (FXSQLDA.sqlvar[i].ID = ID) then begin FXSQLDA.sqlvar[i].SqlData := SqlData; FXSQLDA.sqlvar[i].SqlLen := SqlLen; end; end; procedure TSQLParams.SetAsQuad(const Index: Word; const Value: TISCQuad); begin SetFieldType(Index, sizeof(TISCQuad), SQL_QUAD + 1); with FXSQLDA.sqlvar[Index] do begin case (sqltype and not(1)) of SQL_QUAD, SQL_DOUBLE, SQL_INT64, SQL_BLOB, SQL_ARRAY: PISCQuad(sqldata)^ := Value; else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; if (sqlind <> nil) then if CompareMem(@Value, @QuadNull, SizeOf(TIscQuad)) then sqlind^ := -1 else sqlind^ := 0; end; end; procedure TSQLParams.SetAsDateTime(const Index: Word; const Value: TDateTime); var ASQLCode: SmallInt; begin SetFieldType(Index, sizeof(TISCQuad), SQL_TIMESTAMP + 1); with FXSQLDA.sqlvar[Index] do begin ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : PSmallInt(sqldata)^ := Trunc(Value * ScaleDivisor[sqlscale]); SQL_LONG : PInteger(sqldata)^ := Trunc(Value * ScaleDivisor[sqlscale]); SQL_INT64, SQL_QUAD : PInt64(sqldata)^ := Trunc(Value * ScaleDivisor[sqlscale]); SQL_DOUBLE : PDouble(sqldata)^ := Value; else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : PDouble(sqldata)^ := Value; SQL_TIMESTAMP : EncodeTimeStamp(Value, PISCTimeStamp(sqldata)); SQL_TYPE_DATE : EncodeSQLDate(Value, PInteger(sqldata)^); SQL_TYPE_TIME : PCardinal(sqldata)^ := Round(Frac(Value) * 864000000); SQL_LONG : PInteger(sqldata)^ := Trunc(Value); SQL_D_FLOAT, SQL_FLOAT : PSingle(sqldata)^ := Value; {$IFDEF IB7_UP} SQL_BOOLEAN, {$ENDIF IB7_UP} SQL_SHORT : PSmallint(sqldata)^ := Trunc(Value); SQL_INT64 : PInt64(sqldata)^ := Trunc(Value); SQL_TEXT : EncodeString(SQL_TEXT, Index, DateTimeToStr(Value)); SQL_VARYING : EncodeString(SQL_VARYING, Index, DateTimeToStr(Value)); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; if (sqlind <> nil) then sqlind^ := 0; // not null end; end; procedure TSQLParams.SetAsDate(const Index: Word; const Value: Integer); var ASQLCode: SmallInt; begin SetFieldType(Index, sizeof(Integer), SQL_TYPE_DATE + 1); with FXSQLDA.sqlvar[Index] do begin ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : PSmallInt(sqldata)^ := Value * ScaleDivisor[sqlscale]; SQL_LONG : PInteger(sqldata)^ := Value * ScaleDivisor[sqlscale]; SQL_INT64, SQL_QUAD : PInt64(sqldata)^ := Value * ScaleDivisor[sqlscale]; SQL_DOUBLE : PDouble(sqldata)^ := Value; else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : PDouble(sqldata)^ := Value; SQL_TIMESTAMP : EncodeTimeStamp(Value, PISCTimeStamp(sqldata)); SQL_TYPE_DATE : EncodeSQLDate(Value, PInteger(sqldata)^); SQL_TYPE_TIME : PCardinal(sqldata)^ := 0; SQL_LONG : PInteger(sqldata)^ := Value; SQL_D_FLOAT, SQL_FLOAT : PSingle(sqldata)^ := Value; {$IFDEF IB7_UP} SQL_BOOLEAN, {$ENDIF IB7_UP} SQL_SHORT : PSmallint(sqldata)^ := Value; SQL_INT64 : PInt64(sqldata)^ := Value; SQL_TEXT : EncodeString(SQL_TEXT, Index, DateToStr(Value)); SQL_VARYING : EncodeString(SQL_VARYING, Index, DateToStr(Value)); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; if (sqlind <> nil) then sqlind^ := 0; // not null end; end; procedure TSQLParams.SetAsTime(const Index: Word; const Value: Cardinal); var ASQLCode: SmallInt; begin SetFieldType(Index, sizeof(Cardinal), SQL_TYPE_TIME + 1); with FXSQLDA.sqlvar[Index] do begin ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : PSmallInt(sqldata)^ := Value * ScaleDivisor[sqlscale]; SQL_LONG : PInteger(sqldata)^ := Value * ScaleDivisor[sqlscale]; SQL_INT64, SQL_QUAD : PInt64(sqldata)^ := Value * ScaleDivisor[sqlscale]; SQL_DOUBLE : PDouble(sqldata)^ := Value; else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : PDouble(sqldata)^ := Value; SQL_TIMESTAMP : EncodeTimeStamp(Value, PISCTimeStamp(sqldata)); SQL_TYPE_DATE : PInteger(sqldata)^ := 0; SQL_TYPE_TIME : PCardinal(sqldata)^ := Value; SQL_LONG : PInteger(sqldata)^ := Value; SQL_D_FLOAT, SQL_FLOAT : PSingle(sqldata)^ := Value; {$IFDEF IB7_UP} SQL_BOOLEAN, {$ENDIF IB7_UP} SQL_SHORT : PSmallint(sqldata)^ := Value; SQL_INT64 : PInt64(sqldata)^ := Value; SQL_TEXT : EncodeString(SQL_TEXT, Index, TimeToStr(Value)); SQL_VARYING : EncodeString(SQL_VARYING, Index, TimeToStr(Value)); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; if (sqlind <> nil) then sqlind^ := 0; // not null end; end; procedure TSQLParams.SetAsBoolean(const Index: Word; const Value: Boolean); var ASQLCode: SmallInt; begin {$IFDEF IB7_UP} SetFieldType(Index, sizeof(Smallint), SQL_BOOLEAN + 1); {$ELSE} SetFieldType(Index, sizeof(Smallint), SQL_SHORT + 1); {$ENDIF IB7_UP} with FXSQLDA.sqlvar[Index] do begin ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : PSmallInt(sqldata)^ := ord(Value) * ScaleDivisor[sqlscale]; SQL_LONG : PInteger(sqldata)^ := ord(Value) * ScaleDivisor[sqlscale]; SQL_INT64, SQL_QUAD : PInt64(sqldata)^ := ord(Value) * ScaleDivisor[sqlscale]; SQL_DOUBLE : PDouble(sqldata)^ := ord(Value); else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : PDouble(sqldata)^ := ord(Value); SQL_LONG : PInteger(sqldata)^ := ord(Value); SQL_D_FLOAT, SQL_FLOAT : PSingle(sqldata)^ := ord(Value); {$IFDEF IB7_UP} SQL_BOOLEAN, {$ENDIF IB7_UP} SQL_SHORT : PSmallint(sqldata)^ := ord(Value); SQL_INT64 : PInt64(sqldata)^ := ord(Value); SQL_TEXT : EncodeString(SQL_TEXT, Index, IntToStr(ord(Value))); SQL_VARYING : EncodeString(SQL_VARYING, Index, IntToStr(ord(Value))); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; if (sqlind <> nil) then sqlind^ := 0; // not null end; end; procedure TSQLParams.SetAsInteger(const Index: Word; const Value: Integer); var ASQLCode: SmallInt; begin SetFieldType(Index, sizeof(Integer), SQL_LONG + 1); with FXSQLDA.sqlvar[Index] do begin ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : PSmallInt(sqldata)^ := Value * ScaleDivisor[sqlscale]; SQL_LONG : PInteger(sqldata)^ := Value * ScaleDivisor[sqlscale]; SQL_INT64, SQL_QUAD : PInt64(sqldata)^ := Value * ScaleDivisor[sqlscale]; SQL_DOUBLE : PDouble(sqldata)^ := Value; else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : PDouble(sqldata)^ := Value; SQL_TIMESTAMP : EncodeTimeStamp(Value, PISCTimeStamp(sqldata)); SQL_TYPE_DATE : EncodeSQLDate(Value, PInteger(sqldata)^); SQL_TYPE_TIME : PCardinal(sqldata)^ := 0; SQL_LONG : PInteger(sqldata)^ := Value; SQL_D_FLOAT, SQL_FLOAT : PSingle(sqldata)^ := Value; {$IFDEF IB7_UP} SQL_BOOLEAN, {$ENDIF IB7_UP} SQL_SHORT : PSmallint(sqldata)^ := Value; SQL_INT64 : PInt64(sqldata)^ := Value; SQL_TEXT : EncodeString(SQL_TEXT, Index, IntToStr(Value)); SQL_VARYING : EncodeString(SQL_VARYING, Index, IntToStr(Value)); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; if (sqlind <> nil) then sqlind^ := 0; // not null end; end; procedure TSQLParams.SetAsSingle(const Index: Word; const Value: Single); var ASQLCode: SmallInt; begin SetFieldType(Index, sizeof(Single), SQL_FLOAT + 1); with FXSQLDA.sqlvar[Index] do begin ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : PSmallInt(sqldata)^ := Trunc(Value * ScaleDivisor[sqlscale]); SQL_LONG : PInteger(sqldata)^ := Trunc(Value * ScaleDivisor[sqlscale]); SQL_INT64, SQL_QUAD : PInt64(sqldata)^ := Trunc(Value * ScaleDivisor[sqlscale]); SQL_DOUBLE : PDouble(sqldata)^ := Value; else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : PDouble(sqldata)^ := Value; SQL_TIMESTAMP : EncodeTimeStamp(Value, PISCTimeStamp(sqldata)); SQL_TYPE_DATE : EncodeSQLDate(Value, PInteger(sqldata)^); SQL_TYPE_TIME : PCardinal(sqldata)^ := Round(Frac(Value) * 864000000); SQL_LONG : PInteger(sqldata)^ := Trunc(Value); SQL_D_FLOAT, SQL_FLOAT : PSingle(sqldata)^ := Value; {$IFDEF IB7_UP} SQL_BOOLEAN, {$ENDIF IB7_UP} SQL_SHORT : PSmallint(sqldata)^ := Trunc(Value); SQL_INT64 : PInt64(sqldata)^ := Trunc(Value); SQL_TEXT : EncodeString(SQL_TEXT, Index, FloatToStr(Value)); SQL_VARYING : EncodeString(SQL_VARYING, Index, FloatToStr(Value)); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; if (sqlind <> nil) then sqlind^ := 0; // not null end; end; procedure TSQLParams.SetAsSmallint(const Index: Word; const Value: Smallint); var ASQLCode: SmallInt; begin SetFieldType(Index, sizeof(Smallint), SQL_SHORT + 1); with FXSQLDA.sqlvar[Index] do begin ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : PSmallInt(sqldata)^ := Value * ScaleDivisor[sqlscale]; SQL_LONG : PInteger(sqldata)^ := Value * ScaleDivisor[sqlscale]; SQL_INT64, SQL_QUAD : PInt64(sqldata)^ := Value * ScaleDivisor[sqlscale]; SQL_DOUBLE : PDouble(sqldata)^ := Value; else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : PDouble(sqldata)^ := Value; SQL_TIMESTAMP : EncodeTimeStamp(Value, PISCTimeStamp(sqldata)); SQL_TYPE_DATE : EncodeSQLDate(Value, PInteger(sqldata)^); SQL_TYPE_TIME : PCardinal(sqldata)^ := 0; SQL_LONG : PInteger(sqldata)^ := Value; SQL_D_FLOAT, SQL_FLOAT : PSingle(sqldata)^ := Value; {$IFDEF IB7_UP} SQL_BOOLEAN, {$ENDIF IB7_UP} SQL_SHORT : PSmallint(sqldata)^ := Value; SQL_INT64 : PInt64(sqldata)^ := Value; SQL_TEXT : EncodeString(SQL_TEXT, Index, IntToStr(Value)); SQL_VARYING : EncodeString(SQL_VARYING, Index, IntToStr(Value)); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; if (sqlind <> nil) then sqlind^ := 0; // not null end; end; procedure TSQLParams.SetAsString(const Index: Word; const Value: String); var ASQLCode: SmallInt; begin SetFieldType(Index, Length(Value), SQL_TEXT + 1); with FXSQLDA.sqlvar[Index] do begin ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : PSmallInt(sqldata)^ := Trunc(StrToFloat(Value) * ScaleDivisor[sqlscale]); SQL_LONG : PInteger(sqldata)^ := Trunc(StrToFloat(Value) * ScaleDivisor[sqlscale]); SQL_INT64, SQL_QUAD : PInt64(sqldata)^ := Trunc(StrToFloat(Value) * ScaleDivisor[sqlscale]); SQL_DOUBLE : PDouble(sqldata)^ := StrToFloat(Value); else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : PDouble(sqldata)^ := StrToFloat(Value); SQL_TIMESTAMP : EncodeTimeStamp(StrToDateTime(Value), PISCTimeStamp(sqldata)); SQL_TYPE_DATE : EncodeSQLDate(StrToDate(Value), PInteger(sqldata)^); SQL_TYPE_TIME : PCardinal(sqldata)^ := Round(Frac(StrToTime(Value)) * 864000000); SQL_LONG : PInteger(sqldata)^ := Trunc(StrToFloat(Value)); SQL_D_FLOAT, SQL_FLOAT : PSingle(sqldata)^ := StrToFloat(Value); {$IFDEF IB7_UP} SQL_BOOLEAN, {$ENDIF IB7_UP} SQL_SHORT : PSmallint(sqldata)^ := Trunc(StrToFloat(Value)); SQL_INT64 : PInt64(sqldata)^ := Trunc(StrToFloat(Value)); SQL_TEXT : EncodeString(SQL_TEXT, Index, Value); SQL_VARYING : EncodeString(SQL_VARYING, Index, Value); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; if (sqlind <> nil) then sqlind^ := 0; end; end; procedure TSQLParams.SetAsWideString(const Index: Word; const Value: WideString); var ASQLCode: SmallInt; begin SetFieldType(Index, Length(Value), SQL_TEXT + 1); with FXSQLDA.sqlvar[Index] do begin ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : PSmallInt(sqldata)^ := Trunc(StrToFloat(Value) * ScaleDivisor[sqlscale]); SQL_LONG : PInteger(sqldata)^ := Trunc(StrToFloat(Value) * ScaleDivisor[sqlscale]); SQL_INT64, SQL_QUAD : PInt64(sqldata)^ := Trunc(StrToFloat(Value) * ScaleDivisor[sqlscale]); SQL_DOUBLE : PDouble(sqldata)^ := StrToFloat(Value); else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : PDouble(sqldata)^ := StrToFloat(Value); SQL_TIMESTAMP : EncodeTimeStamp(StrToDateTime(Value), PISCTimeStamp(sqldata)); SQL_TYPE_DATE : EncodeSQLDate(StrToDate(Value), PInteger(sqldata)^); SQL_TYPE_TIME : PCardinal(sqldata)^ := Round(Frac(StrToTime(Value)) * 864000000); SQL_LONG : PInteger(sqldata)^ := Trunc(StrToFloat(Value)); SQL_D_FLOAT, SQL_FLOAT : PSingle(sqldata)^ := StrToFloat(Value); {$IFDEF IB7_UP} SQL_BOOLEAN, {$ENDIF IB7_UP} SQL_SHORT : PSmallint(sqldata)^ := Trunc(StrToFloat(Value)); SQL_INT64 : PInt64(sqldata)^ := Trunc(StrToFloat(Value)); SQL_TEXT : EncodeWideString(SQL_TEXT, Index, Value); SQL_VARYING : EncodeWideString(SQL_VARYING, Index, Value); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; if (sqlind <> nil) then sqlind^ := 0; end; end; procedure TSQLParams.SetAsInt64(const Index: Word; const Value: Int64); var ASQLCode: SmallInt; begin SetFieldType(Index, sizeof(Int64), SQL_INT64 + 1); with FXSQLDA.sqlvar[Index] do begin ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : PSmallInt(sqldata)^ := Value * ScaleDivisor[sqlscale]; SQL_LONG : PInteger(sqldata)^ := Value * ScaleDivisor[sqlscale]; SQL_INT64, SQL_QUAD : PInt64(sqldata)^ := Value * ScaleDivisor[sqlscale]; SQL_DOUBLE : PDouble(sqldata)^ := Value; else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : PDouble(sqldata)^ := Value; SQL_TIMESTAMP : EncodeTimeStamp(Value, PISCTimeStamp(sqldata)); SQL_TYPE_DATE : EncodeSQLDate(Value, PInteger(sqldata)^); SQL_TYPE_TIME : PCardinal(sqldata)^ := 0; SQL_LONG : PInteger(sqldata)^ := Value; SQL_D_FLOAT, SQL_FLOAT : PSingle(sqldata)^ := Value; {$IFDEF IB7_UP} SQL_BOOLEAN, {$ENDIF IB7_UP} SQL_SHORT : PSmallint(sqldata)^ := Value; SQL_INT64 : PInt64(sqldata)^ := Value; SQL_TEXT : EncodeString(SQL_TEXT, Index, IntToStr(Value)); SQL_VARYING : EncodeString(SQL_VARYING, Index, IntToStr(Value)); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; if (sqlind <> nil) then sqlind^ := 0; // not null end; end; procedure TSQLParams.SetAsDouble(const Index: Word; const Value: Double); var ASQLCode: SmallInt; begin SetFieldType(Index, sizeof(double), SQL_DOUBLE + 1); with FXSQLDA.sqlvar[Index] do begin ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : PSmallInt(sqldata)^ := Trunc(Value * ScaleDivisor[sqlscale]); SQL_LONG : PInteger(sqldata)^ := Trunc(Value * ScaleDivisor[sqlscale]); SQL_INT64, SQL_QUAD : PInt64(sqldata)^ := Trunc(Value * ScaleDivisor[sqlscale]); SQL_DOUBLE : PDouble(sqldata)^ := Value; else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : PDouble(sqldata)^ := Value; SQL_TIMESTAMP : EncodeTimeStamp(Value, PISCTimeStamp(sqldata)); SQL_TYPE_DATE : EncodeSQLDate(Value, PInteger(sqldata)^); SQL_TYPE_TIME : PCardinal(sqldata)^ := Round(Frac(Value) * 864000000); SQL_LONG : PInteger(sqldata)^ := Trunc(Value); SQL_D_FLOAT, SQL_FLOAT : PSingle(sqldata)^ := Value; {$IFDEF IB7_UP} SQL_BOOLEAN, {$ENDIF IB7_UP} SQL_SHORT : PSmallint(sqldata)^ := Trunc(Value); SQL_INT64 : PInt64(sqldata)^ := Trunc(Value); SQL_TEXT : EncodeString(SQL_TEXT, Index, FloatToStr(Value)); SQL_VARYING : EncodeString(SQL_VARYING, Index, FloatToStr(Value)); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; if (sqlind <> nil) then sqlind^ := 0; // not null end; end; procedure TSQLParams.SetAsCurrency(const Index: Word; const Value: Currency); var ASQLCode: SmallInt; begin SetFieldType(Index, sizeof(Int64), SQL_INT64 + 1, -4); with FXSQLDA.sqlvar[Index] do begin ASQLCode := (sqltype and not(1)); // Is Numeric ? if (sqlscale < 0) then begin case ASQLCode of SQL_SHORT : PSmallInt(sqldata)^ := Trunc(Value * ScaleDivisor[sqlscale]); SQL_LONG : PInteger(sqldata)^ := Trunc(Value * ScaleDivisor[sqlscale]); SQL_INT64, SQL_QUAD : PInt64(sqldata)^ := Trunc(Value * ScaleDivisor[sqlscale]); SQL_DOUBLE : PDouble(sqldata)^ := Value; else raise EUIBConvertError.Create(EUIB_UNEXPECTEDERROR + ': ' + EUIB_CASTERROR); end; end else case ASQLCode of SQL_DOUBLE : PDouble(sqldata)^ := Value; SQL_TIMESTAMP : EncodeTimeStamp(Value, PISCTimeStamp(sqldata)); SQL_TYPE_DATE : EncodeSQLDate(Value, PInteger(sqldata)^); SQL_TYPE_TIME : PCardinal(sqldata)^ := Round(Frac(Value) * 864000000); SQL_LONG : PInteger(sqldata)^ := Trunc(Value); SQL_D_FLOAT, SQL_FLOAT : PSingle(sqldata)^ := Value; {$IFDEF IB7_UP} SQL_BOOLEAN, {$ENDIF IB7_UP} SQL_SHORT : PSmallint(sqldata)^ := Trunc(Value); SQL_INT64 : PInt64(sqldata)^ := Trunc(Value); SQL_TEXT : EncodeString(SQL_TEXT, Index, FloatToStr(Value)); SQL_VARYING : EncodeString(SQL_VARYING, Index, FloatToStr(Value)); else raise EUIBConvertError.Create(EUIB_CASTERROR); end; if (sqlind <> nil) then sqlind^ := 0; // not null end; end; procedure TSQLParams.SetIsNull(const Index: Word; const Value: boolean); begin CheckRange(Index); with FXSQLDA.sqlvar[Index] do if (sqlind <> nil) then case Value of True : sqlind^ := -1; False : sqlind^ := 0; end; end; function TSQLParams.FindParam(const name: string; out Index: Word): boolean; var Field: Smallint; begin for Field := 0 to FXSQLDA.sqln - 1 do if FXSQLDA.sqlvar[Field].ParamNameLength = Length(name) then if StrLIComp(@FXSQLDA.sqlvar[Field].ParamName, PChar(Name), FXSQLDA.sqlvar[Field].ParamNameLength) = 0 then begin Result := true; Index := Field; Exit; end; Result := False; end; function TSQLParams.AddField(const Name: string): Word; var num: Word; len: Cardinal; begin len := Length(Name); if len > MaxParamLength then raise Exception.CreateFmt(EUIB_SIZENAME, [Name]); Result := FXSQLDA.sqln; if (len > 0) and FindParam(Name, num) then begin inc(FXSQLDA.sqln); inc(FXSQLDA.sqld); ReallocMem(FXSQLDA, XSQLDA_LENGTH(FXSQLDA.sqln)); move(FXSQLDA.sqlvar[num], FXSQLDA.sqlvar[Result], SizeOf(TUIBSQLVar)); end else begin inc(FXSQLDA.sqln); inc(FXSQLDA.sqld); ReallocMem(FXSQLDA, XSQLDA_LENGTH(FXSQLDA.sqln)); inc(FParamCount); with FXSQLDA.sqlvar[Result] do begin Init := True; ID := FParamCount; ParamNameLength := len; if ParamNameLength > 0 then move(Pointer(Name)^, ParamName[0], ParamNameLength); sqltype := SQL_TEXT + 1; // tip: don't allocate memory if not defined sqlscale := 0; sqlsubtype := 0; sqllen := 0; sqldata := nil; GetMem(sqlind, 2); // Can be NULL sqlind^ := -1; // NULL end; end; end; constructor TSQLParams.Create; begin inherited Create; GetMem(FXSQLDA, XSQLDA_LENGTH(0)); FillChar(FXSQLDA^, XSQLDA_LENGTH(0), 0); FXSQLDA.sqln := 0; FXSQLDA.sqld := 0; FXSQLDA.version := SQLDA_CURRENT_VERSION; FParamCount := 0; end; destructor TSQLParams.Destroy; begin Clear; FreeMem(FXSQLDA); inherited; end; procedure TSQLParams.Clear; var i, j: Smallint; begin for i := 0 to FXSQLDA.sqln - 1 do begin if (FXSQLDA.sqlvar[i].sqlind <> nil) then begin freemem(FXSQLDA.sqlvar[i].sqldata); freemem(FXSQLDA.sqlvar[i].sqlind); // don't free shared pointers for j := i + 1 to FXSQLDA.sqln - 1 do if (FXSQLDA.sqlvar[i].ID = FXSQLDA.sqlvar[j].ID) then begin FXSQLDA.sqlvar[j].sqldata := nil; FXSQLDA.sqlvar[j].sqlind := nil; end; end; end; FXSQLDA.sqln := 0; FXSQLDA.sqld := 0; ReallocMem(FXSQLDA, XSQLDA_LENGTH(0)); FParamCount := 0; end; {$IFDEF USEJVCL} {$IFDEF UNITVERSIONING} initialization RegisterUnitVersion(HInstance, UnitVersioning); finalization UnregisterUnitVersion(HInstance); {$ENDIF UNITVERSIONING} {$ENDIF USEJVCL} end.