Archivado/Componentes.Terceros.SDAC
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
master
Componentes.Terceros.SDAC/internal/4.10.0.10/1/Source/OLEDBAccess.pas
david fff1b2a4dc Importación inicial 
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.SDAC@3 6f543ec7-021b-7e4c-98c9-62eafc7fb9a8
2007-10-05 14:48:18 +00:00

10208 lines
321 KiB
ObjectPascal
Raw Permalink Blame History

//////////////////////////////////////////////////
// SQL Server Data Access Components
// Copyright © 1998-2007 Core Lab. All right reserved.
// Access via OLE DB
//////////////////////////////////////////////////
{$IFNDEF CLR}
{$I Sdac.inc}
unit OLEDBAccess;
{$ENDIF}
interface
uses
{$IFDEF CLR}
Borland.Vcl.TypInfo, Variants,
{$ELSE}
CLRClasses,
{$ENDIF}
Windows, Classes, DBConsts,
{$IFNDEF LITE}
DB, DBAccess,
{$ENDIF}
{$IFDEF VER6P}
FMTBcd,
{$ENDIF}
DAConsts, SysUtils, ActiveX, SyncObjs, OLEDBC, OLEDBIntf, CRAccess, MemData,
MSConsts, CRThread, ComObj;
const
DefaultSDACDatabase = 'master';
DefaultPacketSize = 4096;
DefaultConnectionTimeout = 15;
OLE_DB_INDICATOR_SIZE = sizeof(DWORD);
MaxNonBlobFieldLen = 8000; // Maximum length of "char", "varchar", "nchar", "nvarchar", fields
// properties
prOleDBBase = 1000;
// connection properties
prDatabase = prOleDBBase; // string
prIsolationLevel = prOleDBBase + 1; // TIsolationLevel
prAuthentication = prOleDBBase + 2; // TMSAuthentication
// dataset options
prReadOnly = prOleDBBase + 6; // boolean
prEnableBCD = prOleDBBase + 7; // boolean
prUniqueRecords = prOleDBBase + 8; // boolean
prCursorType = prOleDBBase + 9; // TMSCursorType
prRequestSQLObjects = prOleDBBase + 10; // boolean
prCursorUpdate = prOleDBBase + 12; // boolean
prLockClearMultipleResults = prOleDBBase + 13; // boolean
prConnectionTimeout = prOleDBBase + 14; // integer
prCommandTimeout = prOleDBBase + 15; // integer
prQuotedIdentifier = prOleDBBase + 16; // boolean
prLanguage = prOleDBBase + 17; // string
prEncrypt = prOleDBBase + 18; // boolean
prNetworkLibrary = prOleDBBase + 19; // string
prPacketSize = prOleDBBase + 20; // integer
prRoAfterUpdate = prOleDBBase + 21; // boolean
//prMultipleConnections = prOleDBBase + 18; // boolean
// if False then unicode fields is supported as TStringsField else as TWideStringField
prWideStrings = prOleDBBase + 22; // boolean
prApplicationName = prOleDBBase + 23; // string
prWorkstationID = prOleDBBase + 24; // string
{$IFDEF VER6P}
prEnableFMTBCD = prOleDBBase + 25; // boolean
{$ENDIF}
prAutoTranslate = prOleDBBase + 26; // boolean
prIsSProc = prOleDBBase + 27; // boolean
prProvider = prOleDBBase + 28; // string
prCanReadParams = prOleDBBase + 29; // boolean
prPersistSecurityInfo = prOleDBBase + 30; // boolean
prInitialFileName = prOleDBBase + 31; // string
prMARS = prOleDBBase + 32; // boolean
prSmartRefresh = prOleDBBase + 33; // boolean
prSmartRefreshMsg = prOleDBBase + 34; // string
prSmartRefreshService = prOleDBBase + 35; // string
prNonBlocking = prOleDBBase + 36; // boolean
prOldPassword = prOleDBBase + 37; // string
prMaxDatabaseSize = prOleDBBase + 38; // integer
prFailoverPartner = prOleDBBase + 39; // string
type
TCursorTypeChangedProc = procedure of object;
TMSCursorType = (ctDefaultResultSet, ctStatic, ctKeyset, ctDynamic);
TMSCursorTypes = set of TMSCursorType;
TReadParamsProc = procedure of object;
{ internal data types }
const
dtMSXML = 100;
{ internal sub data types }
const
dtChar = 20;
dtText = 22;
dtWide = $8000;
const
ServerCursorTypes: TMSCursorTypes = [ctStatic, ctKeyset, ctDynamic];
type
TOLEDBParamDesc = class(TParamDesc)
protected
FOLEDBType: DBTYPE; // Native OLE DB datatype
FUseDefaultValue: boolean;
property OLEDBType: DBTYPE read FOLEDBType write FOLEDBType;
property UseDefaultValue: boolean read FUseDefaultValue write FUseDefaultValue;
public
function GetOLEDBType: DBTYPE;
procedure SetOLEDBType(Value: DBTYPE); virtual;
function GetUseDefaultValue: boolean;
procedure SetUseDefaultValue(Value: boolean);
function GetValue: variant; override;
function GetAsBlobRef: TBlob;
procedure SetNull(const Value: boolean); override;
end;
TRunMethod = procedure of object;
TOLEDBThreadWrapper = class(TCRThreadWrapper)
protected
procedure DoException(E: Exception); override;
end;
TExecuteThread = class(TCRThread)
protected
FRunMethod: TRunMethod;
procedure InternalExecute; override;
{$IFDEF CLR}
property Terminated;
{$ENDIF}
end;
{ TOLEDBConnection }
TOLEDBProvider = (prAuto, prSQL, prNativeClient, prCompact);
TMSAuthentication = (auWindows, auServer);
TIsolationLevel = (ilReadCommitted, ilReadUnCommitted, ilRepeatableRead, ilIsolated, ilSnapshot);
EMSError = class;
// TMSErrorProc = procedure (E: {$IFDEF LITE}Exception{$ELSE}EDAError{$ENDIF}; var Fail: boolean) of object;
TMSInfoMessageProc = procedure (E: EMSError) of object;
// ----------
// Must be declared before(!) TOLEDBConnection declaration to prevent CBuilder compiler bug (pas -> hpp)
{
AccessorBlock types:
1. Ordinary. May contain many ordinary fields and only one BLOB field
1.1. For DefaultResultSet or for CursorUpdate = False. All fields in block must be not ReadOnly
1.2. In other cases ReadOnly and not ReadOnly fields may contains in one AccessorBlock
2. ReadOnly. Used only for KeySet and Dynamic if CursorUpdate is True. All fields in block must be ReadOnly
3. BLOB. May contain only one BLOB field
4. FetchBlock. Used for dtVariant and dtMemo (not BLOB) fields
RecordSet may contain only one each of accessor types, and some BLOB accessors if need
}
TAccessorBlockType = (abOrdinary, abReadOnly, abBLOB, abFetchBlock);
TAccessorBlock = record
BlockType: TAccessorBlockType;
hAcc: HACCESSOR; // OLE DB accessor
BlobFieldNum: integer; // -1, if BLOB field not avaible. This member useful to fetch BLOB streams
FieldNums: array of integer;
end;
TOLEDBRecordSet = class;
TRestrictions = array of OleVariant;
TOLEDBConnection = class (TCRConnection)
protected
//FIMalloc: IMalloc;
{ DataSource }
FIDBInitialize: IDBInitialize;
FIDBProperties: IDBProperties;
FIDBCreateSession: IDBCreateSession;
{ Session }
FISessionProperties: ISessionProperties;
FITransactionLocal: ITransactionLocal;
FCommand: TCRCommand; // Used for ExecSQL. Created on first use
FDatabase: string;
FIsolationLevel: TIsolationLevel;
// FMultipleConnections: boolean;
FMaxDatabaseSize: integer; // Comact Edition
FAuthentication: TMSAuthentication;
FProvider: TOLEDBProvider;
// Init properties
FConnectionTimeout: integer;
FQuotedIdentifier: boolean;
FLanguage: string;
FAutoTranslate: boolean;
FEncrypt: boolean;
FPersistSecurityInfo: boolean;
FNetworkLibrary: string;
FPacketSize: integer;
FApplicationName: string;
FWorkstationID: string;
FInitialFileName: string;
FFailoverPartner: string;
FMultipleActiveResultSets: boolean;
FOldPassword: string;
FDBMSName: string;
FDBMSVer: string;
FDBMSPrimaryVer: integer;
FProviderFriendlyName: string;
FProviderVer: string;
FProviderPrimaryVer: integer;
FProviderId: TGuid;
FColumnsRowsetFieldDescs: TFieldDescs; // FieldDescs for non-Native rowsets
FColumnsMetaInfo: TOLEDBRecordSet; // ColumnsRowset
{$IFNDEF LITE}
FFldCatalogNameIdx, FFldSchemaNameIdx, FFldTableNameIdx, FFldColumnNameIdx,
FFldFieldNameIdx, FFldActualFieldNameIdx, FFldPrecisionIdx, FFldScaleIdx, FFldGuidIdx: integer;
FFldColumnNumberIdx, FFldIsAutoIncIdx, FFldTypeIdx, FFldFlagsIdx, FFldColumnSizeIdx, FFldComputeModeIdx: integer;
FFldXMLSchemaCollCatalogNameIdx, FFldXMLSchemaCollSchemaNameIdx, FFldXMLSchemaCollNameIdx: integer;
{$ENDIF}
FOnInfoMessage: TMSInfoMessageProc;
procedure ReleaseInterfaces;
function GetSchemaRowset(const Schema: TGUID; rgRestrictions: TRestrictions): IRowset;
procedure GetConnectionProperties;
procedure SetConnectionProperties;
procedure SetQuotedIdentifier(const Value: boolean);
procedure ExecSQL(const Text: string);
class procedure AssignFieldDescs(Source, Dest: TFieldDescs);
{$IFDEF CLR}
procedure DoError(E: Exception; var Fail: boolean); override;
{$ENDIF}
procedure CreateDatabase(const Database: string; const Password: string; const Encrypted: boolean);
public
constructor Create; override;
destructor Destroy; override;
procedure Check(const Status: HRESULT; Component: TObject); virtual;
procedure OLEDBError(const ErrorCode: HRESULT; Component: TObject);
procedure Connect(const ConnectString: string); override;
procedure Disconnect; override;
procedure Assign(Source: TOLEDBConnection);
procedure SetIDBCreateSession(CreateSession: IDBCreateSession);
{ Transaction control }
procedure StartTransaction; override;
procedure Commit; override;
procedure Rollback; override;
function SetProp(Prop: integer; const Value: variant): boolean; override;
function GetProp(Prop: integer; var Value: variant): boolean; override;
procedure SetDatabase(const Value: string);
function CheckIsValid: boolean; override;
//property Malloc: IMalloc read FIMalloc;
property SessionProperties: ISessionProperties read FISessionProperties;
property DBProperties: IDBProperties read FIDBProperties;
property DBMSName: string read FDBMSName;
property DBMSVer: string read FDBMSVer;
property DBMSPrimaryVer: integer read FDBMSPrimaryVer;
property ProviderFriendlyName: string read FProviderFriendlyName;
property ProviderVer: string read FProviderVer;
property ProviderPrimaryVer: integer read FProviderPrimaryVer;
property OnInfoMessage: TMSInfoMessageProc read FOnInfoMessage write FOnInfoMessage;
end;
{ TOLEDBCommand }
TIntPtrDynArray = array of IntPtr;
TParamsAccessorData = record
Accessor: IAccessor;
ExecuteParams: DBPARAMS;
rgBindings: TDBBindingArray;
end;
TOLEDBCommand = class (TCRCommand)
protected
FQueryIntCnt: integer; // Quantity of calls to QueryInterfaces
FIsSProc: boolean;
FRPCCall: boolean;
FPrepared: boolean;
FConnection: TOLEDBConnection;
FBreakExecCS: TCriticalSection; // Used to prevent clear FICommandText on BreakExec
FWaitForBreak: boolean;
// If statement executed w/o errors and warnings then FLastExecWarning is False
// If statement executed with warning then FLastExecWarning is True
// If statement executed with error then raising exception
// Used to analyze CursorType changes in RecordSet
FLastExecWarning: boolean;
FCommandTimeout: integer;
{ Smart Refresh}
FSmartRefresh: boolean;
FSmartRefreshMsg: string;
FSmartRefreshService: string;
{ NonBlocking}
FNonBlocking: boolean;
FISSAsynchStatus: ISSAsynchStatus;
FExecutor: TOLEDBThreadWrapper;
{ Command }
FICommandText: ICommandText;
FICommandPrepare: ICommandPrepare;
FICommandProperties: ICommandProperties;
{ Rowset }
FRequestIUnknown: boolean; // Indicate current command owner - MSSQL(False) or MSDataSet(True)
FRequestMultipleResults: boolean; // True for ctDefaultResultSet only
FIUnknown: IUnknown; // If requested then must be setted to a nil as it possible
FIUnknownNext: IUnknown;
FIMultipleResults: IMultipleResults;
FCursorState: TCursorState;
{ Params }
FParamsAccessorData: TParamsAccessorData;
FParamsAccessorDataAvaible: boolean;
FCanReadParams: boolean;
{$IFDEF CLR}
FParamsGC: TIntPtrDynArray; // List of AllocGCHandle(ParamDesc.Value, True)
{$ENDIF}
{ Rows }
FRowsAffected: integer;
FRowsAffectedNext: integer;
FReadParams: TReadParamsProc;
FNextResultRequested: boolean; // FIUnknownNext getted from OLE DB
procedure Check(const Status: HRESULT); virtual;
procedure QueryInterfaces(const QueryPrepare: boolean); // QueryPrepare must be True to request IID_ICommandPrepare
procedure ReleaseInterfaces;
procedure SetCommandProp;
procedure SetParameterInfo;
{ Params }
procedure CreateAndFillParamAccs;
procedure RequestParamsIfPossible; // Call RequestAndFreeParamAccs if interfaces is cleared
procedure CheckAndAnalyze(const Status: HRESULT);
procedure GetNextResult(out ResultSet: IUnknown; out RowsAffected: integer);
public
constructor Create; override;
destructor Destroy; override;
procedure Prepare; override;
procedure Unprepare; override;
function GetPrepared: boolean; override;
function CreateProcCall(Name: string; const NeedDescribe: boolean; const WideStrings: boolean;
const EnableBcd: boolean; const EnableFmtBcd: boolean): string;
procedure Execute(Iters: integer = 1); override;
procedure DoExecuteTerminate(Sender: TObject);
procedure DoExecuteException(Sender: TObject; E: Exception; var Fail: boolean);
procedure WaitAsynchCompletion;
procedure EndExecute(E: Exception);
procedure SetConnection(Value: TCRConnection); override;
function GetCursorState: TCursorState; override;
procedure SetCursorState(Value: TCursorState); override;
function GetProp(Prop: integer; var Value: variant): boolean; override;
function SetProp(Prop: integer; const Value: variant): boolean; override;
procedure BreakExec;
// Interface management
function IUnknownIsNull: boolean;
function IUnknownNextIsNull: boolean;
function IMultipleResultsIsNull: boolean;
function ISSAsynchStatusIsNull: boolean;
procedure ClearIUnknown;
procedure ClearIUnknownNext;
procedure ClearIMultipleResults;
procedure ClearISSAsynchStatus;
{ Params }
function GetParamDescType: TParamDescClass; override;
function AddParam: TParamDesc; override;
function GetParam(Index: integer): TOLEDBParamDesc;
property Params;
property ReadParams: TReadParamsProc read FReadParams write FReadParams;
property Executing;
end;
{ TOLEDBRecordSet }
TFetchAccessorData = record
Accessor: IAccessor;
AccessorBlocks: array of TAccessorBlock;
end;
TOLEDBFieldDesc = class (TCRFieldDesc)
private
FOLEDBType: DBTYPE; // Native OLE DB datatype
FIsAutoIncrement: boolean;
FBaseCatalogName: string;
FBaseColumnName: string;
FBaseSchemaName: string;
FBaseTableName: string;
FIsTimestamp: boolean;
FXMLSchemaCollectionCatalogName: string;
FXMLSchemaCollectionSchemaName: string;
FXMLSchemaCollectionName: string;
FXMLTyped: boolean;
public
function ActualNameQuoted(RecordSet: TCRRecordSet; const QuoteNames: boolean): string; override;
property OLEDBType: DBTYPE read FOLEDBType; // Native OLE DB datatype
property BaseCatalogName: string read FBaseCatalogName;
property BaseSchemaName: string read FBaseSchemaName;
property BaseTableName: string read FBaseTableName;
property BaseColumnName: string read FBaseColumnName;
property IsAutoIncrement: boolean read FIsAutoIncrement;
property IsTimestamp: boolean read FIsTimestamp;
property XMLSchemaCollectionCatalogName: string read FXMLSchemaCollectionCatalogName;
property XMLSchemaCollectionSchemaName: string read FXMLSchemaCollectionSchemaName;
property XMLSchemaCollectionName: string read FXMLSchemaCollectionName;
property XMLTyped: boolean read FXMLTyped;
end;
TOLEDBTableInfo = class(TCRTableInfo)
protected
FMaxTimestamp: Int64;
public
class function LeftQuote: Char; override;
class function RightQuote: Char; override;
property MaxTimestamp: Int64 read FMaxTimestamp write FMaxTimestamp;
end;
TOLEDBRecordSet = class (TCRRecordSet)
private
FProviderPrimaryVer: integer;
FDBMSPrimaryVer: integer;
FProviderId: TGuid;
FProvider: TOLEDBProvider;
FDisconnectedMode: boolean;
FDatabase: string;
function GetProviderPrimaryVer: integer;
function GetDBMSPrimaryVer: integer;
function GetProviderId: TGuid;
function GetProvider: TOLEDBProvider;
function GetDisconnectedMode: boolean;
function GetDatabase: string;
protected
FLockClearMultipleResults: boolean; // Used to prevent clear FCommand.FIMultipleResult on Close by OpenNext
FroAfterUpdate: boolean; // DataSet.RefreshOptions.roAfterUpdate
FNativeRowset: boolean; // For non-native rowsets output parameters not supported
FIsColumnsRowset: boolean; // If True then FieldDescs was stored in FColumnsRowsetFieldDescs
FCommand: TOLEDBCommand;
FFetchAccessorData: TFetchAccessorData;
{ Rowset }
FIRowset: IRowset;
FIRowsetLocate: IRowsetLocate;
FIRowsetUpdate: IRowsetUpdate;
FCursorType: TMSCursorType;
FReadOnly: boolean;
FRequestSQLObjects: boolean;
FEnableBCD: boolean;
{$IFDEF VER6P}
FEnableFMTBCD: boolean;
{$ENDIF}
FUniqueRecords: boolean;
FWideStrings: boolean;
// Bookmarks
FFetchFromBookmark: boolean;
FProcessDynBofEof: boolean; // True, if processing NoResult for ctDynamic
FBookmarkValue: integer; // OLEDB IRowsetLocate Bookmark value. If FBookmarkValue = - 1 then last fetch is not OK for KeySet cursor
FBookmarkSize: integer; // OLEDB IRowsetLocate Bookmark size. If FBookmarkSize = 4 then bookmark is ordinal otherwise bookmark is special (DBBMK_LAST, DBBMK_FIRST)
FBookmarkOffset: integer; // Offset from pHBlock to bookmark field value
FFetchBlock: IntPtr;
FFetchBlockSize: integer;
FLastFetchOK: boolean; // True, if previous Fetch was called succesfulity (Result is True)
FLastFetchEnd: boolean; // True, If previous FIRowset.GetNextRows has return DB_S_ENDOFROWSET
FLastFetchBack: boolean; // True, if previous Fetch was called with True parameter
// HRow for IRowsetUpdate
FHRow: HRow;
FHRowAccessible: boolean; // True, if FHRow is setted to valid value
FCursorUpdate: boolean;
FCursorTypeChanged: TCursorTypeChangedProc;
FSchema: TGUID;
FRestrictions: TRestrictions;
FFetching: boolean;
FFetchExecutor: TOLEDBThreadWrapper;
FBeforeFetch: boolean;
FAfterFetch: boolean;
FPopulatingKeyInfo: boolean;
procedure ClearHRowIfNeed;
procedure Check(const Status: HRESULT); virtual;
procedure CheckBCDOverflow(const FieldNo: integer {from 1}; RecBuf: IntPtr);
procedure CheckAndAnalyzeFieldsStatus(const Status: HRESULT; const pRec: IntPtr);
procedure QueryCommandInterfaces(const QueryPrepare: boolean); // Create ConnectionSwap if need. Call FCommand.QueryInterfaces.
procedure ReleaseCommandInterfaces;
procedure QueryRecordSetInterfaces; // Reqests IRowset, IRowsetLocate, IRowsetUpdate
procedure ReleaseRecordSetInterfaces;
procedure ReleaseAllInterfaces(const ReleaseMultipleResults: boolean);
procedure CreateCommand; override;
procedure SetCommand(Value: TCRCommand); override;
{ Open / Close }
function NeedInitFields: boolean; override;
procedure InternalPrepare; override;
procedure InternalUnPrepare; override;
procedure InternalOpen; override;
procedure InternalClose; override;
{ Fields }
procedure InternalInitFields; override;
function GetIndicatorSize: word; override;
{ Fetch }
procedure AllocFetchBlock; // Also create fetch accessors
function Fetch(FetchBack: boolean = False): boolean; override;
procedure FreeFetchBlock; // Also free fetch accessors
function CanFetchBack: boolean; override; // Return True, if BlockMan is store only one block of records
{ Modify }
procedure RowsetUpdateCommit;
procedure RowsetUpdateRollback;
procedure InternalAppend(RecBuf: IntPtr); override;
procedure InternalDelete; override;
procedure InternalUpdate(RecBuf: IntPtr); override;
procedure InternalAppendOrUpdate(RecBuf: IntPtr; const IsAppend: boolean);
procedure SetCommandProp;
procedure RequestParamsIfPossible; // Call FCommand.RequestAndFreeParamAccs if interfaces is cleared
{ TablesInfo }
class function GetTableInfoClass: TTableInfoClass; override;
//PreCached FConection properties
property ProviderPrimaryVer: integer read GetProviderPrimaryVer;
property DBMSPrimaryVer: integer read GetDBMSPrimaryVer;
property ProviderID: TGuid read GetProviderId;
property Provider: TOLEDBProvider read GetProvider;
property DisconnectedMode: boolean read GetDisconnectedMode;
property Database: string read GetDatabase;
public
constructor Create; override;
destructor Destroy; override;
{ Fields}
function GetFieldDescType: TFieldDescClass; override;
{ Open / Close }
procedure ExecCommand; override;
procedure Open; override;
procedure Reopen; override;
function GetSchemaRowset(const Schema: TGUID; rgRestrictions: TRestrictions): IRowset;
procedure Disconnect; override;
{ Fetch }
procedure FetchAll; override;
procedure DoFetchAll; virtual;
procedure DoFetchTerminate(Sender: TObject);
procedure DoFetchException(Sender: TObject; E: Exception; var Fail: boolean);
procedure DoFetchSendEvent(Sender: TObject; Event: TObject);
procedure EndFetchAll(E: Exception); virtual;
procedure BreakFetch; override;
function CanDisconnect: boolean; override;
{ Fields }
function GetNull(FieldNo: word; RecBuf: IntPtr): boolean; override;
procedure SetNull(FieldNo: word; RecBuf: IntPtr; Value: boolean); override;
function GetStatus(FieldNo: word; RecBuf: IntPtr): DWORD;
procedure SetStatus(FieldNo: word; RecBuf: IntPtr; Value: DWORD);
procedure GetFieldData(Field: TFieldDesc; RecBuf: IntPtr; Dest: IntPtr); override;
procedure GetFieldAsVariant(FieldNo: word; RecBuf: IntPtr; var Value: variant);override;
procedure PutFieldData(Field: TFieldDesc; RecBuf: IntPtr; Source: IntPtr); override;
function IsBlobFieldType(DataType: word): boolean; override;
{ Records }
procedure InsertRecord(RecBuf: IntPtr); override;
procedure UpdateRecord(RecBuf: IntPtr); override;
procedure DeleteRecord; override;
{ Sorting }
procedure SetIndexFieldNames(Value: string); override;
{ Filter/Find/Locate }
procedure CreateComplexField(RecBuf: IntPtr; FieldIndex: integer; WithBlob: boolean); override;
procedure CreateComplexFields(RecBuf: IntPtr; WithBlob: boolean); override;
procedure FreeComplexFields(RecBuf: IntPtr; WithBlob: boolean); override;
{ Navigation }
procedure SetToBegin; override;
procedure SetToEnd; override;
//procedure GetBookmark(Bookmark: PRecBookmark); override;
procedure SetToBookmark(Bookmark: PRecBookmark); override;
function FetchToBookmarkValue(FetchBack: boolean = False): boolean; // Fetch to Bookmark. Bookmark value is stored in FBookmarkValue. Bookmark value used only for ctStatic and ctKeyset. For ctDynamic method refetched current record in specified direction
function CompareBookmarks(Bookmark1, Bookmark2: PRecBookmark): integer; override;
function RowsReturn: boolean; override;
function GetIRowset: IRowset;
function GetICommandText: ICommandText;
procedure SetIRowset(
Rowset: IRowset;
const IsColumnsRowset: boolean); // If True then FieldDescs was stored in FColumnsRowsetFieldDescs
function GetProp(Prop: integer; var Value: variant): boolean; override;
function SetProp(Prop: integer; const Value: variant): boolean; override;
property NativeRowset: boolean read FNativeRowset;
property CursorTypeChanged: TCursorTypeChangedProc read FCursorTypeChanged write FCursorTypeChanged;
property FetchExecutor: TOLEDBThreadWrapper read FFetchExecutor;
end;
{ TOLEDBPropertiesSet }
TOLEDBPropertiesSet = class
protected
FConnection: TOLEDBConnection;
FInitPropSet: PDBPROPSET;
procedure Check(const Status: HRESULT);
function GetInitPropSetStatus: string;
function GetDBPropPtr(Index: UINT): PDBProp;
function InitProp(const dwPropertyID: DBPROPID; const Required: boolean = False): PDBProp;
public
constructor Create(Connection: TOLEDBConnection; const GuidPropertySet: TGUID);
destructor Destroy; override;
// procedure AddProp(const dwPropertyID: DBPROPID; const Value: OleVariant);
procedure AddPropSmallInt(const dwPropertyID: DBPROPID; const Value: smallint);
procedure AddPropInt(const dwPropertyID: DBPROPID; const Value: integer);
procedure AddPropBool(const dwPropertyID: DBPROPID; const Value: boolean; const Required: boolean = False);
procedure AddPropStr(const dwPropertyID: DBPROPID; const Value: string; const Required: boolean = False);
procedure SetProperties(Obj: IDBProperties); overload;
procedure SetProperties(Obj: ISessionProperties); overload;
procedure SetProperties(Obj: ICommandProperties); overload;
property InitPropSet: PDBPROPSET read FInitPropSet;
end;
{ TOLEDBPropertiesGet }
TPropValues = array of Variant;
TOLEDBPropertiesGet = class
protected
FConnection: TOLEDBConnection;
FInitPropSet: PDBPROPSET;
FPropIds: array of DBPROPID;
FPropIdsGC: IntPtr;
procedure Check(const Status: HRESULT);
function GetDBPropPtr(rgProperties: PDBPropArray; Index: UINT): PDBProp;
procedure PrepareToGet;
procedure ProcessResult(rgPropertySets: PDBPropSet; var PropValues: TPropValues);
procedure ClearResult(rgPropertySets: PDBPropSet);
public
constructor Create(Connection: TOLEDBConnection; const GuidPropertySet: TGUID);
destructor Destroy; override;
procedure AddPropId(Id: DBPROPID);
procedure GetProperties(Obj: IDBProperties; var PropValues: TPropValues); overload;
procedure GetProperties(Obj: IRowsetInfo; var PropValues: TPropValues); overload;
procedure GetProperties(Obj: ICommandProperties; var PropValues: TPropValues); overload;
end;
{ TOLEDBErrors }
EOLEDBError = class;
TOLEDBErrors = class
protected
FList: TList;
function GetCount: integer;
function GetError(Index: Integer): EOLEDBError;
procedure Assign(Source: TOLEDBErrors);
procedure Clear;
public
constructor Create;
destructor Destroy; override;
property Count: integer read GetCount;
property Errors[Index: Integer]: EOLEDBError read GetError; default;
end;
{ EOLEDBError }
{$IFDEF LITE}
EOLEDBError = class(Exception)
protected
FErrorCode: integer;
public
property ErrorCode: integer read FErrorCode;
{$ELSE}
EOLEDBError = class(EDAError)
{$ENDIF}
protected
FErrors: TOLEDBErrors;
FOLEDBErrorCode: integer;
// GetBasicErrorInfo - ERRORINFO struct
// FhrError: HResult; - equal to FOLEDBErrorCode
// FMinor: UINT; - only for EMSError and equal to FMSSQLErrorCode
// Fclsid: TGUID; - always CLSID_SQLOLEDB
Fiid: TGUID;
// Fdispid: Integer; - always 0
// GetErrorInfo - IErrorInfo interface
// Fguid: TGUID; - same as Fiid
// FSource: WideString; - always "Microsoft OLE DB Provider for SQL Server"
// FDescription: WideString; - equal to Message
// FHelpFile: WideString; - not used by sqloledb
// FHelpContext: Longint; - not used by sqloledb
FMessageWide: WideString;
function GetErrorCount: integer;
function GetError(Index: Integer): EOLEDBError;
procedure Assign(Source: EOLEDBError); virtual;
protected
property iid: TGUID read Fiid;
public
constructor Create(ErrorCode: integer; Msg: WideString);
destructor Destroy; override;
property ErrorCount: integer read GetErrorCount;
property Errors[Index: Integer]: EOLEDBError read GetError; default;
property OLEDBErrorCode: integer read FOLEDBErrorCode;
property MessageWide: WideString read FMessageWide;
// property hrError: HResult read FhrError;
// property Minor: UINT read FMinor;
// property clsid: TGUID read Fclsid;
// property iid: TGUID read Fiid; - protected
// property dispid: Integer read Fdispid;
// property Source: WideString read FSource;
// property Description: WideString read FDescription;
end;
{ EMSError }
EMSError = class(EOLEDBError)
protected
FMSSQLErrorCode: integer;
FServerName: string;
FProcName: string;
FState: BYTE;
FSeverityClass: BYTE;
FLineNumber: WORD;
FLastMessage: string;
procedure Assign(Source: EOLEDBError); override;
public
constructor Create(
const pServerErrorInfo: SSERRORINFO;
OLEDBErrorCode: integer;
Msg: WideString); overload;
property MSSQLErrorCode: integer read FMSSQLErrorCode;
property ServerName: string read FServerName;
property ProcName: string read FProcName;
property State: BYTE read FState;
property SeverityClass: BYTE read FSeverityClass;
property LineNumber: WORD read FLineNumber;
property LastMessage: string read FLastMessage;
end;
function ConvertInternalTypeToOLEDB(const InternalType: word; const IsParam: boolean;
ServerVersion: Integer): word;
function ConvertOLEDBTypeToInternalFormat(
const OLEDBType: DBTYPE;
const IsLong: Boolean;
const EnableBCD, EnableFMTBCD: boolean;
const WideStrings: boolean;
const IsParam: boolean;
var InternalType: word; ServerVersion: Integer): boolean;
function DBNumericToBCD(Value: TDBNumeric): TBCD;
function BcdToDBNumeric(const Bcd: TBcd): TDBNumeric;
function DBNumericToDouble(Value: TDBNumeric): double;
function DoubleToDBNumeric(Value: double; Precision, Scale: integer): TDBNumeric;
function IsLargeDataTypeUsed(const FieldDesc: TFieldDesc): boolean; overload;
function IsLargeDataTypeUsed(const ParamDesc: TParamDesc): boolean; overload;
function GetProviderName(const Provider: TOLEDBProvider): string;
function GetProvider(const ProviderName: string): TOLEDBProvider;
const
slDelimiter = #1;
function BracketIfNeed(const Value: string): string; overload;
function BracketIfNeed(const Value: string; const LeftQ: char; const RightQ: char): string; overload;
function UnbracketIfPossible(const Value: string): string; overload;
function UnbracketIfPossible(const Value: string; var sl: string {Result parts in reverse order delimited by slDelimiter}): string; overload;
function UnbracketIfPossible(const Value: string; out DataBase: string; out Owner: string; out ObjName: string): string; overload;
function GenerateTableName(const CatalogName: string;
const SchemaName: string;
const TableName: string;
const DefaultCatalogName: string): string;
function ChangeDecimalSeparator(const Value: Variant): string;
function GetParamNameWODog(const ParamName: string): string;
{$IFDEF CLR}
procedure QueryIntf(Source: IUnknown; const IID: TInterfaceRef; out Intf); // OLE QueryInterface analog
{$ELSE}
procedure QueryIntf(Source: IUnknown; const IID: TGuid; out Intf); // OLE QueryInterface analog
{$ENDIF}
{$IFDEF DEBUG}
var
StreamCnt: integer = 0;
{$ENDIF}
var
__UseRPCCallStyle: boolean; // temporary
ParamsInfoOldBehavior: boolean; // delete 03.06.2006
//procedure AddInfoToErr(var S: string; const FormatStr: string; const Args: array of const); overload; // Add additional info to exception message
procedure AddInfoToErr(var E: Exception; const FormatStr: string; const Args: array of const); overload; // Add additional info to exception message
{$IFDEF SDAC_TEST}
var
__ServerPrepareCount: integer;
__ServerExecuteCount: integer;
__SetCommandPropCount: integer;
__SetRecordSetCommandPropCount: integer;
{$ENDIF}
const
LeftQuote = '[';
RightQuote = ']';
EmptyString = '';
const
BytesByRef = [dtBlob, dtBytes, dtVarBytes];
CharsByRef = [dtMemo, dtWideMemo, dtMSXML, dtString, dtWideString];
procedure FillBindingForParam(Ordinal: integer; ParamDesc: TOLEDBParamDesc; Connection: TOLEDBConnection;
var pBind: TDBBinding; var BindMemorySize: UINT; const ValueAvaliable: boolean; const IsWide: boolean);
procedure SaveParamValue(const ParamDesc: TParamDesc; const pBind: TDBBinding;
var ParamsAccessorData: TParamsAccessorData
{$IFDEF HAVE_COMPRESS}; const CompressBlobMode: TCompressBlobMode{$ENDIF}
{$IFDEF CLR}; var ParamsGC: TIntPtrDynArray{$ENDIF}; ServerVersion, ClientVersion: integer);
implementation
uses
MemUtils,
{$IFDEF VER6P}
DateUtils,
{$ENDIF}
{$IFDEF CLR}
System.Text, System.Runtime.InteropServices, System.Globalization, System.IO, System.Threading,
{$ELSE}
{$IFDEF VER6P}
Variants,
{$ENDIF}
{$ENDIF}
CRParser, MSParser, Math;
type
TOLEDBStream = class(TInterfacedObject, ISequentialStream)
protected
FSize: UINT;
FBlob: TBlob;
FPosInBlob: cardinal;
FStreamList: TList;
public
{$IFDEF CLR}
[PreserveSig]
function Read(
pv: IntPtr;
cb: Longint;
pcbRead: PLongint): HResult;
[PreserveSig]
function Write(
pv: IntPtr;
cb: Longint;
pcbWritten: PLongint): HResult;
{$ELSE}
function Read(pv: IntPtr; cb: Longint; pcbRead: PLongint): HResult;
stdcall;
function Write(pv: IntPtr; cb: Longint; pcbWritten: PLongint): HResult;
stdcall;
{$ENDIF}
public
constructor Create(Blob: TBlob {to avoid data copy}; StreamList: TList);
destructor Destroy; override;
property Size: UINT read FSize; // Return size of stream in bytes
end;
const
MaxLength = 130;
SizeOfLongWord = 4;
type
{$IFDEF CLR}
[StructLayout(LayoutKind.Sequential, Pack = 1, CharSet = CharSet.Auto)]
{$ENDIF}
RBigInteger = packed record
Data: array[0..MaxLength - 1] of LongWord;
DataLength: integer;
end;
const
SizeOfRBigInteger = 524;
type
PBigInteger = IntPtr;
TBigIntegerAccessor = class
protected
FSelfAllocated: boolean;
FBigIntegerPtr: PBigInteger;
procedure SetBigIntegerPtr(Value: PBigInteger);
function GetDataLength: integer;
procedure SetDataLength(Value: integer);
function GetDataPtr: IntPtr;
function GetData(Index: integer): LongWord;
procedure SetData(Index: integer; Value: LongWord);
function GetBigInteger: RBigInteger;
procedure SetBigInteger(const Value: RBigInteger);
public
constructor Create(BigIntegerPtr: PBigInteger; Allocate: boolean);
destructor Destroy; override;
procedure ClearData;
property DataLength: integer read GetDataLength write SetDataLength;
property DataPtr: IntPtr read GetDataPtr;
property Data[Index: integer]: LongWord read GetData write SetData;
property BigIntegerPtr: PBigInteger read FBigIntegerPtr write SetBigIntegerPtr;
property BigInteger: RBigInteger read GetBigInteger write SetBigInteger;
end;
TBigInteger = class
public
class procedure CreatePBigIntegerPtr(PBigInt: PBigInteger);
class procedure CreateRBigIntegerStruct(var BigInt: RBigInteger);
class procedure CreatePBigInteger64(PBigInt: PBigInteger; Value: Int64);
class procedure CreatePBigIntegerBCD(PBigInt: PBigInteger; const Value: TBcd);
class function Add(PBigInt1: PBigInteger; PBigInt2: PBigInteger): RBigInteger;
class function NEGATEPtr(PBigInt: PBigInteger): RBigInteger;
class function NEGATE(const BigInt: RBigInteger): RBigInteger;
class function Mul(PBigInt1: PBigInteger; PBigInt2: PBigInteger): RBigInteger;
class function Mul64(PBigInt1: PBigInteger; Value: Int64): RBigInteger;
end;
var
dstSmallint: IntPtr;
dstInt: IntPtr;
dstReal: IntPtr;
dstFloat: IntPtr;
dstMoney: IntPtr;
dstDateTime: IntPtr;
dstNVarChar: IntPtr;
dstNVarCharMax: IntPtr;
dstVarChar: IntPtr;
dstVarCharMax: IntPtr;
dstBit: IntPtr;
dstTinyInt: IntPtr;
dstBigint: IntPtr;
dstSql_variant: IntPtr;
dstImage: IntPtr;
dstBinary: IntPtr;
dstVarBinary: IntPtr;
dstGuid: IntPtr;
var
IsWindowsVista: boolean;
{$IFNDEF CLR}
GlobaIMalloc: IMalloc;
{$ENDIF}
procedure FreeCoMem(ptr: IntPtr);
begin
{$IFDEF CLR}
Marshal.FreeCoTaskMem(ptr);
{$ELSE}
if GlobaIMalloc = nil then
CoGetMalloc(1, GlobaIMalloc);
GlobaIMalloc.Free(ptr);
{$ENDIF}
end;
{$IFDEF LITE}
procedure DatabaseError(const Message: string; Component: TComponent = nil);
begin
if Assigned(Component) and (Component.Name <> '') then
raise Exception.Create(Format('%s: %s', [Component.Name, Message])) else
raise Exception.Create(Message);
end;
procedure DatabaseErrorFmt(const Message: string; const Args: array of const;
Component: TComponent = nil);
begin
DatabaseError(Format(Message, Args), Component);
end;
{$ENDIF}
procedure AddInfoToErr(var S: WideString; const FormatStr: string; const Args: array of const); overload; // Add additional info to exception message
var
s1: WideString;
begin
s1 := Format(FormatStr, Args);
if s1 <> '' then
S := S + #10 + s1;
end;
procedure AddInfoToErr(var E: Exception; const FormatStr: string; const Args: array of const); overload; // Add additional info to exception message
var
S: WideString;
{ $IFDEF CLR}
ENew: Exception;
{ $ENDIF}
begin
if IsClass(E, EOLEDBError) then
S := EOLEDBError(E).MessageWide
else
S := E.Message;
AddInfoToErr(S, FormatStr, Args);
{ $IFDEF CLR}
if IsClass(E, EMSError) then begin
ENew := EMSError.Create(EMSError(E).ErrorCode, S);
EMSError(ENew).Assign(EMSError(E));
end
else
if IsClass(E, EOLEDBError) then begin
ENew := EOLEDBError.Create(EOLEDBError(E).ErrorCode, S);
EOLEDBError(ENew).Assign(EOLEDBError(E));
end
else
{$IFNDEF LITE}
if IsClass(E, EDAError) then
ENew := EDAError.Create(EDAError(E).ErrorCode, S)
else
{$ENDIF}
ENew := Exception.Create(S);
E := ENew;
{ $ELSE}
// E.Message := S;
{ $ENDIF}
end;
{$WARNINGS OFF}
function ConvertInternalTypeToOLEDB(const InternalType: word; const IsParam: boolean;
ServerVersion: Integer): word;
begin
case InternalType of
// Integer fields
dtBoolean:
Result := DBTYPE_BOOL;
dtInt8:
if ServerVersion <> 3 then
Result := DBTYPE_I1
else
Result := DBTYPE_UI1;
dtWord:
if ServerVersion <> 3 then
Result := DBTYPE_I2
else
Result := DBTYPE_UI2;
dtInt16:
Result := DBTYPE_I2;
dtInt32:
Result := DBTYPE_I4;
dtUInt32:
Result := DBTYPE_UI4;
dtInt64:
Result := DBTYPE_I8;
// Float fields
dtFloat:
Result := DBTYPE_R8;
dtCurrency:
if ServerVersion <> 3 then
Result := DBTYPE_R8
// Result := DBTYPE_CY; Currency type cannot be used over TCurrencyField uses double to store
else
Result := DBTYPE_CY;
// Multibyte fields
dtDateTime:
if ServerVersion <> 3 then
Result := DBTYPE_DATE
else
Result := DBTYPE_DBTIMESTAMP;
dtDate, dtTime:
Result := DBTYPE_DATE;
dtString:
Result := DBTYPE_STR;
dtWideString:
Result := DBTYPE_WSTR;
dtExtString:
Result := DBTYPE_STR;
dtExtWideString:
Result := DBTYPE_WSTR;
dtBytes, dtVarBytes:
Result := DBTYPE_BYTES;
dtExtVarBytes:
Result := DBTYPE_BYTES;
dtMemo, dtWideMemo, dtMSXML, dtBlob:
Result := DBTYPE_IUNKNOWN;
{$IFDEF VER5P}
dtGuid:
Result := DBTYPE_GUID;
dtVariant:
Result := DBTYPE_VARIANT;
{$ENDIF}
dtBCD:
if ServerVersion <> 3 then
Result := DBTYPE_CY
else
Result := DBTYPE_NUMERIC;
{$IFDEF VER6P}
dtFmtBCD:
if IsParam and (ServerVersion <> 3) then
Result := DBTYPE_STR
else
Result := DBTYPE_NUMERIC;
{$ENDIF}
dtUnknown:
Result := DBTYPE_VARIANT;
else
Assert(False, Format('Invalid internal field type $%X (%d)', [InternalType, InternalType]));
end;
end;
{$WARNINGS ON}
function ConvertOLEDBTypeToInternalFormat(
const OLEDBType: DBTYPE;
const IsLong: boolean;
const EnableBCD, EnableFMTBCD: boolean;
const WideStrings: boolean;
const IsParam: boolean;
var InternalType: word; ServerVersion: Integer): boolean;
begin
Result := True;
case OLEDBType of // List of types must be synchronized with InternalInitFields types list
// Integer fields
DBTYPE_BOOL:
InternalType := dtBoolean;
DBTYPE_UI1:
InternalType := dtWord;
DBTYPE_I2:
InternalType := dtInt16;
DBTYPE_I4:
InternalType := dtInt32;
DBTYPE_UI2, DBTYPE_UI4:{WAR For OLE DB info only. Signed/unsigned conversion}
if ServerVersion <> 3 then
InternalType := dtInt32
else
case OLEDBType of
DBTYPE_UI2:
InternalType := dtUInt16;
DBTYPE_UI4:
InternalType := dtUInt32;
end;
DBTYPE_I8:
InternalType := dtInt64;
// Float fields
DBTYPE_NUMERIC:
if EnableBCD then begin
{$IFDEF VER6P}
if EnableFMTBCD then
InternalType := dtFmtBCD
else
{$ENDIF}
InternalType := dtBCD;
end
else
InternalType := dtFloat;
DBTYPE_R4, DBTYPE_R8:
InternalType := dtFloat;
DBTYPE_CY:
InternalType := dtCurrency;
// Multibyte fields
DBTYPE_DBTIMESTAMP, DBTYPE_DATE:
InternalType := dtDateTime;
DBTYPE_STR:
begin
if IsLong then
InternalType := dtMemo
else
InternalType := dtString;
end;
DBTYPE_WSTR:
begin
if IsLong then begin
if WideStrings then
InternalType := dtWideMemo
else
InternalType := dtMemo;
end
else
if WideStrings then
InternalType := dtWideString
else
InternalType := dtString;
end;
DBTYPE_BYTES:
begin
if IsLong then
InternalType := dtBlob
else
InternalType := dtBytes;
end;
DBTYPE_GUID:
{$IFDEF VER5P}
InternalType := dtGuid;
{$ELSE}
InternalType := dtString;
{$ENDIF}
DBTYPE_VARIANT:
{$IFDEF VER5P}
{$IFDEF LITE}
InternalType := dtString;
{$ELSE}
{$IFDEF CLR}
if IsParam and (ServerVersion = 9) then
InternalType := dtVariant
else
InternalType := dtString;
{$ELSE}
InternalType := dtVariant;
{$ENDIF}
{$ENDIF}
{$ELSE}
InternalType := dtString;
{$ENDIF}
DBTYPE_XML:
InternalType := dtMSXML;
DBTYPE_UDT:
InternalType := dtVarBytes;
else
Result := False;
end;
end;
function ConvertCRParamTypeToOLEDB(const InternalType: TParamDirection): word;
begin
case InternalType of
pdUnknown:
Result := DBPARAMIO_INPUT;
pdInput:
Result := DBPARAMIO_INPUT;
pdOutput, pdResult:
Result := DBPARAMIO_OUTPUT;
pdInputOutput:
Result := DBPARAMIO_INPUT + DBPARAMIO_OUTPUT;
else
Result := DBPARAMIO_INPUT;
end;
end;
{$WARNINGS OFF}
function ConvertOLEDBParamTypeToCR(const Value: word): TParamDirection;
begin
case Value of
DBPARAMTYPE_INPUT:
Result := pdInput;
DBPARAMTYPE_INPUTOUTPUT:
Result := pdInputOutput;
DBPARAMTYPE_RETURNVALUE:
Result := pdResult;
else
Assert(False, Format('Invalid value %d', [Value]));
end;
end;
{$WARNINGS ON}
{$WARNINGS OFF}
function ConvertIsolationLevelToOLEDBIsoLevel(const Value: TIsolationLevel):Integer;
begin
case Value of
ilReadCommitted:
Result := ISOLATIONLEVEL_READCOMMITTED;
ilReadUnCommitted:
Result := ISOLATIONLEVEL_READUNCOMMITTED;
ilRepeatableRead:
Result := ISOLATIONLEVEL_REPEATABLEREAD;
ilIsolated:
Result := ISOLATIONLEVEL_ISOLATED;
ilSnapshot:
Result := ISOLATIONLEVEL_SNAPSHOT;
else
Assert(False, Format('Invalid value %d', [Integer(Value)]));
end;
end;
{$WARNINGS ON}
{$IFNDEF CLR}
const
SizeOfFraction = 32;
{$ENDIF}
function DBNumericToBCD(Value: TDBNumeric): TBCD;
var
i, j, k: integer;
SignificantBytes: integer;
Remainder, tmp: word;
{$IFDEF CLR}
ResultCLR: array[0..33] of byte;
{$ENDIF}
function FindStart: boolean;
begin
SignificantBytes := 16;
while (SignificantBytes > 0) and (Value.Val[SignificantBytes - 1] = 0) do
dec(SignificantBytes);
Result := SignificantBytes > 0;
end;
begin
if Value.Sign = 0 then
{$IFDEF CLR}ResultCLR[1]{$ELSE}Result.SignSpecialPlaces{$ENDIF} := (1 shl 7) + Value.Scale
else
{$IFDEF CLR}ResultCLR[1]{$ELSE}Result.SignSpecialPlaces{$ENDIF} := (0 shl 7) + Value.Scale;
if not FindStart then begin
{$IFDEF CLR}
for i := 2 to 33 do
ResultCLR[i] := 0;
Result.FromBytes(ResultCLR);
{$ELSE}
System.FillChar(Result.Fraction, Length(Result.Fraction), 0);
{$ENDIF}
{$IFDEF CLR}ResultCLR[0]{$ELSE}Result.Precision{$ENDIF} := 8; // if value is zero
{$IFDEF CLR}ResultCLR[1]{$ELSE}Result.SignSpecialPlaces{$ENDIF} := 2;
{$IFDEF CLR}
Result.FromBytes(ResultCLR);
{$ENDIF}
exit;
end;
{$IFDEF CLR}
for i := 2 to 33 do
ResultCLR[i] := 0;
Result.FromBytes(ResultCLR);
{$ELSE}
System.FillChar(Result.Fraction, Length(Result.Fraction), 0);
{$ENDIF}
k := SignificantBytes - 1;
j := 31;
while k >= 0 do begin
Remainder := 0;
for i := k downto 0 do begin
tmp := (Byte(Value.Val[i]) + Remainder);
Value.Val[i] := tmp div 100;
Remainder := (tmp mod 100) shl 8;
end;
{$IFDEF CLR}ResultCLR[j + 2]{$ELSE}Result.Fraction[j]{$ENDIF} := (((Remainder shr 8) mod 10)) + (((Remainder shr 8) div 10) shl 4);
if Value.Val[k] = 0 then
dec(k);
dec(j);
end;
{$IFDEF CLR}ResultCLR[0]{$ELSE}Result.Precision{$ENDIF} := Value.Precision;
i := 31 - (Value.Precision div 2);
j := i;
if (Value.Precision mod 2) = 1 then begin
while i <= 30 do begin
{$IFDEF CLR}ResultCLR[i - j + 2]{$ELSE}Result.Fraction[i - j]{$ENDIF} :=
({$IFDEF CLR}ResultCLR[i + 2]{$ELSE}Result.Fraction[i]{$ENDIF} and $0f) shl 4 +
{$IFDEF CLR}ResultCLR[i + 1 + 2]{$ELSE}Result.Fraction[i + 1]{$ENDIF} shr 4;
inc(i);
end;
{$IFDEF CLR}ResultCLR[i - j + 2]{$ELSE}Result.Fraction[i - j]{$ENDIF} :=
({$IFDEF CLR}ResultCLR[i + 2]{$ELSE}Result.Fraction[i]{$ENDIF} and $0f) shl 4;
end
else begin
while i <= 30 do begin
{$IFDEF CLR}ResultCLR[i - j + 2]{$ELSE}Result.Fraction[i - j]{$ENDIF} :=
{$IFDEF CLR}ResultCLR[i + 1 + 2]{$ELSE}Result.Fraction[i + 1]{$ENDIF};
inc(i);
end;
end;
for i := 31 - j + 1 to 31 do
{$IFDEF CLR}ResultCLR[i + 2]{$ELSE}Result.Fraction[i]{$ENDIF} := 0;
{$IFDEF CLR}
Result := TBcd.FromBytes(ResultCLR);
{$ENDIF}
end;
{$IFNDEF VER6P}
function IsBcdNegative(const Bcd: TBcd): Boolean;
begin
Result := (Bcd.SignSpecialPlaces and (1 shl 7)) <> 0;
end;
{$ENDIF}
function BcdToDBNumeric(const Bcd: TBcd): TDBNumeric;
var
Value: TBigIntegerAccessor;
BytesCount: integer;
{$IFDEF CLR}
i: integer;
{$ENDIF}
begin
Value := TBigIntegerAccessor.Create(nil, True);
try
Value.ClearData;
TBigInteger.CreatePBigIntegerBCD(Value.BigIntegerPtr, Bcd);
if Value.DataLength > (Length(Result.val) div SizeOfLongWord) then
raise Exception.Create(SNumericOverflow);
Result.precision := Bcd.Precision;
Result.scale := Bcd.SignSpecialPlaces and $3F;
if IsBcdNegative(Bcd) then
Result.Sign := 0
else
Result.Sign := 1;
BytesCount := Result.precision div 2;
if (Result.precision mod 2) <> 0 then
Inc(BytesCount);
{$IFDEF CLR}
for i := 0 to BytesCount - 1 do
Result.val[i] := Marshal.ReadByte(Value.DataPtr, i);
{$ELSE}
FillChar(@Result.val[0], Length(Result.val), $00);
CopyBuffer(Value.DataPtr, @Result.val[0], BytesCount);
{$ENDIF}
finally
Value.Free;
end;
end;
{$IFNDEF VER6P}
const
MaxFMTBcdFractionSize = 64;
SInvalidBcdValue = '%s is not a valid BCD value';
type
{ Exception classes }
EBcdException = class(Exception);
EBcdOverflowException = class(EBcdException);
procedure OverflowError(const Message: string);
begin
raise EBcdOverflowException.Create(Message);
end;
procedure BcdErrorFmt(const Message, BcdAsString: string);
begin
raise EBcdException.Create(Format(Message, [BcdAsString]));
end;
function FractionToStr(const pIn: PChar; count: SmallInt;
DecPosition: ShortInt; Negative: Boolean;
StartWithDecimal: Boolean): string;
var
NibblesIn, BytesIn, DigitsOut: Integer;
P, POut: PChar;
Dot: Char;
procedure AddOneChar(Value: Char);
begin
P[0] := Value;
Inc(P);
Inc(DigitsOut);
end;
procedure AddDigit(Value: Char);
begin
if ((DecPosition > 0) and (NibblesIn = DecPosition)) or
((NibblesIn = 0) and StartWithDecimal) then
begin
if DigitsOut = 0 then AddOneChar('0');
AddOneChar(Dot);
end;
if (Value > #0) or (DigitsOut > 0) then
AddOneChar(Char(Integer(Value)+48));
Inc(NibblesIn);
end;
begin
POut := AllocMem(Count + 3); // count + negative/decimal/zero
try
Dot := DecimalSeparator;
P := POut;
DigitsOut := 0;
BytesIn := 0;
NibblesIn := 0;
while NibblesIn < Count do
begin
AddDigit(Char(Integer(pIn[BytesIn]) SHR 4));
if NibblesIn < Count then
AddDigit(Char(Integer(pIn[BytesIn]) AND 15));
Inc(BytesIn);
end;
while (DecPosition > 0) and (NibblesIn > DecPosition) and (DigitsOut > 1) do
begin
if POut[DigitsOut-1] = '0' then
begin
Dec(DigitsOut);
POut[DigitsOut] := #0;
end else
break;
end;
if POut[DigitsOut-1] = Dot then
Dec(DigitsOut);
POut[DigitsOut] := #0;
SetString(Result, POut, DigitsOut);
finally
FreeMem(POut, Count + 2);
end;
if Result = '' then Result := '0'
else if Negative then Result := '-' + Result;
end;
function BcdToStr(const Bcd: TBcd): string;
var
NumDigits: Integer;
pStart: PChar;
DecPos: SmallInt;
Negative: Boolean;
begin
if (Bcd.Precision = 0) or (Bcd.Precision > MaxFMTBcdFractionSize) then
OverFlowError(SBcdOverFlow)
else
begin
Negative := Bcd.SignSpecialPlaces and (1 shl 7) <> 0;
NumDigits := Bcd.Precision;
pStart := pCHAR(@Bcd.Fraction); // move to fractions
// use lower 6 bits of iSignSpecialPlaces.
if (Bcd.SignSpecialPlaces and 63) > 0 then
begin
DecPos := ShortInt(NumDigits - (Bcd.SignSpecialPlaces and 63));
end else
DecPos := NumDigits + 1; // out of range
Result := FractionToStr(pStart, NumDigits, DecPos, Negative,
(NumDigits = Bcd.SignSpecialPlaces and 63));
if Result[1] in ['0', '-'] then
if (Result = '-0') or (Result = '0.0') or (Result = '-0.0') then Result := '0';
end;
end;
function BcdToDouble(const Bcd: TBcd): Double;
begin
Result := StrToFloat(BcdToStr(Bcd));
end;
function InvalidBcdString(PValue: PChar): Boolean;
var
Dot: Char;
P: PChar;
begin
Dot := DecimalSeparator;
P := PValue;
Result := False;
while P^ <> #0 do
begin
if not (P^ in ['0'..'9', '-', Dot]) then
begin
Result := True;
break;
end;
Inc(P);
end;
end;
procedure StrToFraction(pTo: PChar; pFrom: PChar; count: SmallInt); pascal;
var
Dot: Char;
begin
Dot := DecimalSeparator;
asm
// From bytes to nibbles, both left aligned
PUSH ESI
PUSH EDI
PUSH EBX
MOV ESI,pFrom // move pFrom to ESI
MOV EDI,pTo // move pTo to EDI
XOR ECX,ECX // set ECX to 0
MOV CX,count // store count in CX
MOV DL,0 // Flag: when to store
CLD
@@1: LODSB // moves [ESI] into al
CMP AL,Dot
JE @@4
SUB AL,'0'
CMP DL,0
JNE @@2
SHL AL,4
MOV AH,AL
JMP @@3
@@2: OR AL,AH // takes AH and ors in AL
STOSB // always moves AL into [EDI]
@@3: NOT dl // flip all bits
@@4: LOOP @@1 // decrements cx and checks if it's 0
CMP DL,0 // are any bytes left unstored?
JE @@5
MOV AL,AH // if so, move to al
STOSB // and store to [EDI]
@@5: POP EBX
POP EDI
POP ESI
end;
end;
function TryStrToBcd(const AValue: string; var Bcd: TBcd): Boolean;
const
spaceChars: set of Char = [ ' ', #6, #10, #13, #14];
digits: set of Char = ['0'..'9'];
var
Neg: Boolean;
NumDigits, DecimalPos: Word;
pTmp, pSource: PChar;
Dot : Char;
begin
Dot := DecimalSeparator;
if InvalidBcdString(PChar(AValue)) then
begin
Result := False;
exit;
end;
if (AValue = '0') or (AValue = '') then
begin
Result := True;
Bcd.Precision := 8;
Bcd.SignSpecialPlaces := 2;
pSource := PChar(@Bcd.Fraction);
System.FillChar(PSource^, SizeOf(Bcd.Fraction), 0);
Exit
end;
Result := True;
Neg := False;
DecimalPos := Pos(Dot, AValue);
pSource := pCHAR(AValue);
{ Strip leading whitespace }
while (pSource^ in spaceChars) or (pSource^ = '0') do
begin
Inc(pSource);
if DecimalPos > 0 then Dec(DecimalPos);
end;
{ Strip trailing whitespace }
pTmp := @pSource[ StrLen( pSource ) -1 ];
while pTmp^ in spaceChars do
begin
pTmp^ := #0;
Dec(pTmp);
end;
{ Is the number negative? }
if pSource^ = '-' then
begin
Neg := TRUE;
if DecimalPos > 0 then Dec(DecimalPos);
end;
if (pSource^ = '-') or (pSource^ ='+') then
Inc(pSource);
{ Clear structure }
pTmp := pCHAR(@Bcd.Fraction);
System.FillChar(pTmp^, SizeOf(Bcd.Fraction), 0);
if (pSource[0] = '0') then
begin
Inc(PSource); // '0.' scenario
if DecimalPos > 0 then Dec(DecimalPos);
end;
NumDigits := StrLen(pSource);
if (NumDigits > MaxFMTBcdFractionSize) then
begin
if (DecimalPos > 0) and (DecimalPos <= MaxFMTBcdFractionSize) then
NumDigits := MaxFMTBcdFractionSize // truncate to 64
else begin
Bcd.Precision := NumDigits;
Exit;
end;
end;
if NumDigits > 0 then
StrToFraction(pTmp, pSource, SmallInt(NumDigits))
else begin
Bcd.Precision := 10;
Bcd.SignSpecialPlaces := 2;
end;
if DecimalPos > 0 then
begin
Bcd.Precision := Byte(NumDigits-1);
if Neg then
Bcd.SignSpecialPlaces := ( 1 shl 7 ) + (BYTE(NumDigits - DecimalPos))
else
Bcd.SignSpecialPlaces := ( 0 shl 7 ) + (BYTE(NumDigits - DecimalPos));
end else
begin
Bcd.Precision := Byte(NumDigits);
if Neg then
Bcd.SignSpecialPlaces := (1 shl 7)
else
Bcd.SignSpecialPlaces := (0 shl 7);
end;
end;
function StrToBcd(const AValue: string): TBcd;
var
Success: Boolean;
begin
Success := TryStrToBcd(AValue, Result);
if not Success then
BcdErrorFmt(SInvalidBcdValue, AValue);
end;
{$ENDIF}
function DBNumericToDouble(Value: TDBNumeric): double;
var
Bcd: TBcd;
begin
Bcd := DBNumericToBcd(Value);
Result := BcdToDouble(Bcd);
end;
function DoubleToDBNumeric(Value: double; Precision, Scale: integer): TDBNumeric;
var
Bcd: TBcd;
Str: string;
begin
//Str := FloatToStrF(Value, ffFixed, Precision, Scale);
if (Precision = 0) and (Scale = 0) then
Str := Format('%f', [Value])
else
Str := Format('%.' + IntToStr(Scale) + 'f', [Value]);
Bcd := StrToBcd(Str);
Result := BcdToDBNumeric(Bcd);
end;
function IsLargeDataTypeUsed(const FieldDesc: TFieldDesc): boolean;
begin
Result := FieldDesc.DataType = dtBlob;
if not Result then
Result := ((FieldDesc.DataType = dtMemo) or (FieldDesc.DataType = dtWideMemo)) and (((not dtWide) and FieldDesc.SubDataType) = dtText);
if not Result then
Result := FieldDesc.DataType = dtMSXML;
end;
function IsLargeDataTypeUsed(const ParamDesc: TParamDesc): boolean;
begin
Result :=
(ParamDesc.GetDataType = dtBlob) or
(ParamDesc.GetDataType = dtMemo) or
(ParamDesc.GetDataType = dtWideMemo) or
(ParamDesc.GetDataType = dtMSXML);
end;
function IsOutputLOB(ParamDesc: TParamDesc; ServerVersion, ClientVersion: integer): boolean;
begin
Result := ((ParamDesc.GetDataType = dtMemo) or (ParamDesc.GetDataType = dtWideMemo)) and
(ParamDesc.GetParamType in [pdOutput, pdInputOutput]) and
(ServerVersion = 9) and
(ClientVersion = 9);
end;
function GetProviderName(const Provider: TOLEDBProvider): string;
begin
case Provider of
prAuto, prSQL:
Result := 'SQLOLEDB.1';
prNativeClient:
Result := 'SQLNCLI.1';
prCompact:
Result := 'MICROSOFT.SQLSERVER.MOBILE.OLEDB.3.0';
else
Assert(False);
Result := '';
end;
end;
function GetProvider(const ProviderName: string): TOLEDBProvider;
var
Name: string;
begin
Name := Uppercase(ProviderName);
if Name = SSQLOLEDB then
Result := prSQL
else
if Name = SSQLNativeClient then
Result := prNativeClient
else
if Name = SSQLEverywhere then
Result := prCompact
else
Result := prAuto;
end;
// FetchBlock support
function IsNeedFetchBlock(const FieldDesc: TFieldDesc; ServerVersion: integer): boolean; // Return True if field need to fetch into separate buffer
var
DataType: word;
begin
Assert(FieldDesc.FieldDescKind = fdkData, 'IsNeedFetchBlock ' + FieldDesc.Name);
DataType := FieldDesc.DataType;
case DataType of
dtExtString, dtExtWideString, dtExtVarBytes, dtVariant:
Result := True;
dtMemo, dtWideMemo, dtMSXML:
Result := not IsLargeDataTypeUsed(FieldDesc);
dtFloat, dtBcd:
Result := (ServerVersion = 3) and (TOLEDBFieldDesc(FieldDesc).OLEDBType = DBTYPE_NUMERIC);
else
Result := False;
end;
end;
procedure IncFetchBlockOffset(var FetchBlockOffset: integer; const DataType: TDataType);
begin
case DataType of
dtExtString, dtExtWideString:
Inc(FetchBlockOffset, OLE_DB_INDICATOR_SIZE + MaxNonBlobFieldLen + 2 {#0#0 terminator} + sizeof(UINT) {Length});
dtMemo, dtWideMemo, dtMSXML:
Inc(FetchBlockOffset, OLE_DB_INDICATOR_SIZE + MaxNonBlobFieldLen + 2 {#0#0 terminator});
dtExtVarBytes:
Inc(FetchBlockOffset, OLE_DB_INDICATOR_SIZE + MaxNonBlobFieldLen + sizeof(UINT) {Length});
dtVariant:
Inc(FetchBlockOffset, OLE_DB_INDICATOR_SIZE + sizeof(OleVariant));
dtFloat, dtBcd:
Inc(FetchBlockOffset, OLE_DB_INDICATOR_SIZE + SizeOfTDBNumeric);
else
Assert(False);
end;
end;
// Brackets support
function IsBracketPresent(const Value: string): boolean;
var
l: integer;
begin
Assert(Pos('.', Value) = 0, 'In func IsBracketPresent delimited values not allowed');
l := Length(Value);
if (l <= 1) then
Result := False
else
Result := ((Value[1] = '"') and (Value[l] = '"')) or
((Value[1] = '[') and (Value[l] = ']'));
end;
function Unbracket(const Value: string): string;
begin
if IsBracketPresent(Value) then
Result := Copy(Value, 2, length(Value) - 2)
else
Result := Value;
end;
function IsBracketNeed(Value: string): boolean;
var
i: integer;
begin
Assert(Pos('.', Value) = 0, 'In func IsBracketNeeds delimited values not allowed');
Value := Unbracket(Value);
Result := False;
for i := 1 to Length(Value) do
if i = 1 then
case Value[i] of
'a'..'z', 'A'..'Z', '_', '@', '#':; // NoBracketableStartingChars = ['a'..'z', 'A'..'Z', '_', '@', '#'];
else
begin
Result := True;
Exit;
end;
end
else
case Value[i] of
'a'..'z', 'A'..'Z', '_', '@', '#', '0'..'9', '$':; // NoBracketableChars = NoBracketableStartingChars + ['0'..'9', '$'];
else
begin
Result := True;
Exit;
end;
end;
end;
// Rules see in MSDN (mk:@MSITStore:D:\Program%20Files\Microsoft%20Visual%20Studio\MSDN\2003JAN\1033\acdata.chm::/ac_8_con_03_89rn.htm,
// mk:@MSITStore:D:\Program%20Files\Microsoft%20Visual%20Studio\MSDN\2003JAN\1033\acdata.chm::/ac_8_con_03_6e9e.htm)
function BracketIfNeed(const Value: string): string;
begin
Result := BracketIfNeed(Value, Char('['), Char(']'));
end;
function BracketIfNeed(const Value: string; const LeftQ: char; const RightQ: char): string;
var
i: integer;
begin
i := Pos('.', Value);
if i <> 0 then
Result := BracketIfNeed(Copy(Value, 1, i - 1)) + '.' + BracketIfNeed(Copy(Value, i + 1, Length(Value) - i))
else
if not IsBracketPresent(Value) and
IsBracketNeed(Value) then
Result := LeftQ + Value + RightQ
else
Result := Value;
end;
function UnbracketIfPossible(const Value: string; const NeedSl: boolean; var sl: String {Result parts in reverse order delimited by slDelimiter}): string; overload;
var
{$IFNDEF CLR}
p: PChar;
{$ENDIF}
DotPos: integer;
l: integer;
begin
Result := Value;
l := Length(Value);
{$IFDEF CLR}
DotPos := Value.IndexOf('.');
{$ELSE}
p := StrScan(PChar(Value), '.'); // i := Pos('.', Value);
if p = nil then
DotPos := -1
else
DotPos := p - PChar(Value);
{$ENDIF}
if (l < 3) then begin
if (DotPos = -1) and NeedSl then
sl := Result + slDelimiter + sl;
Exit;
end;
if DotPos <> -1 then begin
{ if DotPos = 0 then
Result := UnbracketIfPossible(Copy(Value, DotPos + 2, l - DotPos - 1), sl)
else}
Result := UnbracketIfPossible(Copy(Value, 1, DotPos), sl) + '.' + UnbracketIfPossible(Copy(Value, DotPos + 2, l - DotPos - 1), sl)
end
else
begin
if IsBracketPresent(Value) and
not IsBracketNeed(Value) then
Result := Copy(Value, 2, l - 2)
else
Result := Value;
if NeedSl then
sl := Result + slDelimiter + sl;
end;
end;
function UnbracketIfPossible(const Value: string): string; overload;
var
sl: string;
begin
Result := UnbracketIfPossible(Value, False, sl);
end;
function UnbracketIfPossible(const Value: string; var sl: string {Result parts in reverse order delimited by slDelimiter}): string; overload;
begin
Result := UnbracketIfPossible(Value, True, sl);
end;
{$IFDEF CLR}
function UnbracketIfPossible(const Value: string; out DataBase: string; out Owner: string; out ObjName: string): string;
const
d: array[0..0] of char = (slDelimiter);
var
sl: string;
i: integer;
SubSl: array of string;
begin
sl := '';
UnbracketIfPossible(Value, sl);
if sl = '' then
Exit;
SubSl := sl.Split(d);
i := Length(SubSl);
if i > 0 then begin
ObjName := SubSl[0];
if i > 1 then begin
Owner := SubSl[1];
if i > 2 then
Database := SubSl[2];
end;
end;
end;
{$ELSE}
function UnbracketIfPossible(const Value: string; out DataBase: string; out Owner: string; out ObjName: string): string;
function GetSubStr(var Src: PChar): string;
var
p: PChar;
l: integer;
begin
p := StrScan(Src, slDelimiter);
if p = nil then
Result := ''
else
begin
l := p - Src;
SetLength(Result, l);
Move(Src^, PChar(Result)^, l);
Src := Src + l + 1{slDelimiter};
end;
end;
var
sl: string;
p: PChar;
begin
sl := '';
UnbracketIfPossible(Value, sl);
if sl = '' then
Exit;
p := PChar(sl);
ObjName := GetSubStr(p);
Owner := GetSubStr(p);
Database := GetSubStr(p);
end;
{$ENDIF}
function GenerateTableName(const CatalogName: string;
const SchemaName: string;
const TableName: string;
const DefaultCatalogName: string): string;
begin
if (CatalogName <> '') and not SameText(CatalogName, DefaultCatalogName) then
Result := Format('%s.%s.%s',
[BracketIfNeed(CatalogName),
BracketIfNeed(SchemaName),
BracketIfNeed(TableName)])
else
if SchemaName <> '' then
Result := Format('%s.%s',
[BracketIfNeed(SchemaName),
BracketIfNeed(TableName)])
else
Result := Format('%s',
[BracketIfNeed(TableName)]);
end;
function ChangeDecimalSeparator(const Value: Variant): string;
var
i: integer;
begin
{$IFDEF VER6P}
Result := Value;
{$ELSE}
if TVarData(Value).VType = varSingle then
Result := FloatToStr(TVarData(Value).VSingle)
else
if TVarData(Value).VType = varDouble then
Result := FloatToStr(TVarData(Value).VDouble)
else
Result := Value;
{$ENDIF}
if DecimalSeparator <> '.' then begin
i := 2;
while i < Length(Result) do begin
if Result[i] = DecimalSeparator then begin
Result[i] := '.';
Break;
end;
Inc(i);
end;
end;
end;
function GetParamNameWODog(const ParamName: string): string;
begin
if (ParamName <> '') and (ParamName[1] = '@') then
Result := Copy(ParamName, 2, 1000)
else
Result := ParamName;
end;
{$IFDEF CLR}
procedure QueryIntf(Source: IUnknown; const IID: TInterfaceRef; out Intf); // OLE QueryInterface analog
begin
Assert(Source <> nil);
Intf := nil;
if Source is IID then
Intf := Source as IID
else
raise EOLEDBError.Create(E_NOINTERFACE, 'QueryInterface failed');
end;
{$ELSE}
procedure QueryIntf(Source: IUnknown; const IID: TGuid; out Intf); // OLE QueryInterface analog
begin
Assert(Source <> nil);
if Source.QueryInterface(IID, Intf) <> S_OK then
raise EOLEDBError.Create(E_NOINTERFACE, 'QueryInterface failed');
end;
{$ENDIF}
function Min(const A, B: Integer): Integer;
begin
if A < B then
Result := A
else
Result := B;
end;
{ TOLEDBParamDesc }
function TOLEDBParamDesc.GetOLEDBType: DBTYPE;
begin
Result := FOLEDBType;
end;
procedure TOLEDBParamDesc.SetOLEDBType(Value: DBTYPE);
begin
FOLEDBType := Value;
end;
function TOLEDBParamDesc.GetUseDefaultValue: boolean;
begin
Result := FUseDefaultValue;
end;
procedure TOLEDBParamDesc.SetUseDefaultValue(Value: boolean);
begin
FUseDefaultValue := Value;
end;
function TOLEDBParamDesc.GetValue: variant;
begin
if not GetNull
and not VarIsEmpty(FData)
and not VarIsNull(FData)
{$IFDEF CLR}
and (FData is TSharedObject)
{$ELSE}
and (TVarData(FData).VType = varByRef)
{$ENDIF}
then begin
if GetAsBlobRef.IsUnicode then
Result := GetAsBlobRef.AsWideString
else
Result := GetAsBlobRef.AsString;
end
else
Result := inherited GetValue;
end;
function TOLEDBParamDesc.GetAsBlobRef: TBlob;
begin
Result := TBlob({$IFDEF CLR}FData{$ELSE}TVarData(FData).VPointer{$ENDIF});
end;
procedure TOLEDBParamDesc.SetNull(const Value: boolean);
begin
FIsNull := Value;
if not((DataType = dtBlob) or (DataType = dtMemo) or (DataType = dtWideMemo)) then
FData := Unassigned;
end;
{ TExecuteThread }
procedure TExecuteThread.InternalExecute;
begin
if Assigned(FRunMethod) then
FRunMethod;
end;
{ TOLEDBThreadWrapper }
procedure TOLEDBThreadWrapper.DoException(E: Exception);
begin
if E is EOLEDBError then begin
Assert(FException = nil);
FException := EOLEDBError.Create(EOLEDBError(E).ErrorCode, EOLEDBError(E).Message);
EOLEDBError(FException).Assign(EOLEDBError(E));
end
else
inherited;
end;
{ TOLEDBStream }
constructor TOLEDBStream.Create(Blob: TBlob {to avoid data copy}; StreamList: TList);
begin
inherited Create;
{$IFDEF DEBUG} Inc(StreamCnt); {$ENDIF}
FBlob := Blob;
FPosInBlob := 0;
FSize := Blob.Size;
FStreamList := StreamList;
if FStreamList <> nil then
FStreamList.Add(Self);
end;
destructor TOLEDBStream.Destroy;
begin
if FStreamList <> nil then
{$IFDEF CLR}
FStreamList.Remove(Self);
{$ELSE}
FStreamList.Remove(pointer(Self));
{$ENDIF}
inherited;
{$IFDEF DEBUG} Dec(StreamCnt); {$ENDIF}
end;
function TOLEDBStream.Read(
pv: IntPtr;
cb: Longint;
pcbRead: PLongint
): HResult;
var
cbSrcReadBytes: longint;
cbDstWriteBytes: longint;
begin
try
cbSrcReadBytes := Min(Integer(FSize - FPosInBlob), cb);
cbDstWriteBytes := FBlob.Read(FPosInBlob, cbSrcReadBytes, pv);
Inc(FPosInBlob, cbDstWriteBytes);
if pcbRead <> nil then
Marshal.WriteInt32(pcbRead, cbDstWriteBytes);
Result := S_OK;
except
Result := S_FALSE;
end;
end;
function TOLEDBStream.Write(
pv: IntPtr;
cb: Longint;
pcbWritten: PLongint
): HResult;
begin
try
FBlob.Write(FPosInBlob, cb, pv);
Inc(FPosInBlob, cb);
Inc(FSize, cb);
if pcbWritten <> nil then
Marshal.WriteInt32(pcbWritten, cb);
Result := S_OK;
except
Result := S_FALSE;
end;
end;
{ TBigIntegerAccessor }
constructor TBigIntegerAccessor.Create(BigIntegerPtr: PBigInteger; Allocate: boolean);
begin
inherited Create;
if not Allocate then
FBigIntegerPtr := BigIntegerPtr
else begin
FBigIntegerPtr := Marshal.AllocHGlobal(SizeOfRBigInteger);
FSelfAllocated := True;
end;
end;
destructor TBigIntegerAccessor.Destroy;
begin
if FSelfAllocated then
Marshal.FreeHGlobal(FBigIntegerPtr);
inherited;
end;
procedure TBigIntegerAccessor.SetBigIntegerPtr(Value: PBigInteger);
begin
if FSelfAllocated then begin
Marshal.FreeHGlobal(FBigIntegerPtr);
FSelfAllocated := False;
end;
FBigIntegerPtr := Value;
end;
function TBigIntegerAccessor.GetDataLength: integer;
begin
Result := Marshal.ReadInt32(FBigIntegerPtr, MaxLength * SizeOfLongWord)
end;
procedure TBigIntegerAccessor.SetDataLength(Value: integer);
begin
Marshal.WriteInt32(FBigIntegerPtr, MaxLength * SizeOfLongWord, Value);
end;
function TBigIntegerAccessor.GetDataPtr: IntPtr;
begin
Result := FBigIntegerPtr;
end;
function TBigIntegerAccessor.GetData(Index: integer): LongWord;
begin
Result := LongWord(Marshal.ReadInt32(FBigIntegerPtr, Index * SizeOfLongWord));
end;
procedure TBigIntegerAccessor.SetData(Index: integer; Value: LongWord);
begin
Marshal.WriteInt32(FBigIntegerPtr, Index * SizeOfLongWord, Integer(Value));
end;
procedure TBigIntegerAccessor.ClearData;
var
i: integer;
begin
for i := 0 to MaxLength - 1 do
Data[i] := 0;
end;
function TBigIntegerAccessor.GetBigInteger: RBigInteger;
{$IFDEF CLR}
var
i: integer;
{$ENDIF}
begin
{$IFDEF CLR}
Result.DataLength := GetDataLength;
for i := 0 to MaxLength - 1 do
Result.Data[i] := Data[i];
//Result := RBigInteger(Marshal.PtrToStructure(FBigIntegerPtr, TypeOf(RBigInteger)));
{$ELSE}
Result := RBigInteger(FBigIntegerPtr^);
{$ENDIF}
end;
procedure TBigIntegerAccessor.SetBigInteger(const Value: RBigInteger);
{$IFDEF CLR}
var
i: integer;
{$ENDIF}
begin
Assert(FBigIntegerPtr <> nil);
{$IFDEF CLR}
DataLength := Value.DataLength;
for i := 0 to MaxLength - 1 do
Data[i] := Value.Data[i];
//Marshal.StructureToPtr(TObject(Value), FBigIntegerPtr, False);
{$ELSE}
RBigInteger(FBigIntegerPtr^) := Value;
{$ENDIF}
end;
{ TBigInteger }
class procedure TBigInteger.CreatePBigIntegerPtr(PBigInt: PBigInteger);
var
BigIntAcc: TBigIntegerAccessor;
begin
BigIntAcc := TBigIntegerAccessor.Create(PBigInt, False);
try
BigIntAcc.DataLength := 1;
BigIntAcc.ClearData;
finally
BigIntAcc.Free;
end;
end;
class procedure TBigInteger.CreateRBigIntegerStruct(var BigInt: RBigInteger);
{$IFDEF CLR}
var
i: integer;
{$ENDIF}
begin
BigInt.DataLength := 1;
{$IFDEF CLR}
for i := 0 to MaxLength - 1 do
BigInt.Data[i] := 0;
{$ELSE}
MemUtils.FillChar(@BigInt.Data[0], MaxLength * SizeOfLongWord, $00);
{$ENDIF}
end;
class procedure TBigInteger.CreatePBigInteger64(PBigInt: PBigInteger; Value: Int64);
var
BigIntAcc: TBigIntegerAccessor;
begin
BigIntAcc := TBigIntegerAccessor.Create(PBigInt, False);
try
BigIntAcc.ClearData;
BigIntAcc.DataLength := 0;
while (Value <> 0) and (BigIntAcc.DataLength < MaxLength) do begin
BigIntAcc.Data[BigIntAcc.DataLength] := LongWord(Value and $FFFFFFFF);
Value := Value shr 32;
BigIntAcc.DataLength := BigIntAcc.DataLength + 1;
end;
if (Value <> 0) or (LongWord(BigIntAcc.Data[MaxLength - 1] and $80000000) <> 0) then
raise Exception.Create('Positive overflow in constructor.');
if BigIntAcc.DataLength = 0 then
BigIntAcc.DataLength := 1;
finally
BigIntAcc.Free;
end;
end;
class procedure TBigInteger.CreatePBigIntegerBCD(PBigInt: PBigInteger; const Value: TBcd);
var
Multiplier: TBigIntegerAccessor;
Result, Tmp: TBigIntegerAccessor;
BigIntAcc: TBigIntegerAccessor;
Radix: integer;
posVal: Integer;
Val: TBytes;
i: Integer;
k: integer;
begin
Multiplier := nil;
Result := nil;
Tmp := nil;
BigIntAcc := nil;
try
Multiplier := TBigIntegerAccessor.Create(nil, True);
Result := TBigIntegerAccessor.Create(nil, True);
Tmp := TBigIntegerAccessor.Create(nil, True);
BigIntAcc := TBigIntegerAccessor.Create(PBigInt, False);
TBigInteger.CreatePBigInteger64(Multiplier.BigIntegerPtr, 1);
TBigInteger.CreatePBigIntegerPtr(Result.BigIntegerPtr);
SetLength(Val, SizeOfFraction);
{$IFDEF CLR}
for i := 0 to SizeOfFraction - 1 do
Val[i] := Value.Fraction[i];
{$ELSE}
MemUtils.CopyBuffer(@Value.Fraction[0], @Val[0], Length(Val));
{$ENDIF}
k := (Value.Precision div 2);
if (Value.Precision mod 2) = 0 then
Dec(k);
for i := k downto 0 do begin
Radix := 100;
if (i = k) then begin
if (Value.Precision mod 2) = 0 then
posVal := (val[i] and $0F) + ((val[i] and $F0) shr 4) * 10
else begin
posVal := (val[i] and $F0) shr 4;
Radix := 10;
end;
end
else
posVal := (val[i] and $0F) + ((val[i] and $F0) shr 4) * 10;
Assert(posVal < Radix);
Tmp.BigInteger := Mul64(Multiplier.BigIntegerPtr, posVal);
Result.BigInteger := Add(Result.BigIntegerPtr, Tmp.BigIntegerPtr);
if (i - 1) >= 0 then
Multiplier.BigInteger := Mul64(Multiplier.BigIntegerPtr, Radix);
end;
BigIntAcc.ClearData;
for i := 0 to Result.DataLength - 1 do
BigIntAcc.Data[i] := Result.Data[i];
BigIntAcc.DataLength := Result.DataLength;
finally
Multiplier.Free;
Result.Free;
Tmp.Free;
BigIntAcc.Free;
end;
end;
class function TBigInteger.Add(PBigInt1: PBigInteger; PBigInt2: PBigInteger): RBigInteger;
var
carry, sum: Int64;
i, lastPos: Integer;
BigInt1Acc, BigInt2Acc: TBigIntegerAccessor;
begin
BigInt1Acc := TBigIntegerAccessor.Create(PBigInt1, False);
BigInt2Acc := TBigIntegerAccessor.Create(PBigInt2, False);
try
TBigInteger.CreateRBigIntegerStruct(Result);
if BigInt1Acc.DataLength > BigInt2Acc.DataLength then
Result.DataLength := BigInt1Acc.DataLength
else
Result.dataLength := BigInt2Acc.DataLength;
carry := 0;
for i := 0 to Result.DataLength - 1 do begin
sum := Int64(BigInt1Acc.data[i]) + Int64(BigInt2Acc.data[i]) + carry;
carry := sum shr 32;
Result.Data[i] := LongWord(sum and $FFFFFFFF);
end;
if (carry <> 0) and (Result.DataLength < MaxLength) then begin
Result.Data[Result.DataLength] := LongWord(carry);
Result.DataLength := Result.DataLength + 1;
end;
while (Result.DataLength > 1) and (Result.Data[Result.DataLength - 1] = 0) do
Result.DataLength := Result.DataLength - 1;
// overflow check
lastPos := maxLength - 1;
if (longword(BigInt1Acc.Data[lastPos] and $80000000) = longword(BigInt2Acc.Data[lastPos] and $80000000)) and
(longword(Result.Data[lastPos] and $80000000) <> longword(BigInt1Acc.Data[lastPos] and $80000000)) then
begin
raise Exception.Create('overflow!');
end;
finally
BigInt1Acc.Free;
BigInt2Acc.Free;
end;
end;
class function TBigInteger.NEGATEPtr(PBigInt: PBigInteger): RBigInteger;
var
carry, val: Int64;
i, index: Integer;
BigIntAcc: TBigIntegerAccessor;
begin
BigIntAcc := TBigIntegerAccessor.Create(PBigInt, False);
try
// handle neg of zero separately since it'll cause an overflow
// if we proceed.
if (BigIntAcc.DataLength = 1) and (BigIntAcc.Data[0] = 0) then begin
TBigInteger.CreateRBigIntegerStruct(Result);
Exit;
end;
// 1's complement
for i := 0 to MaxLength - 1 do
Result.Data[i] := LongWord(not(BigIntAcc.Data[i]));
// add one to result of 1's complement
carry := 1;
index := 0;
while (carry <> 0) and (index < maxLength) do begin
val := Int64(Result.Data[index]);
Inc(val);
Result.Data[index] := LongWord(val and $FFFFFFFF);
carry := val shr 32;
Inc(index);
end;
if LongWord(BigIntAcc.Data[maxLength-1] and $80000000) = LongWord(Result.Data[MaxLength-1] and $80000000) then
raise Exception.Create('Overflow in negation.');
Result.DataLength := MaxLength;
while (Result.DataLength > 1) and (Result.Data[Result.DataLength - 1] = 0) do
Result.DataLength := Result.DataLength - 1;
finally
BigIntAcc.Free;
end;
end;
class function TBigInteger.NEGATE(const BigInt: RBigInteger): RBigInteger;
{$IFDEF CLR}
var
BigIntAcc: TBigIntegerAccessor;
{$ENDIF}
begin
{$IFDEF CLR}
BigIntAcc := TBigIntegerAccessor.Create(nil, True);
try
BigIntAcc.BigInteger := BigInt;
Result := NEGATEPtr(BigIntAcc.BigIntegerPtr);
finally
BigIntAcc.Free;
end;
{$ELSE}
Result := NEGATEPtr(@BigInt);
{$ENDIF}
end;
class function TBigInteger.Mul(PBigInt1: PBigInteger; PBigInt2: PBigInteger): RBigInteger;
var
BigInt1Acc, BigInt2Acc: TBigIntegerAccessor;
nbi1, nbi2: RBigInteger;
mcarry, val: Int64;
bi1Neg, bi2Neg, isMaxNeg: Boolean;
b1, b2: Longword;
i, j, k, lastPos: Integer;
begin
BigInt1Acc := TBigIntegerAccessor.Create(PBigInt1, False);
BigInt2Acc := TBigIntegerAccessor.Create(PBigInt2, False);
try
lastPos := maxLength - 1;
bi1Neg := false;
bi2Neg := false;
// take the absolute value of the inputs
try
if longword(BigInt1Acc.Data[lastPos] and $80000000) <> 0 then begin
bi1Neg := true;
nbi1 := NEGATEPtr(PBigInt1);
end
else
//nbi1 := bi1^;
nbi1 := BigInt1Acc.BigInteger;
if longword(BigInt2Acc.Data[lastPos] and $80000000) <> 0 then begin
bi2Neg := true;
nbi2 := NEGATEPtr(PBigInt2);
end
else
//nbi2 := bi2^;
nbi2 := BigInt2Acc.BigInteger;
except
end;
TBigInteger.CreateRBigIntegerStruct(Result);
// multiply the absolute values
for i := 0 to nbi1.dataLength - 1 do begin
if nbi1.data[i] = 0 then
continue;
mcarry := 0;
k := i;
for j := 0 to nbi2.dataLength - 1 do begin
// k = i + j
// val := Int64(nbi1.data[i]) * Int64(nbi2.data[j]);
b1 := nbi1.data[i];
b2 := nbi2.data[j];
{$IFDEF CLR}
val := Int64(b1) * Int64(b2);
{$ELSE}
asm
MOV EAX, b1
MUL b2
MOV dword ptr [val+$00], EAX
MOV dword ptr [val+$04], EDX
end;
{$ENDIF}
val := val + Int64(result.data[k]) + mcarry;
result.data[k] := longword(val and $FFFFFFFF);
mcarry := val shr 32;
Inc(k);
end;
if mcarry <> 0 then
result.data[i + nbi2.dataLength] := longword(mcarry);
end;
result.dataLength := nbi1.dataLength + nbi2.dataLength;
if result.dataLength > maxLength then
result.dataLength := maxLength;
while (result.dataLength > 1) and (result.data[result.dataLength - 1] = 0) do
result.dataLength := result.dataLength - 1;
// overflow check (result is -ve)
if longword(result.data[lastPos] and $80000000) <> 0 then begin
if (bi1Neg <> bi2Neg) and (result.data[lastPos] = $80000000) then begin
// handle the special case where multiplication produces
// a max negative number in 2's complement.
if result.dataLength = 1 then
Exit
else begin
isMaxNeg := true;
i := 0;
while (i < result.dataLength - 1) and isMaxNeg do begin
if result.data[i] <> 0 then
isMaxNeg := false;
Inc(i);
end;
if isMaxNeg then
Exit;
end;
end;
raise Exception.Create('Multiplication overflow.');
end;
// if input has different signs, then result is -ve
if bi1Neg <> bi2Neg then
Result := NEGATE(Result);
finally
BigInt1Acc.Free;
BigInt2Acc.Free;
end;
end;
class function TBigInteger.Mul64(PBigInt1: PBigInteger; value: Int64): RBigInteger;
var
BigIntAcc2: TBigIntegerAccessor;
begin
BigIntAcc2 := TBigIntegerAccessor.Create(nil, True);
try
TBigInteger.CreatePBigInteger64(BigIntAcc2.BigIntegerPtr, Value);
Result := Mul(PBigInt1, BigIntAcc2.BigIntegerPtr);
finally
BigIntAcc2.Free;
end;
end;
{ TOLEDBConnection }
constructor TOLEDBConnection.Create;
begin
inherited;
FIsolationLevel := ilReadCommitted;
FCommand := nil;
FAuthentication := auServer;
FProvider := prSQL;
FDatabase := '';
FQuotedIdentifier := True;
FPacketSize := DefaultPacketSize;
FAutoTranslate := True;
FConnectionTimeout := DefaultConnectionTimeout;
FOldPassword := '';
FMaxDatabaseSize := 4091;
FFailoverPartner := '';
end;
destructor TOLEDBConnection.Destroy;
begin
Disconnect;
FCommand.Free;
inherited;
end;
procedure TOLEDBConnection.ReleaseInterfaces;
begin
FISessionProperties := nil;
FITransactionLocal := nil;
FIDBInitialize := nil;
FIDBProperties := nil;
FIDBCreateSession := nil;
end;
{$IFDEF SQL_TRANSACTION}
procedure TOLEDBConnection.StartTransaction;
begin
{$WARNINGS OFF}
case FIsolationLevel of
ilReadCommitted:
ExecSQL('SET TRANSACTION ISOLATION LEVEL READ COMMITTED');
ilReadUnCommitted:
ExecSQL('SET TRANSACTION ISOLATION LEVEL READ UNCOMMITTED');
ilRepeatableRead:
ExecSQL('SET TRANSACTION ISOLATION LEVEL REPEATABLE READ');
ilIsolated:
ExecSQL('SET TRANSACTION ISOLATION LEVEL SERIALIZABLE ');
else
Assert(False, Format('Invalid value %d', [Integer(FIsolationLevel)]));
end;
{$WARNINGS ON}
ExecSQL('BEGIN TRAN');
end;
procedure TOLEDBConnection.Commit;
begin
ExecSQL('COMMIT');
end;
procedure TOLEDBConnection.Rollback;
begin
ExecSQL('ROLLBACK');
end;
{$ELSE}
{$IFDEF CLR}
procedure TOLEDBConnection.StartTransaction;
var
pulTransactionLevel: PUINT;
begin
if FITransactionLocal <> nil then begin
pulTransactionLevel := Marshal.AllocHGlobal(4);
try
Check(FITransactionLocal.StartTransaction(ConvertIsolationLevelToOLEDBIsoLevel(FIsolationLevel), 0, nil, pulTransactionLevel), Component);
finally
Marshal.FreeHGlobal(pulTransactionLevel);
end;
end;
end;
{$ELSE}
procedure TOLEDBConnection.StartTransaction;
var
ulTransactionLevel: UINT;
begin
if FITransactionLocal <> nil then
Check(FITransactionLocal.StartTransaction(ConvertIsolationLevelToOLEDBIsoLevel(FIsolationLevel), 0, nil, @ulTransactionLevel), Component);
end;
{$ENDIF}
procedure TOLEDBConnection.Commit;
begin
if FITransactionLocal <> nil then
Check(ITransaction(FITransactionLocal).Commit(False{WAR may be troubles with server cursors}, XACTTC_SYNC, 0), Component);
end;
procedure TOLEDBConnection.Rollback;
begin
if FITransactionLocal <> nil then
Check(ITransaction(FITransactionLocal).Abort(nil, False, False), Component);
end;
{$ENDIF}
procedure TOLEDBConnection.Check(const Status: HRESULT; Component: TObject);
begin
if Status <> S_OK then
OLEDBError(Status, Component);
end;
procedure TOLEDBConnection.OLEDBError(const ErrorCode: HRESULT; Component: TObject);
{$IFDEF CLR}
function MarshalErrInfo(Err: PSSERRORINFO): SSERRORINFO;
begin
Result := SSERRORINFO(Marshal.PtrToStructure(Err, TypeOf(SSERRORINFO)));
end;
{$ELSE}
function MarshalErrInfo(Err: PSSERRORINFO): SSERRORINFO;
begin
Result.pwszMessage := Err.pwszMessage;
Result.pwszServer := Err.pwszServer;
Result.pwszProcedure := Err.pwszProcedure;
Result.lNative := Err.lNative;
Result.bState := Err.bState;
Result.bClass := Err.bClass;
Result.wLineNumber := Err.wLineNumber;
end;
{$ENDIF}
var
pIErrorInfoAll: IErrorInfo;
// pIErrorInfo: IErrorInfo;
pIErrorRecords: IErrorRecords;
pISQLServerErrorInfo: ISQLServerErrorInfo;
pssErrInfo: PSSERRORINFO;
ssErrInfo: SSERRORINFO;
pStrBuf: IntPtr; // pWideChar;
Msg: WideString;
s1: WideString;
i, RecordCount: Cardinal;
//pIMalloc: IMalloc;
Err: EOLEDBError;
Fail: boolean;
// Descr, Src: WideString;
ErrInfo: ERRORINFO;
iu: IUnknown;
// Buffer
ssErrInfoBuf: SSERRORINFO;
begin
if (ErrorCode = 0) and not Assigned(FOnInfoMessage) then
Exit;
s1 := '';
Err := nil;
RecordCount := 0;
//CoGetMalloc(1, pIMalloc);
if GetErrorInfo(0, pIErrorInfoAll) = S_OK then begin
pIErrorInfoAll.GetDescription(Msg);
{$IFDEF CLR}
pIErrorRecords := pIErrorInfoAll as IErrorRecords;
{$ELSE}
pIErrorInfoAll.QueryInterface(IID_IErrorRecords, pIErrorRecords);
{$ENDIF}
pIErrorRecords.GetRecordCount(RecordCount);
if RecordCount > 0 then begin /// i and RecordCount is unigned int!
for i := RecordCount - 1 downto 0 do begin// Ignore all error messages without last
if (pIErrorRecords.GetCustomErrorObject(i, IID_ISQLServerErrorInfo, iu) = S_OK) then
pISQLServerErrorInfo := ISQLServerErrorInfo(iu);
iu := nil;
if (pISQLServerErrorInfo <> nil) and
(pISQLServerErrorInfo.GetErrorInfo(pssErrInfo, pStrBuf) = S_OK) and
(pssErrInfo <> nil) then begin
{$IFDEF CLR}
ssErrInfo := SSERRORINFO(Marshal.PtrToStructure(pssErrInfo, TypeOf(SSERRORINFO)));
if s1 = '' then begin
ssErrInfoBuf := ssErrInfo;
s1 := ssErrInfo.pwszMessage;
end
else
s1 := ssErrInfo.pwszMessage + #$D#$A + s1;
{$ELSE}
if s1 = '' then begin
ssErrInfoBuf := MarshalErrInfo(pssErrInfo);
s1 := pssErrInfo^.pwszMessage;
end
else
s1 := pssErrInfo^.pwszMessage + WideString(#$D#$A) + s1;
{$ENDIF}
FreeCoMem(pStrBuf);
FreeCoMem(pssErrInfo);
//pIMalloc.Free(pStrBuf);
//pIMalloc.Free(pssErrInfo);
end;
end;
if s1 <> '' then
Err := EMSError.Create(ssErrInfoBuf, ErrorCode, s1);
end;
end;
if Err = nil then // this is OLE DB error. As example - repeated Connection.Rollback or non-convergence types of field and parameter
begin
if ErrorCode = 0 then
Exit; // No error and no message
if Msg = '' then
Msg := Format(SOLEDBError, [ErrorCode]);
if ErrorCode = CO_E_NOTINITIALIZED then
Msg := Msg + '.'#$D#$A'CoInitialize has not been called.';
Err := EOLEDBError.Create(ErrorCode, Msg);
end;
{$IFNDEF LITE}
Err.Component := Component;
{$ENDIF}
Err.FOLEDBErrorCode := ErrorCode;
if RecordCount > 0 then /// i and RecordCount is unigned int!
for i := 0 to RecordCount - 1 do begin// Ignore all error messages without last
if pIErrorRecords.GetCustomErrorObject(i, IID_ISQLServerErrorInfo, iu) = S_OK then begin
pISQLServerErrorInfo := ISQLServerErrorInfo(iu);
if (pISQLServerErrorInfo <> nil) and
(pISQLServerErrorInfo.GetErrorInfo(pssErrInfo, pStrBuf) = S_OK) and
(pssErrInfo <> nil) then begin
// EMSError
ssErrInfo := MarshalErrInfo(pssErrInfo);
Err.FErrors.FList.Add(EMSError.Create(ssErrInfo, 0, ssErrInfo.pwszMessage));
FreeCoMem(pStrBuf);
FreeCoMem(pssErrInfo);
//pIMalloc.Free(pStrBuf);
//pIMalloc.Free(pssErrInfo);
end
else
Err.FErrors.FList.Add(EOLEDBError.Create(ErrorCode, Msg));
end;
with Err.Errors[Err.ErrorCount - 1] do begin
if pIErrorRecords.GetBasicErrorInfo(i, ErrInfo) = S_OK then begin
// GetBasicErrorInfo - ERRORINFO struct
FOLEDBErrorCode := ErrInfo.hrError;
// FMinor := ErrInfo.dwMinor;
// Fclsid := ErrInfo.clsid;
Fiid := ErrInfo.iid;
// Fdispid := ErrInfo.dispid;
end;
(* if pIErrorRecords.GetErrorInfo(i, GetUserDefaultLCID(), pIErrorInfo) = S_OK then begin
// GetErrorInfo - IErrorInfo interface
// pIErrorInfo.GetGUID(Fguid); - same as Fiid
pIErrorInfo.GetSource(FSource);
pIErrorInfo.GetDescription(FDescription);
// pIErrorInfo.GetHelpFile(FHelpFile); - not used by sqloledb
// pIErrorInfo.GetHelpContext(FdwHelpContext); - not used by sqloledb
end;*)
end;
end;
if (ErrorCode = 0) and Assigned(FOnInfoMessage) then begin
Assert(Err <> nil);
try
FOnInfoMessage(Err as EMSError);
finally
Err.Free;
end;
end
else
begin
Fail := True;
try
if Assigned(OnError) then
DoError(Err{$IFNDEF LITE} as EDAError{$ENDIF}, Fail);
if Fail then
raise Err
else
Abort;
finally
if not Fail then
Err.Free;
end;
end;
end;
procedure TOLEDBConnection.GetConnectionProperties;
var
PropValues: TPropValues;
begin
with TOLEDBPropertiesGet.Create(Self, DBPROPSET_DATASOURCEINFO) do
try
AddPropId(DBPROP_DBMSNAME);
AddPropId(DBPROP_DBMSVER);
AddPropId(DBPROP_PROVIDERFRIENDLYNAME);
AddPropId(DBPROP_PROVIDERVER);
if FProvider = prCompact then
AddPropId(DBPROP_PROVIDERNAME);
GetProperties(FIDBProperties, PropValues);
finally
Free;
end;
FDBMSName := PropValues[0];
FDBMSVer := PropValues[1];
FDBMSPrimaryVer := StrToInt(Copy(FDBMSVer, 1, Pos('.', FDBMSVer) - 1));
FProviderFriendlyName := PropValues[2];
FProviderVer := PropValues[3];
FProviderPrimaryVer := StrToInt(Copy(FProviderVer, 1, Pos('.', FProviderVer) - 1));
if (FProvider = prCompact) and (FProviderFriendlyName = '') then begin
FProviderFriendlyName := PropValues[4];
if Pos('.dll', LowerCase(FProviderFriendlyName)) > 0 then
SetLength(FProviderFriendlyName, Length(FProviderFriendlyName) - 4);
end;
if FProvider = prCompact then begin
if (FProviderPrimaryVer <> 3) then
DatabaseError(SBadProviderName)
end
else
if (FProviderPrimaryVer < 7) and not IsWindowsVista then
DatabaseError(SWrongMDACVer);
end;
procedure TOLEDBConnection.SetConnectionProperties;
var
BufLen: cardinal;
// ComputerName: array[0..MAX_COMPUTERNAME_LENGTH] of char;
{$IFDEF CLR}
AppName: StringBuilder;
{$ELSE}
AppName: array[0..MAX_PATH + 100] of char;
{$ENDIF}
s: string;
begin
// Set initialization properties
if FProvider <> prCompact then begin
with TOLEDBPropertiesSet.Create(Self, DBPROPSET_DBINIT) do
try
// Auth props
if FServer <> '' then
AddPropStr(DBPROP_INIT_DATASOURCE, FServer)
else
AddPropStr(DBPROP_INIT_DATASOURCE, '(local)');
AddPropStr(DBPROP_INIT_CATALOG, FDatabase);
AddPropInt(DBPROP_INIT_TIMEOUT, FConnectionTimeout);
case FAuthentication of
auWindows:
AddPropStr(DBPROP_AUTH_INTEGRATED, '');
auServer:
if (FUserName = '') and (FPassword = '') then
AddPropStr(DBPROP_AUTH_USERID, 'sa')
else
begin
AddPropStr(DBPROP_AUTH_USERID, FUserName);
AddPropStr(DBPROP_AUTH_PASSWORD, FPassword);
end;
end;
if FPersistSecurityInfo then
AddPropBool(DBPROP_AUTH_PERSIST_SENSITIVE_AUTHINFO, FPersistSecurityInfo);
// Prompt props
AddPropSmallInt(DBPROP_INIT_PROMPT, DBPROMPT_NOPROMPT);
AddPropInt(DBPROP_INIT_HWND, 0);
SetProperties(FIDBProperties);
finally
Free;
end;
// Set common SQL Server properties
with TOLEDBPropertiesSet.Create(Self, DBPROPSET_SQLSERVERDBINIT) do
try
if FWorkstationID <> '' then
AddPropStr(SSPROP_INIT_WSID, FWorkstationID);
if FApplicationName <> '' then
AddPropStr(SSPROP_INIT_APPNAME, FApplicationName)
else
begin
{$IFDEF CLR}
AppName := StringBuilder.Create(MAX_PATH + 100);
try
BufLen := MAX_PATH + 100;
GetModuleFileName(0, AppName, BufLen);
s := ExtractFileName(AppName.ToString);
finally
AppName.Free;
end;
{$ELSE}
BufLen := sizeof(AppName);
GetModuleFileName(0, AppName, BufLen);
s := ExtractFileName(AppName);
{$ENDIF}
AddPropStr(SSPROP_INIT_APPNAME, s);
end;
if FLanguage <> '' then
AddPropStr(SSPROP_INIT_CURRENTLANGUAGE, FLanguage, True);
AddPropBool(SSPROP_INIT_AUTOTRANSLATE, FAutoTranslate, True);
if GUIDToString(FProviderId) = GUIDToString(CLSID_SQLNCLI) then begin
if FMultipleActiveResultSets then
AddPropBool(SSPROP_INIT_MARSCONNECTION, FMultipleActiveResultSets);
if FOldPassword <> '' then
AddPropStr(SSPROP_AUTH_OLD_PASSWORD, FOldPassword);
end
else
if FOldPassword <> '' then
raise Exception.Create(SSQLNCLINeedsChangePwd);
if FInitialFileName <> '' then
AddPropStr(SSPROP_INIT_FILENAME, FInitialFileName);
if FFailoverPartner <> '' then
AddPropStr(SSPROP_INIT_FAILOVERPARTNER, FFailoverPartner);
SetProperties(FIDBProperties);
finally
Free;
end;
/// Isolated for easy error detection
if FEncrypt then /// Set only if FEncrypt = True. This needs for prevent troubles with 7.xxx clients
with TOLEDBPropertiesSet.Create(Self, DBPROPSET_SQLSERVERDBINIT) do
try
AddPropBool(SSPROP_INIT_ENCRYPT, FEncrypt);
try
SetProperties(FIDBProperties);
except
on E: Exception do
begin
AddInfoToErr(E, SBadEncrypt, []);
raise E;
end;
end;
finally
Free;
end;
/// Isolated for easy error detection
if FNetworkLibrary <> '' then
with TOLEDBPropertiesSet.Create(Self, DBPROPSET_SQLSERVERDBINIT) do
try
AddPropStr(SSPROP_INIT_NETWORKLIBRARY, FNetworkLibrary, True);
try
SetProperties(FIDBProperties);
except
on E: Exception do begin
AddInfoToErr(E, SBadNetworkLibrary, []);
raise E;
end;
end;
finally
Free;
end;
/// Isolated for easy error detection
with TOLEDBPropertiesSet.Create(Self, DBPROPSET_SQLSERVERDBINIT) do
try
AddPropInt(SSPROP_INIT_PACKETSIZE, FPacketSize);
try
SetProperties(FIDBProperties);
except
on E: Exception do begin
AddInfoToErr(E, SBadPacketSize, []);
raise E;
end;
end;
finally
Free;
end;
end
else begin
with TOLEDBPropertiesSet.Create(Self, DBPROPSET_DBINIT) do
try
AddPropStr(DBPROP_INIT_DATASOURCE, FDatabase, True);
try
SetProperties(FIDBProperties);
except
on E: Exception do begin
AddInfoToErr(E, SBadDatabaseFile, []);
raise E;
end;
end;
finally
Free;
end;
with TOLEDBPropertiesSet.Create(Self, DBPROPSET_SSCE_DBINIT) do
try
if FPassword <> '' then
AddPropStr(DBPROP_SSCE_DBPASSWORD, FPassword);
//if FMaxDatabaseSize <> 128 then
AddPropInt(DBPROP_SSCE_MAX_DATABASE_SIZE, FMaxDatabaseSize);
SetProperties(FIDBProperties);
finally
Free;
end;
end;
end;
procedure TOLEDBConnection.Connect(const ConnectString: string);
procedure SetSessionProperties;
var
OLEDBProperties: TOLEDBPropertiesSet;
begin
OLEDBProperties := TOLEDBPropertiesSet.Create(Self, DBPROPSET_SESSION);
try
//Set transaction properties
with OLEDBProperties do begin
AddPropInt(DBPROP_SESS_AUTOCOMMITISOLEVELS, ConvertIsolationLevelToOLEDBIsoLevel(FIsolationLevel))
end;
OLEDBProperties.SetProperties(FISessionProperties);
finally
OLEDBProperties.Free;
end;
end;
procedure SetDataSourceProperties;
var
OLEDBProperties: TOLEDBPropertiesSet;
begin
OLEDBProperties := TOLEDBPropertiesSet.Create(Self, DBPROPSET_DATASOURCE);
try
//Set transaction properties
with OLEDBProperties do begin
AddPropBool(DBPROP_MULTIPLECONNECTIONS, True);
SetProperties(FIDBProperties);
end;
finally
OLEDBProperties.Free;
end;
end;
function OpenProvider(const clsid: array of TGuid): HRESULT;
var
i: integer;
begin
Result := 0;
for i := Low(clsid) to High(clsid) do begin
Result := CoCreateInstance(clsid[i],
nil,
CLSCTX_INPROC_SERVER,
IID_IDBInitialize,
FIDBInitialize);
if Result <> REGDB_E_CLASSNOTREG then begin
FProviderId := clsid[i];
Exit;
end;
end;
end;
var
hr: HRESULT;
iu: IUnknown;
begin
if not FConnected then begin
try
hr := 0;
if FProvider = prAuto then
hr := OpenProvider([CLSID_SQLNCLI, CLSID_SQLOLEDB])
else
if FProvider = prSQL then
hr := OpenProvider([CLSID_SQLOLEDB])
else
if FProvider = prNativeClient then
hr := OpenProvider([CLSID_SQLNCLI])
else
if FProvider = prCompact then
hr := OpenProvider([CLSID_SQLSERVERCE_3_0])
else
DatabaseError(SBadProviderName);
if hr = REGDB_E_CLASSNOTREG then
DatabaseError(SMSSQLNotFound)
else
Check(hr, Component);
QueryIntf(FIDBInitialize, {$IFDEF CLR}IDBProperties{$ELSE}IID_IDBProperties{$ENDIF}, FIDBProperties);
//Set initialization properties.
SetConnectionProperties;
// SetDatabase(FDatabase); - setted on SetConnectionProperties
//Now establish the connection to the data source.
hr := FIDBInitialize.Initialize;
if (hr = E_FAIL) and (FProvider = prCompact) then begin // Database file is not exist
CreateDatabase(FDatabase, FPassword, FEncrypt);
hr := FIDBInitialize.Initialize;
end;
Check(hr, Component);
if FProvider <> prCompact then
SetDataSourceProperties;
//Create the SessionObject
QueryIntf(FIDBInitialize, {$IFDEF CLR}IDBCreateSession{$ELSE}IID_IDBCreateSession{$ENDIF}, FIDBCreateSession);
Check(FIDBCreateSession.CreateSession(nil, IID_ISessionProperties, iu), Component);
FISessionProperties := ISessionProperties(iu);
if FProvider <> prCompact then
SetSessionProperties;
QueryIntf(FISessionProperties, {$IFDEF CLR}ITransactionLocal{$ELSE}IID_ITransactionLocal{$ENDIF}, FITransactionLocal);
// Get properties ------------------------------
GetConnectionProperties;
inherited;
FConnected := True;
if not FQuotedIdentifier then
SetQuotedIdentifier(FQuotedIdentifier);
except
on EFailOver do;
else begin
ReleaseInterfaces;
raise;
end;
end;
end;
end;
procedure TOLEDBConnection.Disconnect;
begin
if FConnected then begin
if FIDBInitialize <> nil then
FIDBInitialize.Uninitialize;// check not need
ReleaseInterfaces;
FConnected := False;
FreeAndNil(FColumnsMetaInfo);
FreeAndNil(FColumnsRowsetFieldDescs);
end;
end;
procedure TOLEDBConnection.Assign(Source: TOLEDBConnection);
begin
FConnectionTimeout := Source.FConnectionTimeout;
FServer := Source.FServer;
FUsername := Source.FUsername;
FPassword := Source.FPassword;
FDatabase := Source.FDatabase;
FIsolationLevel := Source.FIsolationLevel;
FAuthentication := Source.FAuthentication;
FProvider := Source.FProvider;
FQuotedIdentifier := Source.FQuotedIdentifier;
FLanguage := Source.FLanguage;
FEncrypt := Source.FEncrypt;
FPersistSecurityInfo := Source.FPersistSecurityInfo;
FAutoTranslate := Source.FAutoTranslate;
FNetworkLibrary := Source.FNetworkLibrary;
FApplicationName := Source.FApplicationName;
FWorkstationID := Source.FWorkstationID;
FPacketSize := Source.FPacketSize;
FMaxDatabaseSize := Source.FMaxDatabaseSize;
end;
procedure TOLEDBConnection.SetIDBCreateSession(CreateSession: IDBCreateSession);
var
iu: IUnknown;
begin
Assert(not FConnected);
//Obtain access to the SQLOLEDB provider.
try
FIDBCreateSession := CreateSession;
Check(FIDBCreateSession.CreateSession(nil, IID_ISessionProperties, iu), Component);
FISessionProperties := ISessionProperties(iu);
QueryIntf(FISessionProperties, {$IFDEF CLR}ITransactionLocal{$ELSE}IID_ITransactionLocal{$ENDIF}, FITransactionLocal);
FConnected := True;
if not FQuotedIdentifier then
SetQuotedIdentifier(FQuotedIdentifier);
except
ReleaseInterfaces;
raise;
end;
end;
function TOLEDBConnection.GetProp(Prop: integer; var Value: variant): boolean;
begin
Result := True;
case Prop of
prDatabase:
Value := FDatabase; // string
prIsolationLevel:
Value := Integer(FIsolationLevel);
prAuthentication:
Value := Integer(FAuthentication); //TMSAuthentication
prConnectionTimeout:
Value := Integer(FConnectionTimeout);
prMaxDatabaseSize:
Value := Integer(FMaxDatabaseSize);
else
Result := inherited GetProp(Prop, Value);
end;
end;
function TOLEDBConnection.SetProp(Prop: integer; const Value: variant): boolean;
begin
Result := True;
case Prop of
prDatabase:
SetDatabase(Value);
prIsolationLevel:
FIsolationLevel := TIsolationLevel(Integer(Value));
{prMultipleConnections:
FMultipleConnections := boolean(Value^);}
prAuthentication:
FAuthentication := TMSAuthentication(Integer(Value)); //TMSAuthentication
prProvider:
FProvider := TOLEDBProvider(Integer(Value));
prConnectionTimeout:
FConnectionTimeout := Integer(Value);
prQuotedIdentifier:
SetQuotedIdentifier(boolean(Value));
prLanguage:
FLanguage := Value;
prAutoTranslate:
FAutoTranslate := Boolean(Value);
prEncrypt:
FEncrypt := Boolean(Value);
prPersistSecurityInfo:
FPersistSecurityInfo := Boolean(Value);
prNetworkLibrary:
FNetworkLibrary := Value;
prApplicationName:
FApplicationName := Value;
prWorkstationID:
FWorkstationID := Value;
prPacketSize:
FPacketSize := Integer(Value);
prInitialFileName:
FInitialFileName := Value;
prMARS:
FMultipleActiveResultSets := Value;
prOldPassword:
FOldPassword := Value;
prMaxDatabaseSize:
FMaxDatabaseSize := Value;
prFailoverPartner:
FFailoverPartner := Value;
else
Result := inherited SetProp(Prop, Value);
end;
end;
function TOLEDBConnection.CheckIsValid: boolean;
begin
FIsValid := FIDBInitialize <> nil;
if FIsValid then
try
ExecSQL(SCheckConnection);
except
FIsValid := False;
end;
Result := FIsValid;
end;
procedure TOLEDBConnection.SetDatabase(const Value: string);
var
OLEDBProperties: TOLEDBPropertiesSet;
begin
if FIDBProperties <> nil then begin
OLEDBProperties := TOLEDBPropertiesSet.Create(Self, DBPROPSET_DATASOURCE);
try
with OLEDBProperties do
AddPropStr(DBPROP_CURRENTCATALOG, BracketIfNeed(Value));
OLEDBProperties.SetProperties(FIDBProperties);
finally
OLEDBProperties.Free;
end;
end;
FDatabase := Value;
end;
procedure TOLEDBConnection.SetQuotedIdentifier(const Value: boolean);
begin
FQuotedIdentifier := Value;
if FConnected then
if Value then
ExecSQL('SET QUOTED_IDENTIFIER ON')
else
ExecSQL('SET QUOTED_IDENTIFIER OFF');
end;
procedure TOLEDBConnection.ExecSQL(const Text: string);
begin
if FCommand = nil then begin
FCommand := TOLEDBCommand.Create;
TOLEDBCommand(FCommand).FConnection := Self;
end;
with FCommand do begin
SetSQL(Text);
try
Execute;
finally
FCommand.SetCursorState(csInactive); // To prevent blocking execute on second exec
end;
end;
end;
class procedure TOLEDBConnection.AssignFieldDescs(Source, Dest: TFieldDescs);
var
i: integer;
Field, FieldSource: TOLEDBFieldDesc;
begin
Dest.Clear;
for i := 0 to Source.Count - 1 do begin
FieldSource := Source[i] as TOLEDBFieldDesc;
Field := TOLEDBFieldDesc.Create;
Dest.Add(Field);
Field.Name := FieldSource.Name;
Field.ActualName := FieldSource.ActualName;
// FTableName: string; //table of name that holds this field
Field.DataType := FieldSource.DataType;
Field.SubDataType := FieldSource.SubDataType;
Field.Length := FieldSource.Length; // precision for number
Field.Scale := FieldSource.Scale;
Field.FieldNo := FieldSource.FieldNo;
Field.ActualFieldNo := FieldSource.ActualFieldNo;
Field.Size := FieldSource.Size;
//Field.DataSize := FieldSource.DataSize;
Field.Offset := FieldSource.Offset;
Field.DataOffset := FieldSource.DataOffset;
Field.Required := FieldSource.Required;
Field.ReadOnly := FieldSource.ReadOnly;
Field.IsKey := FieldSource.IsKey;
Field.Fixed := FieldSource.Fixed;
Field.Hidden := FieldSource.Hidden;
//Field.ObjectType := FieldSource.ObjectType;
//Field.ParentField := FieldSource.ParentField;
//Field.HiddenObject := FieldSource.HiddenObject;
//FHandle: IntPtr; // IntPtr to field specific data
//FReserved: boolean; // reserved flag for perfomance optimization
end;
end;
{$IFDEF CLR}
procedure TOLEDBConnection.DoError(E: Exception; var Fail: boolean);
begin
inherited;
end;
{$ENDIF}
procedure TOLEDBConnection.CreateDatabase(const Database: string; const Password: string; const Encrypted: boolean);
var
pIDBDataSourceAdmin: IDBDataSourceAdmin;
pIUnknownSession: IUnknown;
PPropertySet: IntPtr;
PropertySet: PDBPropSet;
PDBProperty: IntPtr;
DBProperty: PDBProp;
PSSCEProperty: IntPtr;
SSCEProperty: PDBPROP;
begin
PPropertySet := nil;
PDBProperty := nil;
PSSCEProperty := nil;
try
Check(CoCreateInstance(CLSID_SQLSERVERCE_3_0, nil, CLSCTX_INPROC_SERVER,
IID_IDBDataSourceAdmin, pIDBDataSourceAdmin), Component);
PDBProperty := Marshal.AllocHGlobal(SizeOfDBProp);
FillChar(PDBProperty, SizeOfDBProp, $00);
DBProperty := PDBProperty;
DBProperty.dwPropertyID := DBPROP_INIT_DATASOURCE;
DBProperty.dwOptions := DBPROPOPTIONS_REQUIRED;
DBProperty.vValue := Database;
PSSCEProperty := Marshal.AllocHGlobal(SizeOfDBProp * 2);
FillChar(PSSCEProperty, SizeOfDBProp * 2, $00);
SSCEProperty := PSSCEProperty;
SSCEProperty.dwPropertyID := DBPROP_SSCE_ENCRYPTDATABASE;
SSCEProperty.dwOptions := DBPROPOPTIONS_REQUIRED;
SSCEProperty.vValue := VarAsType(Encrypted, VT_BOOL);
SSCEProperty := IntPtr(Integer(PSSCEProperty) + SizeOfDBProp);
SSCEProperty.dwPropertyID := DBPROP_SSCE_DBPASSWORD;
SSCEProperty.dwOptions := DBPROPOPTIONS_REQUIRED;
SSCEProperty.vValue := Password;
PPropertySet := Marshal.AllocHGlobal(SizeOf(DBPROPSET) * 2);
FillChar(PPropertySet, SizeOf(DBPROPSET) * 2, $00);
PropertySet := PPropertySet;
PropertySet.guidPropertySet := DBPROPSET_DBINIT;
PropertySet.rgProperties := PDBProperty;
PropertySet.cProperties := 1;
PropertySet := IntPtr(Integer(PPropertySet) + SizeOf(DBPROPSET));
PropertySet.guidPropertySet := DBPROPSET_SSCE_DBINIT ;
PropertySet.rgProperties := PSSCEProperty;
PropertySet.cProperties := 2;
Check(pIDBDataSourceAdmin.CreateDataSource(2, PPropertySet, nil,
IID_IUnknown, pIUnknownSession), Component);
finally
pIUnknownSession := nil;
if PPropertySet <> nil then
Marshal.FreeHGlobal(PPropertySet);
if PSSCEProperty <> nil then
Marshal.FreeHGlobal(PSSCEProperty);
if PDBProperty <> nil then
Marshal.FreeHGlobal(PDBProperty);
end;
end;
function TOLEDBConnection.GetSchemaRowset(const Schema: TGUID; rgRestrictions: TRestrictions): IRowset;
var
i: integer;
iu: IUnknown;
DBSchemaRowset: IDBSchemaRowset;
rgRestrictionsPtr: IntPtr;
begin
for i := Low(rgRestrictions) to High(rgRestrictions) do
if (VarType(rgRestrictions[i]) = varOleStr) and (String(rgRestrictions[i]) = '') then
rgRestrictions[i] := Null; //
// rgRestrictions[i] := Unassigned;
// TVarData(rgRestrictions[i]).VType := varNull;
QueryIntf(SessionProperties, {$IFDEF CLR}IDBSchemaRowset{$ELSE}IID_IDBSchemaRowset{$ENDIF}, DBSchemaRowset);
{$IFDEF CLR}
i := 16 {SizeOf(OleVariant)} * Length(rgRestrictions);
rgRestrictionsPtr := Marshal.AllocHGlobal(i);
try
FillChar(rgRestrictionsPtr, i, 0);
for i := Low(rgRestrictions) to High(rgRestrictions) do
SetOleVariant(IntPtr(Integer(rgRestrictionsPtr) + 16 {SizeOf(OleVariant)} * (Integer(i) - Low(rgRestrictions))), rgRestrictions[i]);
{$ELSE}
rgRestrictionsPtr := @rgRestrictions[0];
{$ENDIF}
Check(DBSchemaRowset.GetRowset(nil, Schema, Length(rgRestrictions), rgRestrictionsPtr,
IID_IRowset, 0, nil, iu), Component);
{$IFDEF CLR}
finally
for i := Low(rgRestrictions) to High(rgRestrictions) do
OleVarClear(IntPtr(Integer(rgRestrictionsPtr) + 16 {SizeOf(OleVariant)} * (Integer(i) - Low(rgRestrictions))));
Marshal.FreeHGlobal(rgRestrictionsPtr);
end;
{$ENDIF}
Result := IRowset(iu);
iu := nil;
end;
{ TOLEDBCommand }
procedure TOLEDBCommand.Check(const Status: HRESULT);
begin
Assert(FConnection <> nil);
if Status <> S_OK then
FConnection.Check(Status, Component);
end;
constructor TOLEDBCommand.Create;
begin
inherited;
FQueryIntCnt := 0;
FRequestIUnknown := False;
FParamsAccessorDataAvaible := False;
FRowsAffected := -1;
FCursorState := csInactive;
FBreakExecCS := TCriticalSection.Create;
end;
destructor TOLEDBCommand.Destroy;
begin
if FNonBlocking and (FISSAsynchStatus <> nil) then
BreakExec;
FISSAsynchStatus := nil;
ClearIMultipleResults;
FIUnknownNext := nil; /// Clear this interface before RequestParams to avoid AV. See TDbxSdaTestSet.DoTestSPNextRecordSet
RequestParamsIfPossible;
UnPrepare;
Assert(FQueryIntCnt = 0, Format('TOLEDBCommand.Destroy - interfaces not released (%d)', [FQueryIntCnt]));
FBreakExecCS.Free;
inherited;
end;
procedure TOLEDBCommand.QueryInterfaces(const QueryPrepare: boolean); // QueryPrepare must be True to request IID_ICommandPrepare
var
CreateCommand: IDBCreateCommand;
iu: IUnknown;
begin
if FQueryIntCnt = 0 then begin
Assert(FConnection <> nil);
QueryIntf(FConnection.FISessionProperties, {$IFDEF CLR}IDBCreateCommand{$ELSE}IID_IDBCreateCommand{$ENDIF}, CreateCommand);
Check(CreateCommand.CreateCommand(nil, IID_ICommandText, iu));
FICommandText := ICommandText(iu);
if QueryPrepare then
QueryIntf(FICommandText, {$IFDEF CLR}ICommandPrepare{$ELSE}IID_ICommandPrepare{$ENDIF}, FICommandPrepare)
else
FICommandPrepare := nil;
QueryIntf(FICommandText, {$IFDEF CLR}ICommandProperties{$ELSE}IID_ICommandProperties{$ENDIF}, FICommandProperties);
end;
Inc(FQueryIntCnt);
end;
procedure TOLEDBCommand.ReleaseInterfaces;
begin
if FQueryIntCnt = 0 then // Exception on TOLEDBRecordSet.InternalOpen -> TOLEDBRecordSet.QueryCommandInterfaces -> TOLEDBCommand.QueryInterfaces
Exit;
if FQueryIntCnt = 1 then begin
FBreakExecCS.Acquire;
try
FICommandText := nil;
finally
FBreakExecCS.Release;
end;
FICommandPrepare := nil;
FICommandProperties := nil;
end;
Dec(FQueryIntCnt);
end;
(*procedure TOLEDBCommand.GetCommandProp;
var
rgPropertySets, pPropSet: PDBPropSet;
cPropertySets: UINT;
s: string;
// PropCnt: integer;
begin
try
Check(FICommandProperties.GetProperties(0, nil,
cPropertySets, PDBPropSet(rgPropertySets)));
Assert(rgPropertySets <> nil, 'Cannot get connection properties');
pPropSet := rgPropertySets; // DBPROPSET_ROWSET
// PropCnt := pPropSet.cProperties;
s := pPropSet.rgProperties[0].vValue;
PChar(pPropSet) := PChar(pPropSet) + sizeof(DBPropSet);//DBPROPSET_SQLSERVERROWSET
s := pPropSet.rgProperties[0].vValue;
s := pPropSet.rgProperties[1].vValue;
s := pPropSet.rgProperties[2].vValue;
s := pPropSet.rgProperties[3].vValue;
finally
FConnection.Malloc.Free(rgPropertySets.rgProperties);
FConnection.Malloc.Free(rgPropertySets);
end;
end;
type
PDBParamInfoArray = ^TDBParamInfoArray;
TDBParamInfoArray = array[0..MAXBOUND] of DBPARAMINFO;
*)
procedure TOLEDBCommand.SetCommandProp;
var
OLEDBProperties: TOLEDBPropertiesSet;
Str: WideString;
g: TGUID;
begin
{$IFDEF SDAC_TEST}
Inc(__SetCommandPropCount);
{$ENDIF}
Assert(FICommandText <> nil);
Str := FSQL;
g := DBGUID_DEFAULT;
Check(FICommandText.SetCommandText(g, {$IFDEF CLR}Str{$ELSE}PWideChar(Str){$ENDIF}));
OLEDBProperties := TOLEDBPropertiesSet.Create(FConnection, DBPROPSET_ROWSET);
try
with OLEDBProperties do begin
if FConnection.FProvider <> prCompact then
AddPropInt(DBPROP_COMMANDTIMEOUT, FCommandTimeout);
if FNonBlocking and (not FRequestIUnknown) then begin
if GUIDToString(FConnection.FProviderId) <> GUIDToString(CLSID_SQLNCLI) then
raise Exception.Create(SSQLNCLINeeds);
AddPropInt(DBPROP_ROWSET_ASYNCH, DBPROPVAL_ASYNCH_INITIALIZE);
end;
end;
OLEDBProperties.SetProperties(FICommandProperties);
finally
OLEDBProperties.Free;
end;
if FSmartRefresh then begin
OLEDBProperties := TOLEDBPropertiesSet.Create(FConnection, DBPROPSET_SQLSERVERROWSET);
try
with OLEDBProperties do begin
AddPropStr(SSPROP_QP_NOTIFICATION_MSGTEXT, WideString(FSmartRefreshMsg), True);
AddPropStr(SSPROP_QP_NOTIFICATION_OPTIONS, Format('service=%s', [FSmartRefreshService]), True);
end;
OLEDBProperties.SetProperties(FICommandProperties);
finally
OLEDBProperties.Free;
end;
end;
end;
procedure TOLEDBCommand.SetParameterInfo;
var
CommandWithParameters: ICommandWithParameters;
i: integer;
rgParamOrdinals: array of UInt;
rgParamBindInfo: array of TDBParamBindInfo;
ParamDesc: TParamDesc;
hr: HResult;
ParamCount: integer;
ParamVarType: TVarType;
prgParamOrdinals: IntPtr;
prgParamBindInfo: IntPtr;
{$IFDEF CLR}
rgParamOrdinalsGC: GCHandle;
rgParamBindInfoGC: GCHandle;
{$ENDIF}
IsUnicode: boolean;
begin
QueryIntf(FICommandText, {$IFDEF CLR}ICommandWithParameters{$ELSE}IID_ICommandWithParameters{$ENDIF}, CommandWithParameters);
CommandWithParameters.SetParameterInfo(0, nil, nil); /// Clear, just in case
ParamCount := FParams.Count;
if ParamCount <> 0 then begin
SetLength(rgParamOrdinals, ParamCount);
SetLength(rgParamBindInfo, ParamCount);
//OFS('=================================');
for i := 0 to ParamCount - 1 do begin
ParamDesc := FParams[i];
rgParamOrdinals[i] := i + 1;
case ParamDesc.GetDataType and varTypeMask of
dtUnknown: begin
ParamVarType := VarType(ParamDesc.Value);
case ParamVarType of
varSmallint: { vt_i2 2 }
rgParamBindInfo[i].pwszDataSourceType := dstSmallint;
varInteger: { vt_i4 3 }
rgParamBindInfo[i].pwszDataSourceType := dstInt;
varSingle: { vt_r4 4 }
rgParamBindInfo[i].pwszDataSourceType := dstReal;
varDouble: { vt_r8 5 }
rgParamBindInfo[i].pwszDataSourceType := dstFloat;
varCurrency: { vt_cy 6 }
rgParamBindInfo[i].pwszDataSourceType := dstMoney;
varDate: { vt_date 7 }
rgParamBindInfo[i].pwszDataSourceType := dstDatetime;
varOleStr: { vt_bstr 8 }
rgParamBindInfo[i].pwszDataSourceType := dstNVarchar;
{$IFNDEF CLR}
varString:
rgParamBindInfo[i].pwszDataSourceType := dstVarchar;
{$ENDIF}
varBoolean: { vt_bool 11 }
rgParamBindInfo[i].pwszDataSourceType := dstBit;
{$IFDEF VER6P}
varShortInt:
rgParamBindInfo[i].pwszDataSourceType := dstTinyint;
varWord:
rgParamBindInfo[i].pwszDataSourceType := dstInt;
varInt64: { vt_i8 20 }
rgParamBindInfo[i].pwszDataSourceType := dstBigint;
{$ENDIF}
varByte: { vt_ui1 17 }
rgParamBindInfo[i].pwszDataSourceType := dstSmallint;
varLongWord: { vt_ui4 19 }
rgParamBindInfo[i].pwszDataSourceType := dstBigint;
else
rgParamBindInfo[i].pwszDataSourceType := dstSql_variant;
end;
end;
dtString, dtExtString:
if IsOutputLOB(ParamDesc, FConnection.DBMSPrimaryVer, FConnection.ProviderPrimaryVer) then
rgParamBindInfo[i].pwszDataSourceType := dstVarcharMax
else
rgParamBindInfo[i].pwszDataSourceType := dstVarchar;
dtWideString, dtExtWideString:
if IsOutputLOB(ParamDesc, FConnection.DBMSPrimaryVer, FConnection.ProviderPrimaryVer) then
rgParamBindInfo[i].pwszDataSourceType := dstNVarcharMax
else
rgParamBindInfo[i].pwszDataSourceType := dstNVarchar;
dtInt8:
rgParamBindInfo[i].pwszDataSourceType := dstTinyint;
dtInt16:
rgParamBindInfo[i].pwszDataSourceType := dstSmallint;
dtInt32, dtUInt16:
rgParamBindInfo[i].pwszDataSourceType := dstInt;
dtInt64, dtUInt32:
rgParamBindInfo[i].pwszDataSourceType := dstBigint;
dtFloat:
rgParamBindInfo[i].pwszDataSourceType := dstFloat;
dtDate, dtTime, dtDateTime:
rgParamBindInfo[i].pwszDataSourceType := dstDatetime;
dtBoolean:
rgParamBindInfo[i].pwszDataSourceType := dstBit;
dtCurrency:
rgParamBindInfo[i].pwszDataSourceType := dstMoney;
dtBlob:
rgParamBindInfo[i].pwszDataSourceType := dstImage;
dtMemo, dtWideMemo, dtMSXML: begin
{$IFDEF CLR}
IsUnicode := (VarType(ParamDesc.Value) = varOleStr) or (VarType(ParamDesc.Value) = varString);
if not IsUnicode
and (ParamDesc.Value <> nil)
and (ParamDesc.Value is TBlob) then
IsUnicode := TBlob(ParamDesc.Value).IsUnicode;
{$ELSE}
IsUnicode := VarType(ParamDesc.Value) = varOleStr;
if not IsUnicode
and (VarType(ParamDesc.Value) = varByRef)
and (TVarData(ParamDesc.Value).VPointer <> nil) then begin
// Assert(TObject(TVarData(ParamDesc.Value).VPointer) is TBlob); - trial
IsUnicode := TBlob(TVarData(ParamDesc.Value).VPointer).IsUnicode;
end;
{$ENDIF}
if IsUnicode then
rgParamBindInfo[i].pwszDataSourceType := dstNVarchar
else
rgParamBindInfo[i].pwszDataSourceType := dstVarchar;
end;
{$IFDEF VER5P}
dtVariant:
rgParamBindInfo[i].pwszDataSourceType := dstSql_variant;
{$ENDIF}
dtBytes:
rgParamBindInfo[i].pwszDataSourceType := dstBinary;
dtVarBytes, dtExtVarBytes:
rgParamBindInfo[i].pwszDataSourceType := dstVarbinary;
{$IFDEF VER6P}
dtFMTBCD,
{$ENDIF}
dtBCD:
rgParamBindInfo[i].pwszDataSourceType := dstMoney;
dtGuid:
rgParamBindInfo[i].pwszDataSourceType := dstGuid;
else
Assert(False, Format('Unknown datatype for param %s[%d] = %X', [ParamDesc.GetName, i, ParamDesc.GetDataType]));
end;
case ParamDesc.GetDataType of
dtString, dtExtString, dtBytes, dtVarBytes, dtExtVarBytes:
if ParamDesc.GetSize > 0 then
rgParamBindInfo[i].ulParamSize := ParamDesc.GetSize
else
rgParamBindInfo[i].ulParamSize := MaxNonBlobFieldLen;
dtWideString, dtExtWideString:
if ParamDesc.GetSize > 0 then
rgParamBindInfo[i].ulParamSize := ParamDesc.GetSize
else
rgParamBindInfo[i].ulParamSize := MaxNonBlobFieldLen div SizeOf(WideChar);
else
rgParamBindInfo[i].ulParamSize := $FFFFFFF;
end;
case ParamDesc.GetParamType of
pdInput:
rgParamBindInfo[i].dwFlags := DBPARAMFLAGS_ISINPUT + DBPARAMFLAGS_ISNULLABLE;
pdOutput, pdResult:
rgParamBindInfo[i].dwFlags := DBPARAMFLAGS_ISOUTPUT + DBPARAMFLAGS_ISNULLABLE;
pdUnknown, pdInputOutput:
rgParamBindInfo[i].dwFlags := DBPARAMFLAGS_ISINPUT + DBPARAMFLAGS_ISOUTPUT + DBPARAMFLAGS_ISNULLABLE;
end;
rgParamBindInfo[i].pwszName := nil;
{OFS(ParamDesc.GetName);
OFS(' ' + Marshal.PtrToStringUni(rgParamBindInfo[i].pwszDataSourceType));
OFS(' ulParamSize = ' + IntToStr(rgParamBindInfo[i].ulParamSize));
OFS(' dwFlags = ' + IntToStr(rgParamBindInfo[i].dwFlags));
OFS(' bPrecision = ' + IntToStr(rgParamBindInfo[i].bPrecision));
OFS(' bScale = ' + IntToStr(rgParamBindInfo[i].bScale));//}
end;
{$IFDEF CLR}
try
rgParamOrdinalsGC := GCHandle.Alloc(rgParamOrdinals, GCHandleType.Pinned);
prgParamOrdinals := Marshal.UnsafeAddrOfPinnedArrayElement(rgParamOrdinals, 0);
rgParamBindInfoGC := GCHandle.Alloc(rgParamBindInfo, GCHandleType.Pinned);
prgParamBindInfo := Marshal.UnsafeAddrOfPinnedArrayElement(rgParamBindInfo, 0);
{$ELSE}
prgParamOrdinals := @rgParamOrdinals[0];
prgParamBindInfo := @rgParamBindInfo[0];
{$ENDIF}
{OFS('prgParamOrdinals');
OFS(prgParamOrdinals, ParamCount * 4, OFSFileName);
OFS('prgParamBindInfo');
OFS(prgParamBindInfo, ParamCount * sizeof(rgParamBindInfo[0]), OFSFileName);//}
hr := CommandWithParameters.SetParameterInfo(ParamCount, prgParamOrdinals, prgParamBindInfo);
{$IFDEF CLR}
finally
if IntPtr(rgParamOrdinalsGC) <> nil then
rgParamOrdinalsGC.Free;
if IntPtr(rgParamBindInfoGC) <> nil then
rgParamBindInfoGC.Free;
end;
{$ENDIF}
if hr <> DB_S_TYPEINFOOVERRIDDEN then
Check(hr);
end;
end;
procedure TOLEDBCommand.Prepare;
begin
if GetPrepared then
Exit;
QueryInterfaces(True);
try
FRPCCall := FIsSProc and __UseRPCCallStyle;
SetCommandProp;
if FRPCCall or (not ParamsInfoOldBehavior) then
SetParameterInfo;
Check(FICommandPrepare.Prepare(0)); // If statement is wrong in some cases exception may be occured in other place
{$IFDEF SDAC_TEST}
Inc(__ServerPrepareCount);
{$ENDIF}
inherited;
FPrepared := True;
except
ReleaseInterfaces;
raise;
end;
end;
procedure TOLEDBCommand.Unprepare;
begin
if GetPrepared then begin
FIUnknown := nil;
RequestParamsIfPossible;
if (FICommandPrepare <> nil) and not FRPCCall then
Check(FICommandPrepare.UnPrepare);
inherited;
FPrepared := False;
FRPCCall := False;
ReleaseInterfaces;
end;
end;
function TOLEDBCommand.GetPrepared: boolean;
begin
Result := FPrepared;
end;
{$IFNDEF VER6P}
type
_TParamDesc = class (TParamDesc);
{$ENDIF}
procedure FillBindingForParam(Ordinal: integer; ParamDesc: TOLEDBParamDesc; Connection: TOLEDBConnection;
var pBind: TDBBinding; var BindMemorySize: UINT; const ValueAvaliable: boolean; const IsWide: boolean);
procedure SetBindDefaults;
begin
pBind.dwPart := DBPART_STATUS or DBPART_LENGTH or DBPART_VALUE; // WAR Length is not always need and may be removed in some cases
{$IFNDEF CLR}
pointer(pBind.pTypeInfo) := nil;
{$ENDIF}
pBind.pBindExt := nil;
pBind.dwMemOwner := DBMEMOWNER_CLIENTOWNED;
pBind.dwFlags := 0;
pBind.bPrecision := 11;
pBind.bScale := 0;
end;
procedure SetBindData;
function GetMaxLen: integer; // Also correct pBind.wType. Must be called AFTER ConvertInternalTypeToOLEDB
var
IsUnicode: boolean;
DataType: word;
begin
DataType := ParamDesc.GetDataType;
case DataType of
dtUnknown:
Result := sizeof(OleVariant);
dtString:
if not ValueAvaliable then
Result := MaxNonBlobFieldLen
else
Result := ParamDesc.GetSize + 1{#0};
dtWideString:
Result := (ParamDesc.GetSize + 1{#0}) * sizeof(WideChar);
dtBytes, dtVarBytes:
Result := ParamDesc.GetSize;
dtInt8:
Result := sizeof(byte);
dtInt16, dtWord:
if Connection.FProvider = prCompact then begin
if (ParamDesc.OLEDBType = DBTYPE_UI1) then begin
Result := SizeOf(Byte);
pBind.wType := DBTYPE_UI1;
end
else
Result := sizeof(word);
end
else
Result := sizeof(word);
dtInt32:
Result := sizeof(dword);
dtFloat:
if Connection.FProvider = prCompact then begin
if (ParamDesc.OLEDBType = DBTYPE_R4) then begin
Result := SizeOf(Single);
pBind.wType := DBTYPE_R4;
end
else
if (ParamDesc.OLEDBType = DBTYPE_NUMERIC) then begin
Result := SizeOfTDBNumeric;
pBind.wType := DBTYPE_NUMERIC;
end
else
Result := SizeOf(double);
end
else
Result := sizeof(double);
dtCurrency:
Result := sizeof(double);
// Result := sizeof(Currency); Currency type cannot be used over TCurrencyField uses double to store
dtDate:
Result := sizeof(TDateTime);
dtDateTime, dtTime:
begin
Result := sizeof(TDBTimeStamp);
pBind.wType := DBTYPE_DBTIMESTAMP;
end;
dtBoolean:
Result := sizeof(WordBool);
dtInt64:
Result := sizeof(Int64);
dtBlob, dtMemo, dtWideMemo, dtMSXML:
if Connection.FProvider <> prCompact then
if IsOutputLOB(ParamDesc, Connection.DBMSPrimaryVer, Connection.ProviderPrimaryVer) then
Result := SizeOf(TOLEDBStream) // varchar(max)
else
Result := 0 // Only Input, store ByRef
else begin
if ((DataType = dtMemo) or (DataType = dtWideMemo)) and (ParamDesc.OLEDBType in [DBTYPE_STR, DBTYPE_WSTR]) then begin
Result := TBlob(ParamDesc.GetObject).Size;
pBind.wType := ParamDesc.OLEDBType;
end
else
Result := SizeOf(TOLEDBStream);
end;
{$IFDEF VER5P}
dtGuid:
Result := sizeof(TGuid);
dtVariant:
Result := sizeof(OleVariant);
{$ENDIF}
dtBCD:
if Connection.FProvider <> prCompact then
Result := sizeof(Currency)
else begin
Result := SizeOfTDBNumeric;
pBind.wType := DBTYPE_NUMERIC;
end;
{$IFDEF VER6P}
dtFmtBCD:
if Connection.FProvider <> prCompact then
Result := SizeOfTBcd * 2
else
Result := SizeOfTDBNumeric;
{$ENDIF}
else
Result := 0;
end;
if (Connection.FProvider = prCompact) and IsLargeDataTypeUsed(ParamDesc) and ParamDesc.GetNull then begin
Result := 0;
case ParamDesc.GetDataType of
dtBlob:
pBind.wType := DBTYPE_BYTES;
dtMemo, dtWideMemo:
pBind.wType := DBTYPE_WSTR;
else
Assert(False);
end;
end;
// Optimization for input-only parameters
if (((ParamDesc.GetParamType = pdInput) and (DataType in CharsByRef + BytesByRef) {$IFDEF CLR}and (DataType <> dtString){$ENDIF})
or (DataType = dtBlob)
or (DataType = dtMemo)
or (DataType = dtWideMemo)
or (DataType = dtMSXML))
and (Connection.FProvider <> prCompact)
and (not IsOutputLOB(ParamDesc, Connection.DBMSPrimaryVer, Connection.ProviderPrimaryVer)) then begin
// Only Input, store ByRef
Result := 4;
if (DataType in BytesByRef) then // This is Bytes by Ref
pBind.wType := DBTYPE_BYREF or DBTYPE_BYTES
else // This is (Wide)String by Ref
begin
{$IFDEF CLR}
if not ValueAvaliable then
IsUnicode := (ParamDesc.GetDataType in [dtWideString, dtExtWideString]) or IsWide
else
IsUnicode := (VarType(ParamDesc.Value) = varOleStr) or (VarType(ParamDesc.Value) = varString);
if not IsUnicode
and (ParamDesc.Value <> nil)
and (ParamDesc.Value is TBlob) then
IsUnicode := TBlob(ParamDesc.Value).IsUnicode;
{$ELSE}
if not ValueAvaliable then
IsUnicode := (ParamDesc.GetDataType in [dtWideString, dtExtWideString]) or IsWide
else
IsUnicode := VarType(ParamDesc.Value) = varOleStr;
if not IsUnicode
and (VarType(ParamDesc.Value) = varByRef)
and (TVarData(ParamDesc.Value).VPointer <> nil) then begin
// Assert(TObject(TVarData(ParamDesc.Value).VPointer) is TBlob); - trial
IsUnicode := TBlob(TVarData(ParamDesc.Value).VPointer).IsUnicode;
end;
{$ENDIF}
if IsUnicode then // WideString
pBind.wType := DBTYPE_BYREF or DBTYPE_WSTR
else // (VType = varString) String
pBind.wType := DBTYPE_BYREF or DBTYPE_STR;
end;
end
else
if (ParamDesc.GetParamType in [pdOutput, pdInputOutput]) // Truncate params, if too long
and (DataType in [dtString, dtWideString, dtBytes, dtVarBytes]) then begin
if not ((Connection.DBMSPrimaryVer >= 9) and (Connection.ProviderPrimaryVer >=9) and (Result > MaxNonBlobFieldLen)) then
if DataType = dtString then
Result := MaxNonBlobFieldLen + 1
else
Result := MaxNonBlobFieldLen;
end;
Assert(Result >= 0);
// Assert(Result <= MaxNonBlobFieldLen + 1);
end;
var
ServerVersion: integer;
begin
{ if pBind.iOrdinal = 1 then
OFS('==========================================');
OFS('--------------------------');
OFS('ParamDesc.GetName ' + ParamDesc.GetName);
OFS('VarType(ParamDesc.Value) = ' + IntToStr(VarType(ParamDesc.Value)));}
pBind.iOrdinal := Ordinal;
pBind.eParamIO := ConvertCRParamTypeToOLEDB(ParamDesc.GetParamType);
if IsLargeDataTypeUsed(ParamDesc) and // "text", "ntext", "image"
(pBind.eParamIO in [DBPARAMIO_OUTPUT, DBPARAMIO_INPUT + DBPARAMIO_OUTPUT]) then
if not IsOutputLOB(ParamDesc, Connection.DBMSPrimaryVer, Connection.ProviderPrimaryVer) then // "varchar(max)"
DatabaseErrorFmt(SBadOutputParam, [ParamDesc.GetName]);
// int64 parameters conversion
if ((Connection.ProviderPrimaryVer < 8) and not IsWindowsVista) and (Connection.FProvider <> prCompact) and
(ParamDesc.GetDataType = dtInt64) then
ParamDesc.SetDataType(dtFloat);
// currency parameters conversion
if (ParamDesc.GetDataType = dtCurrency) and (VarType(ParamDesc.Value) = varCurrency) then
ParamDesc.SetDataType(dtBCD); // To prevent SQL Server exception on setting float value to smallmoney parameter
if Connection <> nil then
ServerVersion := Connection.DBMSPrimaryVer
else
ServerVersion := 0;
pBind.wType := ConvertInternalTypeToOLEDB(ParamDesc.GetDataType, True, ServerVersion);
(* Not used
if pBind.wType = DBTYPE_IUNKNOWN then begin
GetMem1(pBind.pObject, sizeof(DBOBJECT));
pBind.pObject^.iid := IID_ISequentialStream;
if pBind.eParamIO = DBPARAMIO_INPUT then
pBind.pObject^.dwFlags := STGM_READ
else
pBind.pObject^.dwFlags := STGM_READWRITE;
end;*)
pBind.obStatus := BindMemorySize;
pBind.obLength := BindMemorySize + sizeof(DWORD);
pBind.obValue := BindMemorySize + sizeof(DWORD) + sizeof(UINT);
pBind.cbMaxLen := GetMaxLen; // Also correct pBind.wType. Must be called AFTER ConvertInternalTypeToOLEDB
if not ((ServerVersion = 3) and ((pBind.wType = DBTYPE_BYTES) or (pBind.wType = DBTYPE_WSTR))) then
Assert(pBind.cbMaxLen > 0, Format('Unknown datatype for param %s[%d] = %X', [ParamDesc.GetName, Ordinal, ParamDesc.GetDataType]));
BindMemorySize := pBind.obValue + pBind.cbMaxLen;
{OFS('iOrdinal = ' + IntToStr(pBind.iOrdinal));
OFS('obValue = ' + IntToStr(pBind.obValue));
OFS('obLength = ' + IntToStr(pBind.obLength));
OFS('obStatus = ' + IntToStr(pBind.obStatus));
OFS('pTypeInfo = ' + IntToStr(Integer(pBind.pTypeInfo)));
OFS('pObject = ' + IntToStr(Integer(pBind.pObject)));
OFS('pBindExt = ' + IntToStr(Integer(pBind.pBindExt)));
OFS('dwPart = ' + IntToStr(pBind.dwPart));
OFS('dwMemOwner = ' + IntToStr(pBind.dwMemOwner));
OFS('eParamIO = ' + IntToStr(pBind.eParamIO));
OFS('cbMaxLen = ' + IntToStr(pBind.cbMaxLen));
OFS('dwFlags = ' + IntToStr(pBind.dwFlags));
OFS('wType = ' + IntToStr(pBind.wType));
OFS('bPrecision = ' + IntToStr(pBind.bPrecision));
OFS('bScale = ' + IntToStr(pBind.bScale));}
end;
begin
SetBindDefaults;
SetBindData;
end;
procedure SaveParamValue(const ParamDesc: TParamDesc; const pBind: TDBBinding;
var ParamsAccessorData: TParamsAccessorData{$IFDEF HAVE_COMPRESS};
const CompressBlobMode: TCompressBlobMode{$ENDIF}
{$IFDEF CLR}; var ParamsGC: TIntPtrDynArray{$ENDIF}; ServerVersion, ClientVersion: integer);
var
pStatus: PDWORD;
pLength: PUINT;
pValue: IntPtr;
// pParamData: PVarData;
ParamVarType: TVarType;
ParamVarPtr: IntPtr;
s: string;
l: UINT;
ws: WideString;
c: Currency;
i64: Int64;
Blob: TBlob;
{$IFDEF CLR}
d: double;
b: TBytes;
{$ENDIF}
{$IFDEF VER6P}
DotPos: integer;
Bcd: TBcd;
{$ENDIF}
{$IFDEF HAVE_COMPRESS}
Compress: boolean;
{$ENDIF}
dt: TDateTime;
AYear, AMonth, ADay, AHour, AMinute, ASecond, AMilliSecond: Word;
DBTimeStamp: TDBTimeStamp;
DBNumeric: TDBNumeric;
Stream: ISequentialStream;
OLEDBStream: TOLEDBStream;
begin
{OFS('-------');
OFS('[' + IntToStr(pBind.iOrdinal) + ']');
OFS('pBind.eParamIO=' + IntToStr(pBind.eParamIO));
OFS('pBind.obValue=' + IntToStr(pBind.obValue));
OFS('pBind.obLength=' + IntToStr(pBind.obLength));
OFS('pBind.obStatus=' + IntToStr(pBind.obStatus));
OFS('pBind.wType=' + IntToStr(pBind.wType));
OFS('pBind.dwFlags=' + IntToStr(pBind.dwFlags));
OFS('pBind.bPrecision=' + IntToStr(pBind.bPrecision));
OFS('pBind.bScale=' + IntToStr(pBind.bScale));
OFS('pBind.cbMaxLen=' + IntToStr(pBind.cbMaxLen));
OFS('ParamDesc.GetNull=' + BoolToStr(ParamDesc.GetNull, True));
OFS('ParamDesc.GetParamType=' + IntToStr(Integer(ParamDesc.GetParamType)));
OFS('ParamDesc.GetDataType=' + IntToStr(ParamDesc.GetDataType));}
if pBind.eParamIO in [DBPARAMIO_INPUT, DBPARAMIO_INPUT + DBPARAMIO_OUTPUT] then begin
pStatus := PDWORD(UINT(Integer(ParamsAccessorData.ExecuteParams.pData)) + pBind.obStatus);
pValue := IntPtr(UINT(Integer(ParamsAccessorData.ExecuteParams.pData)) + pBind.obValue); // Destination
if TOLEDBParamDesc(ParamDesc).UseDefaultValue then begin
FillChar(pValue, pBind.cbMaxLen, 0);
Marshal.WriteInt32(pStatus, Integer(DBSTATUS_S_DEFAULT));
end
else
if ParamDesc.GetNull then begin
FillChar(pValue, pBind.cbMaxLen, 0);
Marshal.WriteInt32(pStatus, Integer(DBSTATUS_S_ISNULL));
end
else
begin
Marshal.WriteInt32(pStatus, Integer(DBSTATUS_S_OK));
pLength := PUINT(UINT(Integer(ParamsAccessorData.ExecuteParams.pData)) + pBind.obLength);
ParamVarType := VarType(ParamDesc.Value);
// pParamData := @TVarData(ParamDesc.Value); // Source
if (((ParamDesc.GetParamType = pdInput) and (ParamDesc.GetDataType in CharsByRef + BytesByRef){$IFDEF CLR}and (ParamDesc.GetDataType <> dtString){$ENDIF})
or (ParamDesc.GetDataType in [dtBlob, dtMemo, dtWideMemo, dtMSXML])) and (ServerVersion <> 3) and (not IsOutputLOB(ParamDesc, ServerVersion, ClientVersion))
then begin
// Optimization for input-only parameters, store by ref
if ParamVarType = varArray + varByte then begin
{$IFDEF CLR}
l := Length(ParamsGC);
SetLength(ParamsGC, l + 1);
ParamsGC[l] := AllocGCHandle(ParamDesc.Value, True);
ParamVarPtr := GetAddrOfPinnedObject(ParamsGC[l]);
l := VarArrayHighBound(ParamDesc.Value, 1) - VarArrayLowBound(ParamDesc.Value, 1) + 1;
{$ELSE}
ParamVarPtr := TVarData(ParamDesc.Value).VArray.Data;
l := TVarData(ParamDesc.Value).VArray.Bounds[0].ElementCount;
{$ENDIF}
Marshal.WriteIntPtr(pValue, ParamVarPtr);
Marshal.WriteInt32(pLength, l);
end
else
{$IFDEF CLR}
if ParamDesc.Value is TBlob then begin
Assert(ParamDesc.Value <> nil);
Blob := TBlob(ParamDesc.Value);
{$ELSE}
if ParamVarType = varByRef then begin
Assert(TVarData(ParamDesc.Value).VPointer <> nil);
// Assert(TObject(TVarData(ParamDesc.Value).VPointer) is TBlob); - trial
Blob := TVarData(ParamDesc.Value).VPointer;
{$ENDIF}
Blob.Defrag;
{$IFDEF HAVE_COMPRESS}
Compress := Blob is TCompressedBlob;
if Compress then
TCompressedBlob(Blob).Compressed := (CompressBlobMode = cbServer) or (CompressBlobMode = cbClientServer);
if Compress and TCompressedBlob(Blob).Compressed then
Marshal.WriteInt32(pLength, Integer(TCompressedBlob(Blob).CompressedSize))
else
{$ENDIF}
Marshal.WriteInt32(pLength, Integer(Blob.Size));
if IntPtr(Blob.FirstPiece) = nil then
Marshal.WriteIntPtr(pValue, nil)
else
Marshal.WriteIntPtr(pValue, IntPtr(Integer(Blob.FirstPiece) + sizeof(TPieceHeader)));
end
else
begin // CharsByRef Input parameter
{$IFDEF CLR}
l := Length(ParamsGC);
SetLength(ParamsGC, l + 1);
ParamsGC[l] := AllocGCHandle(ParamDesc.Value, True);
ParamVarPtr := GetAddrOfPinnedObject(ParamsGC[l]);
{$ELSE}
ParamVarPtr := TVarData(ParamDesc.Value).VPointer;
if (ParamVarPtr = nil) and (ParamDesc.Value = '') then
ParamVarPtr := PChar(EmptyString);
{$ENDIF}
Marshal.WriteIntPtr(pValue, ParamVarPtr);
if (ParamDesc.GetDataType in CharsByRef) then
if ParamVarPtr <> nil then begin
{$IFDEF CLR}
l := Length(ParamDesc.Value) * SizeOf(WideChar);
{$ELSE}
if ParamVarType = varOleStr then // WideString
l := Integer(StrLenW(ParamVarPtr) * SizeOf(WideChar))
else // Pascal string
l := StrLen(ParamVarPtr)
{$ENDIF}
end
else
l := 0
else
l := Integer(ParamDesc.GetSize);
Marshal.WriteInt32(pLength, l);
end;
end
else
case ParamDesc.GetDataType of
dtUnknown:
SetOleVariant(pValue, ParamDesc.Value);
dtString:
begin
s := ParamDesc.Value;
l := Length(s);
if l > pBind.cbMaxLen - 1{#0} then // Truncate too long values
l := pBind.cbMaxLen - 1{#0};
Marshal.WriteInt32(pLength, l);
if l > 0 then
CopyBufferAnsi(s, pValue, l + 1{#0});
end;
dtWideString:
begin
ws := ParamDesc.Value;
l := Length(ws) * sizeof(WideChar);
if l > (pBind.cbMaxLen - 1{#0}) * sizeof(WideChar) then // Truncate too long values
l := (pBind.cbMaxLen - 1{#0}) * sizeof(WideChar);
Marshal.WriteInt32(pLength, l);
if l > 0 then
CopyBufferUni(ws, pValue, l + 2{#0#0});
end;
dtBytes, dtVarBytes:
begin
case ParamVarType of
varArray + varByte:
begin
{$IFDEF CLR}
b := ParamDesc.Value;
l := Length(b);
if l > pBind.cbMaxLen then // Truncate too long values
l := pBind.cbMaxLen;
Marshal.Copy(b, 0, pValue, l);
{$ELSE}
l := TVarData(ParamDesc.Value).VArray.Bounds[0].ElementCount;
if l > pBind.cbMaxLen then // Truncate too long values
l := pBind.cbMaxLen;
Move(TVarData(ParamDesc.Value).VArray.Data^, pValue^, l);
{$ENDIF}
Marshal.WriteInt32(pLength, l);
end;
varOleStr:
begin
s := ParamDesc.Value;
l := Length(s);
if l > pBind.cbMaxLen {without #0} then // Truncate too long values
l := pBind.cbMaxLen {without #0};
Marshal.WriteInt32(pLength, l);
if l > 0 then
CopyBufferAnsi(s, pValue, l);
end;
else
{$IFDEF LITE}
raise Exception.Create('Unknown BLOB field type (must be varArray + varByte, varOleStr)');
{$ELSE}
raise EDatabaseError.Create('Unknown BLOB field type (must be varArray + varByte, varOleStr)');
{$ENDIF}
end;
end;
dtInt8:
Marshal.WriteInt16(pValue, Byte(ParamDesc.Value));
dtInt16:
Marshal.WriteInt16(pValue, SmallInt(ParamDesc.Value));
dtWord:
if (ServerVersion = 3) and (pBind.wType = DBTYPE_UI1) then
Marshal.WriteByte(pValue, Byte(ParamDesc.Value))
else
Marshal.WriteInt16(pValue, SmallInt(Word(ParamDesc.Value)));
dtInt32:
Marshal.WriteInt32(pValue, Integer(ParamDesc.Value));
dtFloat:
if ServerVersion = 3 then begin
if (pBind.wType = DBTYPE_R4) then
Marshal.WriteInt32(pValue, BitConverter.ToInt32(BitConverter.GetBytes(Single(ParamDesc.Value)), 0))
else
if (pBind.wType = DBTYPE_NUMERIC) then begin
DBNumeric := DoubleToDBNumeric(Double(ParamDesc.Value), pBind.bPrecision, pBind.bScale);
{$IFDEF CLR}
Marshal.StructureToPtr(TObject(DBNumeric), pValue, False);
{$ELSE}
PDBNumeric(pValue)^ := DBNumeric;
{$ENDIF}
end
else
Marshal.WriteInt64(pValue, BitConverter.DoubleToInt64Bits(Double(ParamDesc.Value)));
end
else
Marshal.WriteInt64(pValue, BitConverter.DoubleToInt64Bits(Double(ParamDesc.Value)));
dtCurrency: begin
if (ServerVersion = 3) and (pBind.wType = DBTYPE_CY) then begin
{$IFDEF CLR}
c := ParamDesc.Value;
d := c;
d := d * 10000;
i64 := Convert.ToInt64(d);
Marshal.WriteInt64(pValue, i64);
{$ELSE}
PCurrency(pValue)^ := ParamDesc.Value;
{$ENDIF}
end
else
Marshal.WriteInt64(pValue, BitConverter.DoubleToInt64Bits(Double(ParamDesc.Value)));
// PCurrency(pValue)^ := ParamDesc.Value; Currency type cannot be used over TCurrencyField uses double to store
end;
dtDate:
Marshal.WriteInt64(pValue, BitConverter.DoubleToInt64Bits(TDateTime(ParamDesc.Value)));
dtDateTime, dtTime:
begin
dt := TDateTime(ParamDesc.Value);
DecodeDateTime(dt, AYear, AMonth, ADay, AHour, AMinute, ASecond, AMilliSecond);
DBTimeStamp.year := AYear;
DBTimeStamp.month := AMonth;
DBTimeStamp.day := ADay;
DBTimeStamp.hour := AHour;
DBTimeStamp.minute := AMinute;
DBTimeStamp.second := ASecond;
DBTimeStamp.fraction := AMilliSecond * 1000000 ; // milliseconds to billionths of a second
{$IFDEF CLR}
Marshal.StructureToPtr(TObject(DBTimeStamp), pValue, False);
{$ELSE}
PDBTimeStamp(pValue)^ := DBTimeStamp;
{$ENDIF}
end;
dtBoolean:
Marshal.WriteInt16(pValue, SmallInt(WordBool(Boolean(ParamDesc.Value)))); // Convert to boolean is useful to bypass Delphi bug
dtInt64:
begin
{$IFDEF VER6P}
i64 := ParamDesc.Value; // Explicit Convert!
Marshal.WriteInt64(pValue, i64);
{$ELSE}
if ParamVarType in [$000E, $0014] then
PInt64(pValue)^ := PInt64(@TVarData(ParamDesc.Value).VInteger)^
else
PInt64(pValue)^ := TVarData(ParamDesc.Value).VInteger;
{$ENDIF}
end;
{$IFDEF VER5P}
dtGuid:
{$IFDEF CLR}
Marshal.StructureToPtr(TObject(StringToGUID(ParamDesc.Value)), pValue, False);
{$ELSE}
PGuid(pValue)^ := StringToGUID(ParamDesc.Value);
{$ENDIF}
dtVariant:
SetOleVariant(pValue, ParamDesc.Value);
{$ENDIF}
dtBCD:
if (ServerVersion = 3) then begin
Assert(pBind.wType = DBTYPE_NUMERIC);
DBNumeric := DoubleToDBNumeric(ParamDesc.Value, 0, 0);
{$IFDEF CLR}
Marshal.StructureToPtr(TObject(DBNumeric), pValue, False);
{$ELSE}
PDBNumeric(pValue)^ := DBNumeric;
{$ENDIF}
end
else begin
{$IFNDEF VER6P}
if ParamVarType in [$000E, $0014] then
PCurrency(pValue)^ := PInt64(@TVarData(ParamDesc.Value).VInteger)^
else
{$ENDIF}
begin
c := ParamDesc.Value;
{$IFDEF CLR}
d := c;
d := d * 10000;
i64 := Convert.ToInt64(d);
{$ELSE}
i64 := PInt64(@c)^;
{$ENDIF}
Marshal.WriteInt64(pValue, i64);
end;
end;
{$IFDEF VER6P}
dtFmtBCD:
if (ServerVersion = 3) then begin
Assert(pBind.wType = DBTYPE_NUMERIC);
if VarIsFMTBcd(ParamDesc.Value) then
//Assert(VarIsFMTBcd(ParamDesc.Value));
DBNumeric := BcdToDBNumeric(VarToBcd(ParamDesc.Value))
else begin
s := ParamDesc.Value;
if DecimalSeparator <> '.' then begin
DotPos := Pos(DecimalSeparator, s);
if DotPos <> 0 then
s[DotPos] := '.';
end;
Bcd := StrToBcd(s);
DBNumeric := BcdToDBNumeric(Bcd);
end;
{$IFDEF CLR}
Marshal.StructureToPtr(TObject(DBNumeric), pValue, False);
{$ELSE}
PDBNumeric(pValue)^ := DBNumeric;
{$ENDIF}
end
else
begin
s := ParamDesc.Value;
if DecimalSeparator <> '.' then begin
DotPos := Pos(DecimalSeparator, s);
if DotPos <> 0 then
s[DotPos] := '.';
end;
l := Length(s);
Marshal.WriteInt32(pLength, l);
if l > 0 then
CopyBufferAnsi(s, pValue, l + 1{#0});
end;
{$ENDIF}
dtMemo, dtWideMemo, dtBlob:
if pBind.wType = DBTYPE_IUNKNOWN then begin
// Create stream
OLEDBStream := TOLEDBStream.Create(ParamDesc.GetObject as TBlob, nil{FStreamList});
Stream := OLEDBStream;
Marshal.WriteIntPtr(pValue, Marshal.GetIUnknownForObject(OLEDBStream));
// Set stream size
Marshal.WriteInt32(pLength, Integer(OLEDBStream.Size));
end
else begin
ws := (ParamDesc.GetObject as TBlob).AsWideString;
l := Length(ws) * sizeof(WideChar);
if l > (pBind.cbMaxLen - 1{#0}) * sizeof(WideChar) then // Truncate too long values
l := (pBind.cbMaxLen - 1{#0}) * sizeof(WideChar);
Marshal.WriteInt32(pLength, l);
if l > 0 then
CopyBufferUni(ws, pValue, l + 2{#0#0});
end;
else
Assert(False, Format('ParamDesc - %s, Unknown DataType = %d', [ParamDesc.GetName, ParamDesc.GetDataType]));
end;
end;
end;
end;
procedure TOLEDBCommand.CreateAndFillParamAccs;
var
ParamCnt: integer;
procedure PrepareParamAcc(out BindMemorySize: UINT); // Set preliminary binding data
var
i: integer;
begin
Assert(Length(FParamsAccessorData.rgBindings) <> 0);
for i := 0 to ParamCnt - 1 do
FParamsAccessorData.rgBindings[i].pObject := nil;
BindMemorySize := 0;
for i := 0 to ParamCnt - 1 do
FillBindingForParam(i + 1, TOLEDBParamDesc(FParams[i]), FConnection, FParamsAccessorData.rgBindings[i], BindMemorySize, True, False);
end;
var
{$IFDEF CLR}
rgBindingsGC: GCHandle;
{$ENDIF}
rgBindings: PDBBinding;
rgStatus: PUINT;
i: integer;
BindMemorySize: UINT;
begin
Assert(FICommandText <> nil, 'FICommandText must be setted to CreateAndFillParamAccs');
Assert(not FParamsAccessorDataAvaible, 'procedure CreateAndFillParamAccs already called');
ParamCnt := FParams.Count;
rgStatus := Marshal.AllocHGlobal(ParamCnt * SizeOf(UINT));
{$IFNDEF CLR}
IntPtr(FParamsAccessorData.Accessor) := nil;
{$ENDIF}
FCanReadParams := False;
try
try
FParamsAccessorData.ExecuteParams.HACCESSOR := 0;
FParamsAccessorData.ExecuteParams.pData := nil;
FParamsAccessorData.ExecuteParams.cParamSets := 1;
SetLength(FParamsAccessorData.rgBindings, ParamCnt);
PrepareParamAcc(BindMemorySize);
FParamsAccessorData.ExecuteParams.pData := Marshal.AllocHGlobal(BindMemorySize);
FillChar(FParamsAccessorData.ExecuteParams.pData, BindMemorySize, 0);
for i := 0 to ParamCnt - 1 do
SaveParamValue(FParams[i], FParamsAccessorData.rgBindings[i],
FParamsAccessorData{$IFDEF HAVE_COMPRESS}, FCompressBlob{$ENDIF}
{$IFDEF CLR}, FParamsGC{$ENDIF}, FConnection.DBMSPrimaryVer, FConnection.ProviderPrimaryVer);
QueryIntf(FICommandText, {$IFDEF CLR}IAccessor{$ELSE}IID_IAccessor{$ENDIF}, FParamsAccessorData.Accessor);
{$IFDEF CLR}
rgBindingsGC := GCHandle.Alloc(FParamsAccessorData.rgBindings, GCHandleType.Pinned);
rgBindings := Marshal.UnsafeAddrOfPinnedArrayElement(FParamsAccessorData.rgBindings, 0);
{$ELSE}
rgBindings := @FParamsAccessorData.rgBindings[0];
{$ENDIF}
Check(FParamsAccessorData.Accessor.CreateAccessor(
DBACCESSOR_PARAMETERDATA, ParamCnt, rgBindings, BindMemorySize,
FParamsAccessorData.ExecuteParams.HACCESSOR, rgStatus));
FParamsAccessorDataAvaible := True;
except
if FParamsAccessorData.ExecuteParams.pData <> nil then
Marshal.FreeHGlobal(FParamsAccessorData.ExecuteParams.pData);
FParamsAccessorData.ExecuteParams.pData := nil;
if Length(FParamsAccessorData.rgBindings) <> 0 then begin
for i := 0 to ParamCnt - 1 do
begin
if FParamsAccessorData.rgBindings[i].pObject <> nil then
Marshal.FreeHGlobal(FParamsAccessorData.rgBindings[i].pObject);
end;
SetLength(FParamsAccessorData.rgBindings, 0);
end;
FParamsAccessorDataAvaible := False;
raise;
end;
finally
Marshal.FreeHGlobal(rgStatus);
{$IFDEF CLR}
if IntPtr(rgBindingsGC) <> nil then
rgBindingsGC.Free;
{$ENDIF}
end;
end;
procedure TOLEDBCommand.Execute(Iters: integer = 1);
procedure DoExecute;
var
AsynchComplete: boolean;
function OpenOrExec: IUnknown;
var
Params: DBPARAMS;
RequestInt: TGUID;
hr: HRESULT;
begin
if not GetPrepared then
SetCommandProp;
if FRequestIUnknown or (FNonBlocking and (not FRequestIUnknown)) then
RequestInt := IID_IUnknown
else
RequestInt := IID_NULL;
FWaitForBreak := False;
try
if FRPCCall then
SetParameterInfo;
if FParams.Count = 0 then begin
Params.HACCESSOR := 0;
Params.pData := nil;
Params.cParamSets := 0;
hr := ICommand(FICommandText).Execute(nil, RequestInt, Params, FRowsAffected, Result);
end
else
begin
CreateAndFillParamAccs;
hr := ICommand(FICommandText).Execute(nil, RequestInt, FParamsAccessorData.ExecuteParams, FRowsAffected, Result);
end;
AsynchComplete := True;
if FNonBlocking and (hr = DB_S_ASYNCHRONOUS) then
AsynchComplete := False
else
CheckAndAnalyze(hr);
{$IFDEF SDAC_TEST}
Inc(__ServerExecuteCount);
{$ENDIF}
except
on E: Exception do begin
if (E is EOLEDBError) and (EOLEDBError(E).ErrorCode = DB_E_ABORTLIMITREACHED) then
Unprepare;
Result := nil;
FIUnknown := nil;
ClearIMultipleResults;
FISSAsynchStatus := nil;
raise;
end;
end;
end;
var
IUnk: IUnknown;
begin
Assert(FIUnknown = nil);
FLastExecWarning := False;
if FIMultipleResults = nil then begin
IUnk := OpenOrExec; // After call IUnk may be [nil, IUnknown (message), IUnknown (cursor)]
Assert(FRequestIUnknown or FNonBlocking or (IUnk = nil));
if FRequestIUnknown and (IUnk <> nil) then begin
if FRequestMultipleResults then
QueryIntf(IUnk, {$IFDEF CLR}IMultipleResults{$ELSE}IID_IMultipleResults{$ENDIF}, FIMultipleResults)
else // This is a server cursor or DbxSda call
FIUnknown := IUnk;
IUnk := nil;
end;
if not FRequestIUnknown and FNonBlocking and not AsynchComplete then begin
Assert(IUnk <> nil);
QueryIntf(IUnk, {$IFNDEF CLR}IID_ISSAsynchStatus{$ELSE}ISSAsynchStatus{$ENDIF}, FISSAsynchStatus);
end;
end;
if FRequestIUnknown and (FIMultipleResults <> nil) then
if FIUnknownNext = nil then
GetNextResult(FIUnknown, FRowsAffected)
else
begin
FIUnknown := FIUnknownNext;
FIUnknownNext := nil;
FRowsAffected := FRowsAffectedNext;
end;
end;
begin
if (FCursorState <> csInactive) and (FCursorState <> csPrepared) then
Exit;
FExecuting := True;
SetCursorState(csExecuting);
QueryInterfaces(False); // If QueryInterfaces already called then do nothing
try
DoExecute;
if FNonBlocking and (FISSAsynchStatus <> nil) then begin
Assert(FExecutor = nil);
FExecutor := TOLEDBThreadWrapper.Create(TExecuteThread, True);
FExecutor.OnException := DoExecuteException;
FExecutor.OnTerminate := DoExecuteTerminate;
TExecuteThread(FExecutor.FThread).FRunMethod := WaitAsynchCompletion;
FExecutor.FreeOnTerminate := True;
FExecutor.Resume;
end;
except
on E: Exception do begin
if (not FNonBlocking) or FRequestIUnknown or (FISSAsynchStatus = nil) then
EndExecute(E);
raise;
end;
end;
if (not FNonBlocking) or FRequestIUnknown or (FISSAsynchStatus = nil) then
EndExecute(nil);
end;
procedure TOLEDBCommand.DoExecuteTerminate(Sender: TObject); // MainThread context
begin
EndExecute(FExecutor.FException);
FExecutor := nil;
end;
procedure TOLEDBCommand.DoExecuteException(Sender: TObject; E: Exception; var Fail: boolean); // MainThread context
begin
if (E is EOLEDBError) then
FConnection.DoError(EOLEDBError(E), Fail);
end;
procedure TOLEDBCommand.WaitAsynchCompletion; // FExecuter.FThread context
var
hr: HRESULT;
Completed: boolean;
begin
if (FISSAsynchStatus <> nil) then begin
try
Completed := False;
while not TExecuteThread(FExecutor.FThread).Terminated do begin
hr := FISSAsynchStatus.WaitForAsynchCompletion(100);
Completed := hr <> DB_S_ASYNCHRONOUS;
if Completed then
break;
end;
if not Completed then
FISSAsynchStatus.Abort(DB_NULL_HCHAPTER, DBASYNCHOP_OPEN);
finally
ClearISSAsynchStatus;
end;
end;
end;
procedure TOLEDBCommand.EndExecute(E: Exception); // MainThread context
begin
try
RequestParamsIfPossible;
ReleaseInterfaces;
if FIUnknown = nil then
FCursorState := csInactive
else
FCursorState := csExecuted;
if Assigned(FAfterExecute) then // Must be after RequestParamsIfPossible
FAfterExecute(E = nil);
finally
FExecuting := False;
end;
end;
function TOLEDBCommand.CreateProcCall(Name: string; const NeedDescribe: boolean; const WideStrings: boolean;
const EnableBcd: boolean; const EnableFmtBcd: boolean): string;
procedure DescribeParams(const MasterDatabase: boolean; out OriginalDatabase: string);
var
ParamsMetaInfo: TOLEDBRecordSet;
procedure FillParams;
function GetOffsetByName(const Name: string): integer;
var
i: integer;
begin
for i := 0 to ParamsMetaInfo.Fields.Count - 1 do
if ParamsMetaInfo.Fields[i].Name = Name then begin
Result := ParamsMetaInfo.Fields[i].Offset;
Exit;
end;
Result := - maxint;
Assert(False, 'Unknown field name ' + Name);
end;
var
NameFld, TypeNameFld, TypeFld, HasDefaultFld, DefaultFld, DataTypeFld, OctetLengthFld, CharMaxLenFld: integer; // offsets
Param: TParamDesc;
ParamType: TParamDirection;
s, ParamName: string;
DataType: word;
IsLong: boolean;
RecBuf: IntPtr;
ws: WideString;
dt: integer;
begin
FParams.Clear;
NameFld := GetOffsetByName('PARAMETER_NAME'); // DataSize = 129
TypeNameFld := GetOffsetByName('TYPE_NAME'); // DataSize = 129
TypeFld := GetOffsetByName('PARAMETER_TYPE'); // DataSize = 4
HasDefaultFld := GetOffsetByName('PARAMETER_HASDEFAULT'); // DataSize = 2
DefaultFld := GetOffsetByName('PARAMETER_DEFAULT'); // DataSize = 256
DataTypeFld := GetOffsetByName('DATA_TYPE'); // DataSize = 4
OctetLengthFld := GetOffsetByName('CHARACTER_OCTET_LENGTH'); // DataSize = 4
CharMaxLenFld := GetOffsetByName('CHARACTER_MAXIMUM_LENGTH'); // DataSize = 4
RecBuf := nil;
ParamsMetaInfo.AllocRecBuf(IntPtr(RecBuf));
try
while True do begin
ParamsMetaInfo.GetNextRecord(RecBuf);
if ParamsMetaInfo.Eof then
Break;
IsLong := Marshal.ReadInt32(RecBuf, OctetLengthFld) >= maxInt - 1;
dt := Marshal.ReadInt32(RecBuf, DataTypeFld);
if ConvertOLEDBTypeToInternalFormat(dt, IsLong, EnableBcd, {$IFDEF VER6P}EnableFMTBCD{$ELSE}False{$ENDIF}, WideStrings, True, DataType, FConnection.DBMSPrimaryVer) then begin
ParamType := ConvertOLEDBParamTypeToCR(Marshal.ReadInt32(RecBuf, TypeFld));
Param := TOLEDBParamDesc.Create;
Param.SetParamType(ParamType);
FParams.Add(Param);
//Choice "Bytes" and "VarBytes"
s := Marshal.PtrToStringUni(IntPtr(Integer(RecBuf) + TypeNameFld));
if (DataType = dtBytes) and (s = 'varbinary') then // WAR user-defined types?
DataType := dtVarBytes;
Param.SetDataType(DataType);
ParamName := GetParamNameWODog(Marshal.PtrToStringUni(IntPtr(Integer(RecBuf) + NameFld)));
Param.SetName(ParamName);
if Word(Marshal.ReadInt16(RecBuf, HasDefaultFld)) <> 0 then begin
ws := Marshal.PtrToStringUni(IntPtr(Integer(RecBuf) + DefaultFld));
Param.SetValue(ws);
end;
if IsLargeDataTypeUsed(Param) and
((ParamType = pdOutput) or (ParamType = pdInputOutput)) then
Param.SetParamType(pdInput);
Param.SetSize(Marshal.ReadInt32(RecBuf, CharMaxLenFld));
end
else begin
s := Marshal.PtrToStringUni(IntPtr(Integer(RecBuf) + TypeNameFld));
DatabaseErrorFmt(SBadFieldType, [s, dt]);
end;
end;
finally
if RecBuf <> nil then
ParamsMetaInfo.FreeRecBuf(RecBuf);
end;
end;
procedure ParseFullName(out Database: string; out Owner: string; out ProcName: string);
begin
UnbracketIfPossible(Name, OriginalDatabase, Owner, ProcName);
if OriginalDatabase <> '' then
Database := OriginalDatabase
else
if not MasterDatabase then
Database := FConnection.FDatabase
else
Database := DefaultSDACDatabase;
end;
var
Database, Owner, ProcName: string;
rgRestrictions: TRestrictions;
Rowset: IRowset;
begin
ParseFullName(Database, Owner, ProcName);
SetLength(rgRestrictions, 3);
if (Length(ProcName) > 1) and (ProcName[1] = '#') then // for temporary stored procedures
rgRestrictions[0] := 'tempdb'
else
rgRestrictions[0] := DataBase;
rgRestrictions[1] := Owner;
rgRestrictions[2] := ProcName;
Rowset := FConnection.GetSchemaRowset(DBSCHEMA_PROCEDURE_PARAMETERS, rgRestrictions);
ParamsMetaInfo := nil;
try
ParamsMetaInfo := TOLEDBRecordSet.Create;
ParamsMetaInfo.SetConnection(FConnection);
ParamsMetaInfo.SetProp(prFetchAll, True);
ParamsMetaInfo.SetIRowset(Rowset, False);
ParamsMetaInfo.Open;
FillParams;
finally
if ParamsMetaInfo <> nil then begin
ParamsMetaInfo.Close;
ParamsMetaInfo.UnPrepare;
ParamsMetaInfo.Free;
end;
end;
end;
var
i: integer;
BracketAdded: boolean;
Database, s, s1: string;
ParamName: string;
begin
if FConnection = nil then
DatabaseError(SConnectionNotDefined);
FConnection.Connect('');
if NeedDescribe then begin
DescribeParams(False, Database);
if (FParams.Count = 0) and (Database = '') then begin
s := LowerCase(Copy(Name, 1, 3));
if (s = 'sp_') or (s = 'xp_') then
DescribeParams(True, Database);
end;
end;
i := Pos(';', Name);
if i = 0 then
s := 'CALL ' + BracketIfNeed(Name, Char('"'), Char('"'){May be bug in MS SQL Server}) + ' '
else begin
s := Name;
s1 := Copy(Name, i, 1024);
Delete(s, i, 1024);
s := 'CALL ' + BracketIfNeed(s, Char('"'), Char('"'){May be bug in MS SQL Server}) + s1
end;
BracketAdded := False;
for i := 0 to FParams.Count - 1 do begin
ParamName := FParams[i].GetName;
if ParamName = '' then
ParamName := '?'
else
ParamName := ':' + ParamName;
if FParams[i].GetParamType = pdResult then
s := ParamName + ' = ' + s
else begin
if BracketAdded then
s := s + ', ' + ParamName
else begin
BracketAdded := True;
s := s + '(' + ParamName
end;
end;
end;
if BracketAdded then
s := s + ')';
FSQL := '{' + s + '}';
Result := FSQL;
end;
procedure ConvertStreamToBlob(const pValue: IntPtr; const Length: integer; Blob: TBlob;
{$IFDEF HAVE_COMPRESS}CompressBlobMode: TCompressBlobMode;{$ENDIF} OmitXMLPreamble: boolean = False);
var
Stream: ISequentialStream;
BytesReadedFromStream: Longint;
p, pXML: IntPtr;
Piece: PPieceHeader;
PieceSize: integer;
{$IFDEF CLR}
o: System.Object;
otype: System.Type;
{$ENDIF}
pBytesReadedFromStream: IntPtr;
FirstRead: boolean;
BlobSize: integer;
SizeAvailable: boolean;
begin
p := Marshal.ReadIntPtr(pValue);
Assert(p <> nil);
BlobSize := Length;
SizeAvailable := BlobSize > 0;
{$IFDEF CLR}
otype := System.Type.GetTypeFromCLSID(CLSID_SQLOLEDB);
o := Marshal.GetObjectForIUnknown(p);
Stream := ISequentialStream(Marshal.CreateWrapperOfType(o, otype));
o := nil;
{$ELSE}
IntPtr(Stream) := IntPtr(p);
{$ENDIF}
pBytesReadedFromStream := Marshal.AllocHGlobal(SizeOf(Integer));
try
Assert(Stream <> nil);
if OmitXMLPreamble then begin
// Skip FF FE bytes, CR 16149
pXML := Marshal.AllocHGlobal(SizeOf(WideChar));
try
Stream.Read(pXML, SizeOf(WideChar), pBytesReadedFromStream);
if SizeAvailable then
Dec(BlobSize, SizeOf(WideChar));
finally
Marshal.FreeHGlobal(pXML);
end;
end;
PieceSize := 10 * 1024;
FirstRead := True;
repeat
if (BlobSize >= DefaultPieceSize) or not SizeAvailable then begin
if not FirstRead then
PieceSize := DefaultPieceSize;
end
else
PieceSize := BlobSize;
Blob.AllocPiece(Piece, PieceSize);
try
{$IFDEF CLR}
Stream.Read(IntPtr(Integer(Piece) + SizeOf(TPieceHeader)), PieceSize, pBytesReadedFromStream);
BytesReadedFromStream := Marshal.ReadInt32(pBytesReadedFromStream);
{$ELSE}
Stream.Read(IntPtr(Integer(Piece) + SizeOf(TPieceHeader)), PieceSize, @BytesReadedFromStream);
{$ENDIF}
Piece.Used := BytesReadedFromStream;
if SizeAvailable then
Dec(BlobSize, BytesReadedFromStream);
finally
Blob.CompressPiece(Piece);
if IntPtr(Piece) <> nil then
Blob.AppendPiece(Piece);
FirstRead := False;
end;
until ((BlobSize = 0) and SizeAvailable) or ((PieceSize <> BytesReadedFromStream) and not SizeAvailable);
{$IFDEF HAVE_COMPRESS}
if (Blob is TCompressedBlob) and ((CompressBlobMode = cbClient) or (CompressBlobMode = cbClientServer)) then
TCompressedBlob(Blob).Compressed := True;
{$ENDIF}
finally
{$IFDEF CLR}
Marshal.ReleaseComObject(Stream);
Marshal.Release(p);
{$ENDIF}
Marshal.FreeHGlobal(pBytesReadedFromStream);
end;
end;
procedure TOLEDBCommand.RequestParamsIfPossible; // Call RequestAndFreeParamAccs if interfaces is cleared
procedure RequestAndFreeParamAccs;
procedure ProcessParam(ParamDesc: TParamDesc; var pBind: TDBBinding);
var
pStatus: PDWORD;
Status: DWORD;
pValue: IntPtr;
pLength: PUINT;
l: UINT;
c: Currency;
i64: Int64;
{$IFDEF CLR}
Bcd: TBcd;
b: TBytes;
d: double;
{$ENDIF}
DBTimeStamp: TDBTimeStamp;
dt: TDateTime;
{$IFDEF VER6P}
DBNumeric: TDBNumeric;
{$ENDIF}
Blob: TSharedObject;
begin
if (ParamDesc.GetParamType in [pdUnknown, pdInputOutput, pdOutput, pdResult])
and not ((ParamDesc.GetParamType = pdUnknown) and (ParamDesc.GetDataType in [dtBlob, dtMemo, dtWideMemo, dtMSXML])) then begin
pStatus := PDWORD(UINT(Integer(FParamsAccessorData.ExecuteParams.pData)) + pBind.obStatus);
Status := DWORD(Marshal.ReadInt32(pStatus));
if not IsOutputLOB(ParamDesc, FConnection.DBMSPrimaryVer, FConnection.ProviderPrimaryVer) then
ParamDesc.SetNull((Status = DBSTATUS_S_ISNULL) or (Status = DBSTATUS_E_UNAVAILABLE))
else begin
Blob := ParamDesc.GetObject;
try
ParamDesc.SetNull((Status = DBSTATUS_S_ISNULL) or (Status = DBSTATUS_E_UNAVAILABLE));
finally
ParamDesc.SetObject(Blob);
end;
end;
if ParamDesc.GetNull then
Marshal.WriteInt32(pStatus, Integer(DBSTATUS_S_ISNULL))
else
begin
pValue := IntPtr(UINT(Integer(FParamsAccessorData.ExecuteParams.pData)) + pBind.obValue);
pLength := PUINT(UINT(Integer(FParamsAccessorData.ExecuteParams.pData)) + pBind.obLength);
case ParamDesc.GetDataType of
dtUnknown:
ParamDesc.SetValue(GetOleVariant(pValue));
dtString:
ParamDesc.SetValue(Marshal.PtrToStringAnsi(pValue));
dtWideString:
ParamDesc.SetValue(Marshal.PtrToStringUni(pValue));
dtBytes, dtVarBytes:
begin
l := Marshal.ReadInt32(pLength);
if l > 0 then begin
{$IFDEF CLR}
SetLength(b, l);
Marshal.Copy(pValue, b, 0, l);
ParamDesc.Value := b;
{$ELSE}
ParamDesc.SetValue(VarArrayCreate([0, l - 1], varByte));
CopyBuffer(pValue, TVarData(ParamDesc.Value).VArray.Data, l);
{$ENDIF}
end;
end;
dtInt8:
ParamDesc.SetValue(Byte(Marshal.ReadByte(pValue)));
dtInt16:
ParamDesc.SetValue(SmallInt(Marshal.ReadInt16(pValue)));
dtWord:
ParamDesc.SetValue(Word(Marshal.ReadInt16(pValue)));
dtInt32:
ParamDesc.SetValue(Integer(Marshal.ReadInt32(pValue)));
dtFloat:
ParamDesc.SetValue(BitConverter.Int64BitsToDouble(Marshal.ReadInt64(pValue)));
dtCurrency:
ParamDesc.SetValue(BitConverter.Int64BitsToDouble(Marshal.ReadInt64(pValue)));
// ParamDesc.SetValue(PCurrency(pValue)^); Currency type cannot be used over TCurrencyField uses double to store
dtDate:
ParamDesc.SetValue(TDateTime(BitConverter.Int64BitsToDouble(Marshal.ReadInt64(pValue))));
dtDateTime, dtTime:
begin
{$IFDEF CLR}
DBTimeStamp := TDBTimeStamp(Marshal.PtrToStructure(pValue, TypeOf(TDBTimeStamp)));
{$ELSE}
DBTimeStamp := PDBTimeStamp(pValue)^;
{$ENDIF}
dt := EncodeDateTime(DBTimeStamp.year, DBTimeStamp.month, DBTimeStamp.day, DBTimeStamp.hour, DBTimeStamp.minute, DBTimeStamp.second, DBTimeStamp.fraction div 1000000{Billionths of a second to milliseconds});
ParamDesc.SetValue(dt);
end;
dtBoolean:
ParamDesc.SetValue(Boolean(WordBool(Marshal.ReadInt16(pValue))));
dtInt64:
{$IFDEF VER6P}
ParamDesc.SetValue(Marshal.ReadInt64(pValue));
{$ELSE}
begin
TVarData(_TParamDesc(ParamDesc).FData).VType := $000E;
PInt64(@TVarData(ParamDesc.Value).VInteger)^ := PInt64(pValue)^;
end;
{$ENDIF}
{$IFDEF VER5P}
dtGuid:
{$IFDEF CLR}
ParamDesc.SetValue(GUIDToString(TGuid(Marshal.PtrToStructure(pValue, TypeOf(TGuid)))));
{$ELSE}
ParamDesc.SetValue(GUIDToString(PGuid(pValue)^));
{$ENDIF}
dtVariant:
ParamDesc.SetValue(GetOleVariant(pValue));
{$ENDIF}
dtBCD:
begin
i64 := Marshal.ReadInt64(pValue);
{$IFDEF CLR}
d := i64;
d := d / 10000;
c := d;
{$ELSE}
c := PCurrency(@i64)^;
{$ENDIF}
ParamDesc.SetValue(c);
end;
{$IFDEF VER6P}
dtFmtBCD:
if FConnection.FProvider <> prCompact then
ParamDesc.SetValue(Marshal.PtrToStringAnsi(pValue))
else begin
{$IFDEF CLR}
DBNumeric := TDBNumeric(Marshal.PtrToStructure(pValue, TypeOf(TDBNumeric)));
{$ELSE}
DBNumeric := PDBNumeric(pValue)^;
{$ENDIF}
ParamDesc.SetValue(VarFMTBcdCreate(DBNumericToBcd(DBNumeric)));
end;
{$ENDIF}
dtMemo, dtWideMemo: begin
Blob := ParamDesc.GetObject;
Assert(Blob <> nil);
TBlob(Blob).Clear;
ConvertStreamToBlob(pValue, 0, TBlob(Blob){$IFDEF HAVE_COMPRESS}, FCompressBlob{$ENDIF});
end;
else
Assert(False, Format('ParamDesc - %s, Unknown DataType = %d', [ParamDesc.GetName, ParamDesc.GetDataType]));
end;
end;
end;
end;
var
i: integer;
ParamCnt: integer;
begin
Assert(FIUnknown = nil, 'Before RequestAndFreeParamAccs interface FIUnknown must be released');
Assert(FIMultipleResults = nil, 'Before RequestAndFreeParamAccs interface FIMultipleResults must be released');
if FParamsAccessorDataAvaible then begin
ParamCnt := FParams.Count;
try
if FConnection <> nil then begin
if FParamsAccessorData.ExecuteParams.HACCESSOR <> 0 then
Check(FParamsAccessorData.Accessor.ReleaseAccessor(FParamsAccessorData.ExecuteParams.HACCESSOR, nil));
FParamsAccessorData.ExecuteParams.HACCESSOR := 0;
FParamsAccessorData.Accessor := nil;
for i := 0 to ParamCnt - 1 do
ProcessParam(FParams[i], FParamsAccessorData.rgBindings[i]);
end;
if FParamsAccessorData.ExecuteParams.pData <> nil then
Marshal.FreeHGlobal(FParamsAccessorData.ExecuteParams.pData);
FParamsAccessorData.ExecuteParams.pData := nil;
finally
if Length(FParamsAccessorData.rgBindings) <> 0 then begin
for i := 0 to ParamCnt - 1 do
if FParamsAccessorData.rgBindings[i].pObject <> nil then
Marshal.FreeHGlobal(FParamsAccessorData.rgBindings[i].pObject);
SetLength(FParamsAccessorData.rgBindings, 0);
end;
FParamsAccessorDataAvaible := False;
(*// Remove unused streams
for i := FStreamList.Count - 1 downto 0 do
TOLEDBStream(FStreamList[i])._Release;
Assert(FStreamList.Count = 0);*)
end;
FCanReadParams := True;
if Assigned(FReadParams) and (FConnection <> nil) then
FReadParams;
end;
end;
{$IFDEF CLR}
var
i: integer;
{$ENDIF}
begin
{$IFDEF CLR}
for i := Low(FParamsGC) to High(FParamsGC) do
FreeGCHandle(FParamsGC[i]);
SetLength(FParamsGC, 0);
{$ENDIF}
if (FIUnknown = nil) then begin
if (FIMultipleResults <> nil) and not FNextResultRequested then begin
GetNextResult(FIUnknownNext, FRowsAffectedNext);
FNextResultRequested := True;
end;
if (FIMultipleResults = nil) and (FParams <> nil) and (FParams.Count > 0) then
RequestAndFreeParamAccs;
end;
end;
procedure TOLEDBCommand.CheckAndAnalyze(const Status: HRESULT);
const
ParamHeader = 'Parameter[%d] %s - %s (Status = %Xh).';
var
i: integer;
ParamStatus: DWORD;
ParamName: string;
Msg: WideString;
begin
if Status <> S_OK then
try
Check(Status);
except
on E: Exception do
begin
if (Status and $80000000) <> 0 then begin // Severity bit (see OLEDBC.pas line 5489) is not 0
if Status = DB_E_OBJECTOPEN then
DatabaseError(SObjectOpen)
else
if FParamsAccessorData.ExecuteParams.pData = nil then
raise
else
begin
Msg := '';
with FParamsAccessorData do
for i := 0 to FParams.Count - 1 do begin
ParamName := FParams[i].GetName;
if ParamName = '' then
ParamName := IntToStr(i)
else
ParamName := ':' + ParamName;
ParamStatus := DWORD(Marshal.ReadInt32(ExecuteParams.pData, rgBindings[i].obStatus));
case ParamStatus of
DBSTATUS_S_OK, DBSTATUS_S_ISNULL, DBSTATUS_S_DEFAULT:;
DBSTATUS_E_BADACCESSOR:
AddInfoToErr(Msg, ParamHeader, [i, ParamName, SInvalidParamType, ParamStatus]);
DBSTATUS_E_CANTCONVERTVALUE:
AddInfoToErr(Msg, ParamHeader, [i, ParamName, SInvalidValue, ParamStatus]);
DBSTATUS_S_TRUNCATED:
AddInfoToErr(Msg, ParamHeader, [i, ParamName, SDataTruncated, ParamStatus]);
DBSTATUS_E_SIGNMISMATCH:
AddInfoToErr(Msg, ParamHeader, [i, ParamName, SSignMismatch, ParamStatus]);
DBSTATUS_E_DATAOVERFLOW:
AddInfoToErr(Msg, ParamHeader, [i, ParamName, SDataOverflow, ParamStatus]);
DBSTATUS_E_CANTCREATE:
AddInfoToErr(Msg, ParamHeader, [i, ParamName, SOutOfMemory, ParamStatus]);
DBSTATUS_E_UNAVAILABLE:
{AddInfoToErr(Msg, ParamHeader, [i, ParamName, SUnavaible, ParamStatus])};
DBSTATUS_E_INTEGRITYVIOLATION:
AddInfoToErr(Msg, ParamHeader, [i, ParamName, SIntegrityViolation, ParamStatus]);
DBSTATUS_E_SCHEMAVIOLATION:
AddInfoToErr(Msg, ParamHeader, [i, ParamName, SShemaViolation, ParamStatus]);
DBSTATUS_E_BADSTATUS:
AddInfoToErr(Msg, ParamHeader, [i, ParamName, SBadStatus, ParamStatus]);
else
AddInfoToErr(Msg, ParamHeader, [i, ParamName, SUnknownStatus, ParamStatus]);
end;
end; // for
AddInfoToErr(E, Msg, []);
raise E;
end; // if Status = DB_E_OBJECTOPEN
end
else // if (Status and $80000000) <> 0 then begin
if Status = DB_S_ERRORSOCCURRED then
FLastExecWarning := True;
end; // on E: Exception do begin
end; // try..except..end;
end;
procedure TOLEDBCommand.GetNextResult(out ResultSet: IUnknown; out RowsAffected: integer);
var
hr: HRESULT;
OldRowsAffected: integer;
begin
try
repeat
OldRowsAffected := FRowsAffected;
hr := FIMultipleResults.GetResult(nil, 0, IID_IUnknown, RowsAffected, ResultSet);
if (hr <> DB_S_NORESULT) then
CheckAndAnalyze(hr);
FConnection.OLEDBError(0, Component); // Check Info messages
if ResultSet <> nil then begin
OldRowsAffected := RowsAffected;
Break;
end;
if FWaitForBreak then begin
FWaitForBreak := False;
FConnection.OLEDBError(DB_E_CANCELED, Component);
end;
until hr <> S_OK;
RowsAffected := OldRowsAffected;
finally
if ResultSet = nil then
ClearIMultipleResults; // Rowsets not also provided
end;
end;
procedure TOLEDBCommand.SetConnection(Value: TCRConnection);
begin
if Value <> FConnection then begin
inherited;
FConnection := TOLEDBConnection(Value);
end;
end;
function TOLEDBCommand.GetCursorState: TCursorState;
begin
Result := FCursorState;
end;
procedure TOLEDBCommand.SetCursorState(Value: TCursorState);
begin
FCursorState := Value;
end;
function TOLEDBCommand.GetProp(Prop: integer; var Value: variant): boolean;
begin
Result := True;
case Prop of
prRowsProcessed:
if FRowsAffected = -1 then
Value := 0
else
Value := FRowsAffected;
prScanParams:
Value := False;
prCanReadParams:
Value := FCanReadParams;
prIsSProc:
Value := FIsSProc;
prNonBlocking:
Value := FNonBlocking;
else
Result := inherited GetProp(Prop, Value);
end;
end;
function TOLEDBCommand.SetProp(Prop: integer; const Value: variant): boolean;
begin
Result := True;
case Prop of
prScanParams:;
prCommandTimeout:
FCommandTimeout := Value;
prIsSProc:
FIsSProc := Boolean(Value);
prCanReadParams:
FCanReadParams := Value;
prSmartRefresh:
FSmartRefresh := Value;
prSmartRefreshMsg:
FSmartRefreshMsg := Value;
prSmartRefreshService:
FSmartRefreshService := Value;
prNonBlocking:
FNonBlocking := Value;
else
Result := inherited SetProp(Prop, Value);
end;
end;
function TOLEDBCommand.IUnknownIsNull: boolean;
begin
Result := FIUnknown = nil;
end;
function TOLEDBCommand.IUnknownNextIsNull: boolean;
begin
Result := FIUnknownNext = nil;
end;
function TOLEDBCommand.IMultipleResultsIsNull: boolean;
begin
Result := FIMultipleResults = nil;
end;
function TOLEDBCommand.ISSAsynchStatusIsNull: boolean;
begin
Result := FISSAsynchStatus = nil;
end;
procedure TOLEDBCommand.ClearIUnknown;
begin
FIUnknown := nil;
end;
procedure TOLEDBCommand.ClearIUnknownNext;
begin
FIUnknownNext := nil;
end;
procedure TOLEDBCommand.ClearIMultipleResults;
begin
{$IFDEF CLR}
if FIMultipleResults <> nil then
Marshal.ReleaseComObject(FIMultipleResults);
{$ENDIF}
FIMultipleResults := nil; // Rowsets not also provided
end;
procedure TOLEDBCommand.ClearISSAsynchStatus;
begin
FISSAsynchStatus := nil;
end;
procedure TOLEDBCommand.BreakExec;
begin
if FNonBlocking and not ISSAsynchStatusIsNull then
FExecutor.Terminate
else begin
FBreakExecCS.Acquire;
try
if FICommandText <> nil then
Check(ICommand(FICommandText).Cancel);
FWaitForBreak := True;
finally
FBreakExecCS.Release;
end;
end;
end;
function TOLEDBCommand.GetParamDescType: TParamDescClass;
begin
Result := TOLEDBParamDesc;
end;
function TOLEDBCommand.AddParam: TParamDesc;
begin
Result := TOLEDBParamDesc.Create;
FParams.Add(Result);
end;
function TOLEDBCommand.GetParam(Index: integer): TOLEDBParamDesc;
begin
Result := TOLEDBParamDesc(FParams[Index]);
end;
{ TOLEDBFieldDesc }
function TOLEDBFieldDesc.ActualNameQuoted(RecordSet: TCRRecordSet; const QuoteNames: boolean): string;
begin
if FActualNameQuoted[QuoteNames] <> '' then
Result := FActualNameQuoted[QuoteNames]
else
begin
if FTableInfo <> nil then begin
if QuoteNames then
Result := FTableInfo.Quote(BaseColumnName, LeftQuote, RightQuote)
else
Result := BaseColumnName;
FActualNameQuoted[QuoteNames] := Result;
end
else begin
if QuoteNames then
Result := TOLEDBRecordSet(RecordSet).GetTableInfoClass.Quote(BaseColumnName, LeftQuote, RightQuote)
else
Result := BaseColumnName;
FActualNameQuoted[QuoteNames] := Result;
end;
end;
end;
{ TMSTableInfo }
class function TOLEDBTableInfo.LeftQuote: Char;
begin
Result := {$IFDEF CLR}CoreLab.Sdac.{$ENDIF}OLEDBAccess.LeftQuote;
end;
class function TOLEDBTableInfo.RightQuote: Char;
begin
Result := {$IFDEF CLR}CoreLab.Sdac.{$ENDIF}OLEDBAccess.RightQuote;
end;
{ TOLEDBRecorSet }
constructor TOLEDBRecordSet.Create;
begin
FEnableBCD := False;
FUniqueRecords := False;
FRequestSQLObjects := False;
FCursorUpdate := True;
FCursorTypeChanged := nil;
FLockClearMultipleResults := False;
FroAfterUpdate := False;
FWideStrings := True; // Native fields mapping
inherited;
FNativeRowset := True;
FCursorType := ctDefaultResultSet;
FFetchRows := 25;
end;
destructor TOLEDBRecordSet.Destroy;
begin
Assert((not FNativeRowset) or (FIRowset = nil), 'TOLEDBRecordSet.Destroy - interfaces not released');
inherited;
end;
function TOLEDBRecordSet.GetFieldDescType: TFieldDescClass;
begin
Result := TOLEDBFieldDesc;
end;
procedure TOLEDBRecordSet.ClearHRowIfNeed;
{$IFDEF CLR}
var
rghRows: PUintArray;
GCHandle: IntPtr;
{$ENDIF}
begin
if FHRowAccessible and (FCursorType in ServerCursorTypes) then begin
Assert(FIRowset <> nil, 'TOLEDBRecordSet.ClearHRowIfNeed - FIRowset must be setted');
{$IFDEF CLR}
GCHandle := AllocGCHandle(TObject(FHRow), True);
try
rghRows := GetAddrOfPinnedObject(GCHandle);
Check(FIRowset.ReleaseRows(1, rghRows, nil, nil, nil));
finally
FreeGCHandle(GCHandle);
end;
{$ELSE}
Check(FIRowset.ReleaseRows(1, @FHRow, nil, nil, nil));
{$ENDIF}
FHRow := MaxLongint;
FHRowAccessible := False;
end;
end;
function TOLEDBRecordSet.GetIndicatorSize: word;
begin
Result := FieldCount * OLE_DB_INDICATOR_SIZE;
end;
function TOLEDBRecordSet.IsBlobFieldType(DataType: word): boolean;
begin
Result := inherited IsBlobFieldType(DataType) or (DataType = dtMSXML);
end;
procedure TOLEDBRecordSet.CreateComplexField(RecBuf: IntPtr; FieldIndex: integer; WithBlob: boolean);
var
Blob: TSharedObject;
FieldDesc: TFieldDesc;
begin
FieldDesc := Fields[FieldIndex];
case FieldDesc.DataType of
dtBlob, dtMemo, dtWideMemo, dtMSXML:
if WithBlob then begin
{$IFDEF HAVE_COMPRESS}
if FieldDesc.DataType = dtBlob then
Blob := TCompressedBlob.Create
else
{$ENDIF}
Blob := TBlob.Create;
TBlob(Blob).EnableRollback;
SetObject(FieldIndex + 1, RecBuf, Blob);
end;
else
inherited;
end;
end;
procedure TOLEDBRecordSet.CreateComplexFields(RecBuf: IntPtr; WithBlob: boolean);
var
i: integer;
Blob: TBlob;
Field: TFieldDesc;
begin
inherited;
if WithBlob then
for i := 0 to FieldCount - 1 do begin
Field := Fields[i];
if (Field.FieldDescKind <> fdkCalculated) and (((Field.DataType = dtMemo) or (Field.DataType = dtWideMemo)) and ((Field.SubDataType and dtWide) <> 0)) or (Field.DataType = dtMSXML) then begin
Blob := TBlob(GetGCHandleTarget(Marshal.ReadIntPtr(RecBuf, Field.Offset)));
Blob.IsUnicode := True;
end
end;
end;
procedure TOLEDBRecordSet.FreeComplexFields(RecBuf: IntPtr; WithBlob: boolean);
var
i: integer;
Handle: IntPtr;
so: TSharedObject;
b: boolean;
Field: TFieldDesc;
begin
inherited;
for i := 0 to FieldCount - 1 do begin
Field := Fields[i];
if (Field.FieldDescKind <> fdkCalculated) and (Field.DataType = dtMSXML) and WithBlob then begin
Handle := Marshal.ReadIntPtr(RecBuf, Field.Offset);
so := TSharedObject(GetGCHandleTarget(Handle));
b := (so <> nil) and (so.RefCount = 1);
so.Free;
if b then
Marshal.WriteIntPtr(RecBuf, Field.Offset, nil);
end;
end;
end;
function TOLEDBRecordSet.GetStatus(FieldNo: word; RecBuf: IntPtr): DWORD;
begin
Result := DWORD(Marshal.ReadInt32(RecBuf, DataSize + FieldNo{numeration from 0?} * OLE_DB_INDICATOR_SIZE));
end;
procedure TOLEDBRecordSet.SetStatus(FieldNo: word; RecBuf: IntPtr; Value: DWORD);
begin
Marshal.WriteInt32(RecBuf, DataSize + FieldNo{numeration from 0?} * OLE_DB_INDICATOR_SIZE, Integer(Value));
end;
function TOLEDBRecordSet.GetNull(FieldNo: word; RecBuf: IntPtr): boolean;
begin
Result := GetStatus(FieldNo - 1 {numeration from 1?}, RecBuf) = DBSTATUS_S_ISNULL;
if Result then
Result := GetNullByBlob(FieldNo, RecBuf);
end;
procedure TOLEDBRecordSet.SetNull(FieldNo: word; RecBuf: IntPtr; Value: boolean);
begin
if Value then
SetStatus(FieldNo - 1 {numeration from 1?}, RecBuf, DBSTATUS_S_ISNULL)
else
SetStatus(FieldNo - 1 {numeration from 1?}, RecBuf, DBSTATUS_S_OK);
end;
procedure TOLEDBRecordSet.GetFieldData(Field: TFieldDesc; RecBuf: IntPtr; Dest: IntPtr);
begin
case Field.DataType of
dtString, dtWideString, dtMemo, dtWideMemo, dtMSXML:
begin
if Field.Length = 0 then
CopyBuffer(IntPtr(Integer(RecBuf) + Field.Offset), Dest, sizeof(IntPtr) {ISeqStream})
else
inherited;
end;
dtBlob:
CopyBuffer(IntPtr(Integer(RecBuf) + Field.Offset), Dest, sizeof(TBlob));
dtBCD:
begin
CheckBCDOverflow(Field.FieldNo, RecBuf);
inherited;
end;
else
inherited;
end;
end;
procedure TOLEDBRecordSet.GetFieldAsVariant(FieldNo: word; RecBuf: IntPtr; var Value: variant);
begin
CheckBCDOverflow(FieldNo, RecBuf);
inherited;
end;
procedure TOLEDBRecordSet.PutFieldData(Field: TFieldDesc; RecBuf: IntPtr; Source: IntPtr);
begin
case Field.DataType of
dtString, dtWideString, dtMemo, dtWideMemo, dtMSXML:
begin
if Field.Length = 0 then
CopyBuffer(Source, IntPtr(Integer(RecBuf) + Field.Offset), sizeof(IntPtr) {ISeqStream})
else
inherited;
end;
dtBlob:
CopyBuffer(Source, IntPtr(Integer(RecBuf) + Field.Offset), sizeof(TBlob));
else
inherited;
end;
end;
{ Open/Close }
function TOLEDBRecordSet.NeedInitFields: boolean;
begin
Result := FCommand.FIsSProc and Prepared;
end;
procedure TOLEDBRecordSet.InternalPrepare;
var
ColumnsInfo: IColumnsInfo;
cColumns: UINT;
prgInfo: PDBCOLUMNINFO;
pStringsBuffer: IntPtr;
//Malloc: IMalloc;
begin
QueryCommandInterfaces(True);
try
SetCommandProp;
inherited;
finally
ReleaseCommandInterfaces; /// FCommand.QueryIntCnt counter is increased in inherited
end;
try
// Detect CommandType
if FNativeRowset and not FCommand.FRPCCall then begin
// If statement is wrong in some cases exception may be occured now
QueryIntf(FCommand.FICommandPrepare, {$IFDEF CLR}IColumnsInfo{$ELSE}IID_IColumnsInfo{$ENDIF}, ColumnsInfo);
Assert(ColumnsInfo <> nil);
pStringsBuffer := nil;
try
// If statement is wrong in some cases exception may be occured now
Check(ColumnsInfo.GetColumnInfo(cColumns, PDBCOLUMNINFO(prgInfo), pStringsBuffer));
if cColumns > 0 then
CommandType := ctCursor
else
CommandType := ctStatement;
finally
FreeCoMem(prgInfo);
FreeCoMem(pStringsBuffer);
end;
end;
except
InternalUnPrepare;
raise;
end;
end;
procedure TOLEDBRecordSet.InternalUnPrepare;
begin
try
inherited;
finally
if FNativeRowset then begin
// ReleaseCommandInterfaces;
if not FLockClearMultipleResults then begin
FCommand.ClearIMultipleResults;
FCommand.FIUnknownNext := nil;
end;
FCommand.FIUnknown := nil;
ReleaseRecordSetInterfaces;
end;
CommandType := ctUnknown;
end;
end;
procedure TOLEDBRecordSet.InsertRecord(RecBuf: IntPtr);
procedure AppItem;
var
Block: PBlockHeader;
Item: PItemHeader;
begin
Assert(IntPtr(BlockMan.FirstBlock) = nil);
// Nearly copied from TBlockManager.AddFreeBlock
BlockMan.AllocBlock(Block, 1);
Item := IntPtr(Integer(Block) + sizeof(TBlockHeader));
Item.Prev := nil;
Item.Next := nil;
Item.Block := Block;
Item.Flag := flFree;
BlockMan.FirstFree := Item;
Block.UsedItems := 0;
//------------------
CurrentItem := AppendItem;
end;
var
Appended: boolean;
i: integer;
begin
// ODS(Format('+ TOLEDBRecordSet.InsertRecord FI = %d, CI = %d, LI = %d, BOF = %s, EOF = %s', [Integer(FirstItem), Integer(CurrentItem), Integer(LastItem), BoolToStr(BOF, True), BoolToStr(EOF, True)]));
if (FIRowsetUpdate <> nil) then begin
if IntPtr(CurrentItem) = nil then begin
if IntPtr(FirstItem) <> nil then
CurrentItem := FirstItem
else
if IntPtr(LastItem) <> nil then
CurrentItem := LastItem;
end;
Appended := IntPtr(CurrentItem) = nil;
if Appended then
AppItem
else
if HasComplexFields then
FreeComplexFields(IntPtr(Integer(CurrentItem.Block) + sizeof(TBlockHeader) + sizeof(TItemHeader)), True);
InternalAppend(RecBuf);
PutRecord(RecBuf);
ReorderItems(CurrentItem, roInsert);
if FCursorType = ctKeySet then begin
FirstItem := nil;
CurrentItem := nil;
LastItem := nil;
SetToEnd;
end
else
begin
Assert(FCursorType = ctDynamic);
if HasBlobFields then
for i := 0 to FieldCount - 1 do
if IsBlobFieldType(Fields[i].DataType) then
TBlob(GetObject(Fields[i].FieldNo, RecBuf)).Commit;
FirstItem := nil;
CurrentItem := nil;
LastItem := nil;
FLastFetchBack := False;
SetToEnd;
end;
end
else
if ((FCursorType in ServerCursorTypes) and not FCursorUpdate) then begin
if FRecordCount = 0 then
begin
InternalAppend(RecBuf);
AppItem;
PutRecord(RecBuf);
ReorderItems(CurrentItem, roInsert);
CurrentItem := nil;
// SetToEnd; - no sense for keyset cursors
FBof := False;
{ SetToEnd;
FBof := FirstItem = nil;
FEof := LastItem = nil;}
end
else
begin
InternalAppend(RecBuf);
if HasComplexFields then
FreeComplexFields(RecBuf, True);
SetToEnd;
CurrentItem := LastItem;
FBof := IntPtr(FirstItem) = nil;
FEof := IntPtr(LastItem) = nil;
end;
end
else
inherited;
// ODS(Format('+ TOLEDBRecordSet.InsertRecord FI = %d, CI = %d, LI = %d, BOF = %s, EOF = %s', [Integer(FirstItem), Integer(CurrentItem), Integer(LastItem), BoolToStr(BOF, True), BoolToStr(EOF, True)]));
end;
procedure TOLEDBRecordSet.UpdateRecord(RecBuf: IntPtr);
begin
inherited;
if (FCursorType in ServerCursorTypes) and FroAfterUpdate then
FetchToBookmarkValue;
end;
procedure TOLEDBRecordSet.DeleteRecord;
begin
if (FIRowsetUpdate <> nil)
or ((FCursorType in ServerCursorTypes) and not FCursorUpdate) then begin
InternalDelete;
RemoveRecord;
if FCursorType = ctDynamic then
FRecordCount := - 1;
Fetch;
CurrentItem := FirstItem;
if IntPtr(CurrentItem) = nil then begin
Fetch(True);
CurrentItem := FirstItem;
end;
end
else
inherited;
end;
procedure TOLEDBRecordSet.SetIndexFieldNames(Value: string);
begin
if FCursorType in ServerCursorTypes then
DatabaseError(SLocalSortingServerCursor);
inherited SetIndexFieldNames(Value);
end;
procedure TOLEDBRecordSet.SetToBegin;
begin
case FCursorType of
ctStatic, ctKeyset:
try
FFetchFromBookmark := True;
FBookmarkSize := sizeof(byte);
FBookmarkValue := DBBMK_FIRST;
Fetch;
finally
FFetchFromBookmark := False;
FBookmarkSize := sizeof(FBookmarkValue);
end;
ctDynamic:
while Fetch(True) do;
end;
inherited;
end;
procedure TOLEDBRecordSet.SetToEnd;
begin
if FCursorType in [ctStatic, ctKeyset] then
try
FFetchFromBookmark := True;
FBookmarkSize := sizeof(byte);
FBookmarkValue := DBBMK_LAST;
Fetch;
finally
FFetchFromBookmark := False;
FBookmarkSize := sizeof(FBookmarkValue);
end
else
FetchAll;
inherited;
end;
function TOLEDBRecordSet.FetchToBookmarkValue(FetchBack: boolean = False): boolean; // Fetch to Bookmark. Bookmark value is stored in FBookmarkValue. Bookmark value used only for ctStatic and ctKeyset. For ctDynamic method refetched current record in specified direction
begin
Assert(FCursorType in ServerCursorTypes);
try
FFetchFromBookmark := True;
Result := Fetch(FetchBack);
finally
FFetchFromBookmark := False;
end;
end;
procedure TOLEDBRecordSet.SetToBookmark(Bookmark: PRecBookmark);
begin
if FCursorType in [ctStatic, ctKeyset] then begin
// Cannot optimize - used to RefreshRecord
// if (FBookmarkValue <> Bookmark.Order) or (CurrentItem = nil) then begin
FBookmarkValue := Bookmark.Order;
FetchToBookmarkValue;
end;
inherited;
end;
function TOLEDBRecordSet.CompareBookmarks(Bookmark1, Bookmark2: PRecBookmark): integer;
const
RetCodes: array[Boolean, Boolean] of ShortInt = ((2,-1),(1,0));
begin
if FCursorType in [ctKeyset, ctStatic] then begin
// Copied from TData.CompareBookmarks
Result := RetCodes[IntPtr(Bookmark1) = nil, IntPtr(Bookmark2) = nil];
if Result = 2 then begin
if Bookmark1.Order >= Bookmark2.Order then
if Bookmark1.Order = Bookmark2.Order then
Result := 0
else
Result := 1
else
Result := -1
end;
end
else
Result := inherited CompareBookmarks(Bookmark1, Bookmark2);
end;
function TOLEDBRecordSet.CanFetchBack: boolean;
begin
Result := FCursorType in ServerCursorTypes;
end;
procedure TOLEDBRecordSet.DoFetchTerminate(Sender: TObject); // MainThread context
begin
EndFetchAll(FFetchExecutor.FException);
FFetchExecutor := nil;
end;
procedure TOLEDBRecordSet.DoFetchException(Sender: TObject; E: Exception; var Fail: boolean); // MainThread context
begin
if (E is EOLEDBError) then
FCommand.FConnection.DoError(EOLEDBError(E), Fail);
end;
const
FE_AFTERFETCH = 1;
procedure TOLEDBRecordSet.DoFetchSendEvent(Sender: TObject; Event: TObject);
begin
if Integer(Event) = FE_AFTERFETCH then
DoAfterFetch;
end;
procedure TOLEDBRecordSet.FetchAll;
begin
if (FCommand.GetCursorState < csFetchingAll) or (FCursorType = ctDynamic) then begin
FCommand.SetCursorState(csFetchingAll);
if FCommand.FNonBlocking then begin
FFetchExecutor := TOLEDBThreadWrapper.Create(TExecuteThread, True);
TExecuteThread(FFetchExecutor.FThread).FRunMethod := DoFetchAll;
FFetchExecutor.OnException := DoFetchException;
FFetchExecutor.OnTerminate := DoFetchTerminate;
FFetchExecutor.OnSendEvent := DoFetchSendEvent;
FFetchExecutor.FreeOnTerminate := True;
StringHeap.ThreadSafety := True;
// FFetchExecutor.Resume; // moved to TCustomMSDataSet.SetActive
end
else
DoFetchAll;
end;
end;
procedure TOLEDBRecordSet.DoFetchAll; // FFetchExecutor.FThread context
begin
FFetching := True;
try
while Fetch do
if (FFetchExecutor <> nil) and FWaitForFetchBreak then
Break;
finally
FFetching := False;
end;
end;
procedure TOLEDBRecordSet.EndFetchAll(E: Exception); // MainThread context
begin
if FCommand.FNonBlocking then
StringHeap.ThreadSafety := True;
end;
procedure TOLEDBRecordSet.BreakFetch;
begin
inherited;
if FCommand.FNonBlocking and (FFetchExecutor <> nil) and not FFetchExecutor.Thread.Suspended then
FFetchExecutor.Terminate;
end;
function TOLEDBRecordSet.CanDisconnect: boolean;
begin
Result := inherited CanDisconnect
and (FCommand.FIUnknown = nil)
and (FIRowset = nil)
and (FCommand.FIUnknownNext = nil)
and (FCommand.FIMultipleResults = nil);
end;
function TOLEDBRecordSet.RowsReturn: boolean;
begin
if CommandType <> ctUnknown then
Result := inherited RowsReturn
else //we need to know this info even if CommandType is not set(TCustomDADataSet.DoAfterExecute)
Result := (FCommand.FIUnknown <> nil) or (FIRowset <> nil);
end;
procedure TOLEDBRecordSet.RowsetUpdateCommit;
const
RowHeader = '%s (Status = %Xh).';
var
{$IFDEF CLR}
rghRows: PUintArray;
GCHandle: IntPtr;
{$ENDIF}
pRowStatus: PDBRowStatus;
RowStatus: DBRowStatus;
Msg: WideString;
begin
try
{$IFDEF CLR}
GCHandle := AllocGCHandle(TObject(FHRow), True);
try
rghRows := GetAddrOfPinnedObject(GCHandle);
Check(FIRowsetUpdate.Update(DB_NULL_HCHAPTER, 1, rghRows, nil, nil, pRowStatus));
finally
FreeGCHandle(GCHandle);
end;
{$ELSE}
Check(FIRowsetUpdate.Update(DB_NULL_HCHAPTER, 1, @FHRow, nil, nil, pRowStatus));
{$ENDIF}
except
on e: Exception do begin
if pRowStatus <> nil then begin
Msg := '';
RowStatus := DBRowStatus(Marshal.ReadInt32(pRowStatus));
case RowStatus of
DBROWSTATUS_S_OK:;
DBROWSTATUS_S_MULTIPLECHANGES:
AddInfoToErr(Msg, RowHeader, [SRowMultipleChanges, RowStatus]);
DBROWSTATUS_S_PENDINGCHANGES:
AddInfoToErr(Msg, RowHeader, [SRowPendingChanges, RowStatus]);
DBROWSTATUS_E_CANCELED:
AddInfoToErr(Msg, RowHeader, [SRowCanceled, RowStatus]);
//DBROWSTATUS_E_CANTRELEASE = $00000006;
DBROWSTATUS_E_CONCURRENCYVIOLATION:
AddInfoToErr(Msg, RowHeader, [SRowConcurrencyViolation, RowStatus]);
DBROWSTATUS_E_DELETED:
AddInfoToErr(Msg, RowHeader, [SRowDeleted, RowStatus]);
//DBROWSTATUS_E_PENDINGINSERT = $00000009;
//DBROWSTATUS_E_NEWLYINSERTED = $0000000A;
DBROWSTATUS_E_INTEGRITYVIOLATION:
AddInfoToErr(Msg, RowHeader, [SRowIntegrityViolation, RowStatus]);
DBROWSTATUS_E_INVALID:
Assert(False);
//DBROWSTATUS_E_MAXPENDCHANGESEXCEEDED = $0000000D;
//DBROWSTATUS_E_OBJECTOPEN = $0000000E;
//DBROWSTATUS_E_OUTOFMEMORY = $0000000F;
DBROWSTATUS_E_PERMISSIONDENIED:
AddInfoToErr(Msg, RowHeader, [SRowPermissionDenied, RowStatus]);
DBROWSTATUS_E_LIMITREACHED:
AddInfoToErr(Msg, RowHeader, [SRowLimitReached, RowStatus]);
DBROWSTATUS_E_SCHEMAVIOLATION:
AddInfoToErr(Msg, RowHeader, [SRowSchemaViolation, RowStatus]);
DBROWSTATUS_E_FAIL:
AddInfoToErr(Msg, RowHeader, [SRowFail, RowStatus]);
else
AddInfoToErr(Msg, RowHeader, [SUnknownStatus, RowStatus]);
end;
FreeCoMem(pRowStatus);
AddInfoToErr(E, Msg, []);
end;
// -----
RowsetUpdateRollback;
// -----}
raise E;
end;
end;
end;
procedure TOLEDBRecordSet.RowsetUpdateRollback;
{$IFDEF CLR}
var
rghRows: PUintArray;
GCHandle: IntPtr;
{$ENDIF}
begin
{$IFDEF CLR}
GCHandle := AllocGCHandle(TObject(FHRow), True);
try
rghRows := GetAddrOfPinnedObject(GCHandle);
Check(FIRowsetUpdate.Undo(0, 1, rghRows, nil, nil, nil));
finally
FreeGCHandle(GCHandle);
end;
{$ELSE}
Check(FIRowsetUpdate.Undo(0, 1, @FHRow, nil, nil, nil));
{$ENDIF}
//Assert(cRows = 1);
{ Check(FIRowsetUpdate.GetRowStatus(0, 1, @FHRow, @pRowStatus));
FHRowAccessible := True; ClearHRowIfNeed;
Check(FIRowsetUpdate.GetRowStatus(0, 1, @FHRow, @pRowStatus));
FHRowAccessible := True; ClearHRowIfNeed;
//Check(FIRowsetUpdate.GetRowStatus(0, 1, @FHRow, @pRowStatus));
}
end;
procedure TOLEDBRecordSet.InternalAppend(RecBuf: IntPtr);
begin
if (FIRowsetUpdate <> nil) then begin
ClearHRowIfNeed;
InternalAppendOrUpdate(RecBuf, True);
end
else
inherited;
if FCursorType = ctKeySet then
Inc(FRecordCount);
end;
procedure TOLEDBRecordSet.InternalDelete;
var
hr: HResult;
{$IFDEF CLR}
rghRows: PUintArray;
GCHandle: IntPtr;
{$ENDIF}
begin
if FIRowsetUpdate = nil then
inherited
else
begin
Assert(FIRowsetUpdate <> nil, 'FCommand.FIRowsetUpdate must be setted');
Assert(FHRowAccessible, 'FHRow must be accessible');
{$IFDEF CLR}
GCHandle := AllocGCHandle(TObject(FHRow), True);
try
rghRows := GetAddrOfPinnedObject(GCHandle);
hr := IRowsetChange(FIRowsetUpdate).DeleteRows(0, 1, rghRows, nil);
finally
FreeGCHandle(GCHandle);
end;
{$ELSE}
hr := FIRowsetUpdate.DeleteRows(0, 1, @FHRow, nil);
{$ENDIF}
Check(hr);
RowsetUpdateCommit;
end;
end;
procedure TOLEDBRecordSet.InternalUpdate(RecBuf: IntPtr);
begin
if FIRowsetUpdate = nil then
inherited
else
begin
Assert(FHRowAccessible, 'FHRow must be accessible');
InternalAppendOrUpdate(RecBuf, False);
end;
end;
procedure TOLEDBRecordSet.InternalAppendOrUpdate(RecBuf: IntPtr; const IsAppend: boolean);
var
StreamList: TList;
procedure SetDataToRow(const Row: hRow; const pRec: IntPtr);
procedure PrepareConvertableFields; // Server Cursors. Before send data to OLEDB
var
i: integer;
pValue: IntPtr;
HeapBuf: IntPtr;
Size: integer;
Field: TFieldDesc;
{$IFDEF VER5P}
g: TGUID;
{$ENDIF}
{$IFDEF VER6P}
Bcd: TBcd;
s: string;
DotPos, l: integer;
{$ENDIF}
{$IFDEF CLR}
BcdBuf: TBytes;
{$ENDIF}
begin
{$IFDEF VER8}
SetLength(BcdBuf, 0); // To avoid compiler warning. Delphi8 bug.
{$ENDIF}
for i := 0 to Fields.Count - 1 do begin
Field := Fields[i];
if Field.FieldDescKind = fdkData then begin
pValue := IntPtr(Integer(pRec) + Field.Offset);
case Field.DataType of
dtBytes:
Marshal.WriteInt32(pValue, Field.Length, Field.Length);
dtVarBytes:
Marshal.WriteInt32(pValue, sizeof(word) + Field.Length, Marshal.ReadInt16(pRec, Field.Offset));
dtExtVarBytes:
if not GetNull(i + 1, pRec) then
begin
HeapBuf := Marshal.ReadIntPtr(pValue); //HeapBuf := IntPtr(IntPtr(pValue)^);
Size := Marshal.ReadInt16(HeapBuf);
Marshal.WriteInt32(pValue, sizeof(IntPtr {IntPtr to OLEDBBuf/StringHeap}), Size);
Marshal.WriteIntPtr(pValue, IntPtr(Integer(HeapBuf) + sizeof(word)));
end;
{$IFDEF VER6P}
dtFmtBCD:
begin
{$IFDEF CLR}
Marshal.Copy(pValue, BcdBuf, 0, 34);
Bcd := TBcd.FromBytes(BcdBuf);
{$ELSE}
Bcd := PBcd(pValue)^;
{$ENDIF}
// DBNumeric
s := BcdToStr(Bcd);
if DecimalSeparator <> '.' then begin
DotPos := Pos(DecimalSeparator, s);
if DotPos <> 0 then
s[DotPos] := '.';
end;
l := Length(s);
// Marshal.WriteInt32(pLength, l);
if l > 0 then
CopyBufferAnsi(s, pValue, l + 1{#0});
end;
{$ENDIF}
{$IFDEF VER5P}
dtGuid:
if not GetNull(i + 1, pRec) then
begin
g := StringToGUID(Marshal.PtrToStringAnsi(pValue));
{$IFDEF CLR}
Marshal.StructureToPtr(TObject(g), pValue, False);
{$ELSE}
CopyBuffer(@g, pValue, sizeof(g));
{$ENDIF}
end;
{$ENDIF}
end;
end;
end;
end;
procedure PostPlainAccessorBlock(
const AccessorBlock: TAccessorBlock;
out NeedToPost: boolean // Used to skip unchanged BLOB fields
);
procedure ConvertBlobToStream(BlobField: TFieldDesc; const pValue: IntPtr);
var
OLEDBStream: TOLEDBStream;
Blob: TBlob;
pUnk: IntPtr;
begin
Blob := TBlob(GetGCHandleTarget(Marshal.ReadIntPtr(pValue)));
// Assert(FCursorType in [ctKeyset, ctDynamic] and FCursorUpdate);
NeedToPost := Blob.CanRollback;
if NeedToPost then begin
// Create stream
OLEDBStream := TOLEDBStream.Create(Blob, StreamList);
pUnk := Marshal.GetIUnknownForObject(OLEDBStream);
Marshal.AddRef(pUnk);
Marshal.WriteIntPtr(pValue, pUnk);
// Set stream size
Marshal.WriteInt32(pRec, BlobField.Offset + sizeof(IntPtr{ISeqStream}), OLEDBStream.Size);
end;
end;
var
pValue: IntPtr;
BlobField: TFieldDesc;
begin
NeedToPost := True;
if AccessorBlock.BlobFieldNum = -1 then
Exit;
BlobField := Fields[AccessorBlock.BlobFieldNum];
pValue := IntPtr(Integer(pRec) + BlobField.Offset);
if not GetNull(AccessorBlock.BlobFieldNum + 1, pRec) then
ConvertBlobToStream(BlobField, pValue);
end;
var
FetchBlockOffset: integer;
procedure PostExternalAccessorBlock(const AccessorBlock: TAccessorBlock);
var
i, l, p: integer;
Blob: TSharedObject;
pValue, pc: IntPtr;
pov: POleVariant;
Field: TFieldDesc;
FieldNum: integer;
ServerVersion: integer;
begin
Assert(AccessorBlock.BlobFieldNum = - 1);
ServerVersion := ProviderPrimaryVer;
for i := 0 to Length(AccessorBlock.FieldNums) - 1 do begin
FieldNum := AccessorBlock.FieldNums[i];
Field := Fields[FieldNum];
if IsNeedFetchBlock(Field, ServerVersion) then begin
pValue := IntPtr(Integer(pRec) + Field.Offset);
case Field.DataType of
dtMemo, dtWideMemo, dtMSXML: begin
Blob := TSharedObject(GetGCHandleTarget(Marshal.ReadIntPtr(pValue)));
pc := IntPtr(Integer(FFetchBlock) + FetchBlockOffset + OLE_DB_INDICATOR_SIZE);
p := 0;
if not GetNull(FieldNum + 1, pRec) then begin
l := TBlob(Blob).Size;
if l > MaxNonBlobFieldLen then // see IncFetchBlockOffset
l := MaxNonBlobFieldLen;
if l > 0 then
p := TBlob(Blob).Read(0, l, pc);
end;
Marshal.WriteByte(pc, p, 0{#0});
if TBlob(Blob).IsUnicode then
Marshal.WriteByte(pc, p + 1, 0{#0});
end;
dtVariant: begin
Blob := TSharedObject(GetGCHandleTarget(Marshal.ReadIntPtr(pValue)));
pov := POleVariant(Integer(FFetchBlock) + FetchBlockOffset + OLE_DB_INDICATOR_SIZE);
Marshal.WriteInt16(pov, varEmpty); // TVarData(pov^).VType := varEmpty;
SetOleVariant(pov, TVariantObject(Blob).Value);
end;
else
Assert(False);
end;
IncFetchBlockOffset(FetchBlockOffset, Field.DataType);
end;
end;
end;
procedure CopyStatusFBlock(const ToFBlock: boolean); // if ToFBlock is True then status is copied from pRec to FetchBlock. Otherwise - from FetchBlock to pRec
var
i: integer;
FetchBlockOffset: integer;
Status: DWORD;
begin
FetchBlockOffset := 0;
for i := 0 to Fields.Count - 1 do
if (Fields[i].FieldDescKind = fdkData) and IsNeedFetchBlock(Fields[i], ProviderPrimaryVer) then begin
if ToFBlock then begin
Status := GetStatus(i, pRec);
Marshal.WriteInt32(FFetchBlock, FetchBlockOffset, Integer(Status));
end
else
begin
Status := DWORD(Marshal.ReadInt32(FFetchBlock, FetchBlockOffset));
SetStatus(i, pRec, Status);
end;
IncFetchBlockOffset(FetchBlockOffset, Fields[i].DataType);
end;
end;
var
AccNum: integer;
hr: HResult;
NeedToPost: boolean;
begin
PrepareConvertableFields;
FetchBlockOffset := 0;
try
for AccNum := 0 to Length(FFetchAccessorData.AccessorBlocks) - 1 do begin
Assert(Length(FFetchAccessorData.AccessorBlocks[AccNum].FieldNums) = 1); // CR 4082
if not IsAppend // Edit
or not GetNull(FFetchAccessorData.AccessorBlocks[AccNum].FieldNums[0] + 1, pRec)
or (FFetchAccessorData.AccessorBlocks[AccNum].BlockType = abBlob) then begin
case FFetchAccessorData.AccessorBlocks[AccNum].BlockType of
abFetchBlock: begin
// Prepare data
CopyStatusFBlock(True);
PostExternalAccessorBlock(FFetchAccessorData.AccessorBlocks[AccNum]);
// Set data to IRowset
if FHRowAccessible then
hr := FIRowsetUpdate.SetData(FHRow, FFetchAccessorData.AccessorBlocks[AccNum].hAcc, FFetchBlock)
else
hr := FIRowsetUpdate.InsertRow(0, FFetchAccessorData.AccessorBlocks[AccNum].hAcc, FFetchBlock, FHRow);
CopyStatusFBlock(False);
// Analyze OLE DB result
CheckAndAnalyzeFieldsStatus(hr, pRec);
FHRowAccessible := True;
end;
abOrdinary, abBLOB: begin
// Prepare data
PostPlainAccessorBlock(FFetchAccessorData.AccessorBlocks[AccNum], NeedToPost);
if NeedToPost then begin
// Set data to IRowset
if FHRowAccessible then
hr := FIRowsetUpdate.SetData(FHRow, FFetchAccessorData.AccessorBlocks[AccNum].hAcc, pRec)
else
hr := FIRowsetUpdate.InsertRow(0, FFetchAccessorData.AccessorBlocks[AccNum].hAcc, pRec, FHRow);
// Analyze OLE DB result
CheckAndAnalyzeFieldsStatus(hr, pRec);
FHRowAccessible := True;
end;
end;
abReadOnly:;
end;
end;
end;
except
if FHRowAccessible then
RowsetUpdateRollback;
raise;
end;
if FHRowAccessible then
RowsetUpdateCommit;
end;
var
pRec, pRecOld: IntPtr;
i: integer;
OLEDBStream: TOLEDBStream;
begin
Assert(FIRowsetUpdate <> nil, 'FCommand.FIRowsetUpdate must be setted');
StreamList := nil;
pRecOld := RecBuf;
/// Store old values to prevent conversion. Blob fields is not stored
pRec := Marshal.AllocHGlobal(RecordSize);
try
StreamList := TList.Create;
CopyBuffer(pRecOld, pRec, RecordSize);
SetDataToRow(FHRow, pRec);
finally
Marshal.FreeHGlobal(pRec);
// Remove streams
for i := StreamList.Count - 1 downto 0 do begin
OLEDBStream := TOLEDBStream(StreamList[i]);
{$IFDEF CLR}
OLEDBStream.Free;
{$ELSE}
OLEDBStream._Release;
{$ENDIF}
if GUIDToString(ProviderId) = GUIDToString(CLSID_SQLNCLI) then
OLEDBStream.FStreamList := nil;
end;
Assert((StreamList.Count = 0) or (GUIDToString(ProviderId) = GUIDToString(CLSID_SQLNCLI)), 'StreamList.Count = ' + IntToStr(StreamList.Count));
StreamList.Free;
end;
end;
procedure TOLEDBRecordSet.SetCommandProp;
var
OLEDBProperties: TOLEDBPropertiesSet;
IRowsetUpdateRequired: boolean;
IsSQLEverywhere: boolean;
begin
{$IFDEF SDAC_TEST}
Inc(__SetRecordSetCommandPropCount);
{$ENDIF}
Assert(FNativeRowset, 'FNativeRowset must be True');
Assert(FCommand.FIMultipleResults = nil, 'FCommand.FIMultipleResults must be nil');
IsSQLEverywhere := Provider = prCompact;
if FCursorType in ServerCursorTypes then begin
// Server cursor has no sence in disconnected mode
if DisconnectedMode then
DatabaseError(SDMandServerCursors);
FFetchRows := 1; /// !!!
FFetchAll := False;
FCommand.FRequestMultipleResults := False;
end
else
FCommand.FRequestMultipleResults := not IsSQLEverywhere;
IRowsetUpdateRequired := (ProviderPrimaryVer = 7);
OLEDBProperties := TOLEDBPropertiesSet.Create(FCommand.FConnection, DBPROPSET_ROWSET);
try
with OLEDBProperties do begin
// AddPropInt(DBPROP_ACCESSORDER, DBPROPVAL_AO_SEQUENTIALSTORAGEOBJECTS); - no performance improvement
AddPropInt(DBPROP_ACCESSORDER, DBPROPVAL_AO_RANDOM);
case FCursorType of
ctDefaultResultSet:
begin
if not IsSQLEverywhere then
AddPropBool(DBPROP_UNIQUEROWS, FUniqueRecords or not FReadOnly);
AddPropBool(DBPROP_IColumnsRowset, FRequestSQLObjects);
if not IsSQLEverywhere then begin
AddPropBool(DBPROP_IMultipleResults, FCommand.FRequestMultipleResults);
AddPropBool(DBPROP_SERVERCURSOR, False);
end;
AddPropBool(DBPROP_OWNINSERT, False);
AddPropBool(DBPROP_OTHERINSERT, False);
AddPropBool(DBPROP_OTHERUPDATEDELETE, False);
AddPropBool(DBPROP_OWNUPDATEDELETE, False);
AddPropBool(DBPROP_IRowsetChange, False);
AddPropBool(DBPROP_IRowsetUpdate, False);
end;
ctStatic:
begin
{Static RO}
AddPropBool(DBPROP_SERVERCURSOR, True);
AddPropBool(DBPROP_IRowsetChange, False);
AddPropBool(DBPROP_IRowsetUpdate, False);
AddPropBool(DBPROP_OWNINSERT, False);
AddPropBool(DBPROP_OTHERINSERT, False);
AddPropBool(DBPROP_OTHERUPDATEDELETE, False);
AddPropBool(DBPROP_OWNUPDATEDELETE, False);
AddPropBool(DBPROP_REMOVEDELETED, False);
AddPropBool(DBPROP_IRowsetResynch, False);
AddPropBool(DBPROP_CHANGEINSERTEDROWS, False);
AddPropBool(DBPROP_SERVERDATAONINSERT, False);
AddPropBool(DBPROP_UNIQUEROWS, False);
AddPropBool(DBPROP_CANFETCHBACKWARDS, not FUniDirectional);
// Bookmarks
AddPropBool(DBPROP_IRowsetLocate, True);
AddPropBool(DBPROP_BOOKMARKS, True);
end;
ctKeyset:
begin
{Keyset}
AddPropBool(DBPROP_SERVERCURSOR, True);
AddPropBool(DBPROP_OTHERINSERT, False);
AddPropBool(DBPROP_OTHERUPDATEDELETE, True);
AddPropBool(DBPROP_OWNINSERT, True);
AddPropBool(DBPROP_OWNUPDATEDELETE, True);
AddPropBool(DBPROP_UNIQUEROWS, False);
AddPropBool(DBPROP_IMMOBILEROWS, True);
AddPropBool(DBPROP_CANFETCHBACKWARDS, not FUniDirectional);
// Bookmarks
AddPropBool(DBPROP_IRowsetLocate, True);
AddPropBool(DBPROP_BOOKMARKS, True);
AddPropBool(DBPROP_REMOVEDELETED, True);
// RO or RW cursor
AddPropBool(DBPROP_IRowsetUpdate, not FReadOnly and FCursorUpdate, IRowsetUpdateRequired);
AddPropBool(DBPROP_CHANGEINSERTEDROWS, True);
// Transactions support
AddPropBool(DBPROP_COMMITPRESERVE, True);
AddPropBool(DBPROP_ABORTPRESERVE, True);
end;
ctDynamic:
begin
{Dynamic}
AddPropBool(DBPROP_SERVERCURSOR, True);
AddPropBool(DBPROP_OTHERINSERT, True);
AddPropBool(DBPROP_OTHERUPDATEDELETE, True);
AddPropBool(DBPROP_OWNINSERT, True);
AddPropBool(DBPROP_OWNUPDATEDELETE, True);
AddPropBool(DBPROP_UNIQUEROWS, False);
AddPropBool(DBPROP_IMMOBILEROWS, False);
AddPropBool(DBPROP_CANFETCHBACKWARDS, not FUniDirectional);
// Bookmarks
AddPropBool(DBPROP_IRowsetLocate, False);
AddPropBool(DBPROP_BOOKMARKS, False);
AddPropBool(DBPROP_REMOVEDELETED, True);
// RO or RW cursor
AddPropBool(DBPROP_IRowsetUpdate, not FReadOnly and FCursorUpdate, IRowsetUpdateRequired);
AddPropBool(DBPROP_CHANGEINSERTEDROWS, False);
AddPropBool(DBPROP_IRowsetScroll, False);
AddPropBool(DBPROP_CANHOLDROWS, False);
AddPropBool(DBPROP_LITERALBOOKMARKS, False);
AddPropBool(DBPROP_SERVERDATAONINSERT, False);
// Transactions support
AddPropBool(DBPROP_COMMITPRESERVE, True);
AddPropBool(DBPROP_ABORTPRESERVE, True);
end;
end;
end;
OLEDBProperties.SetProperties(FCommand.FICommandProperties);
finally
OLEDBProperties.Free;
end;
end;
procedure TOLEDBRecordSet.QueryCommandInterfaces(const QueryPrepare: boolean); // Create ConnectionSwap if need. Call FCommand.QueryInterfaces.
begin
FCommand.QueryInterfaces(QueryPrepare);
end;
procedure TOLEDBRecordSet.ReleaseCommandInterfaces;
begin
FCommand.ReleaseInterfaces;
end;
procedure TOLEDBRecordSet.QueryRecordSetInterfaces;
{ procedure GetProperties;
const
PropSetCnt = 1;
PropCnt = 12;
var
RowsetInfo: IRowsetInfo;
rgPropertyIDSets: PDBPropIDSetArray;
DBPropIDArray: array[0..PropCnt - 1] of DBPROPID;
rgPropertySets: PDBPropSet;
cPropertySets: UINT;
b: boolean;
i: integer;
st: DBPROPSTATUS;
begin
FIRowset.QueryInterface(IID_IRowsetInfo, RowsetInfo);
DBPropIDArray[0] := DBPROP_SERVERCURSOR;
DBPropIDArray[1] := DBPROP_IRowsetChange;
DBPropIDArray[2] := DBPROP_IRowsetUpdate;
DBPropIDArray[3] := DBPROP_OWNINSERT;
DBPropIDArray[4] := DBPROP_OTHERINSERT;
DBPropIDArray[5] := DBPROP_OTHERUPDATEDELETE;
DBPropIDArray[6] := DBPROP_OWNUPDATEDELETE;
DBPropIDArray[7] := DBPROP_REMOVEDELETED;
DBPropIDArray[8] := DBPROP_IRowsetResynch;
DBPropIDArray[9] := DBPROP_CHANGEINSERTEDROWS;
DBPropIDArray[10] := DBPROP_SERVERDATAONINSERT;
DBPropIDArray[11] := DBPROP_UNIQUEROWS;
GetMem1(rgPropertyIDSets, PropSetCnt * sizeof(DBPropIDSet));
try
rgPropertyIDSets[0].guidPropertySet := DBPROPSET_ROWSET;
rgPropertyIDSets[0].cPropertyIDs := PropCnt;
rgPropertyIDSets[0].rgPropertyIDs := @DBPropIDArray;
Check(RowsetInfo.GetProperties(PropSetCnt, rgPropertyIDSets,
cPropertySets, PDBPropSet(rgPropertySets)));
Assert(rgPropertySets <> nil, 'Cannot get properties');
for i := 0 to PropCnt - 1 do
begin
b := rgPropertySets.rgProperties[i].vValue;
st := rgPropertySets.rgProperties[i].dwStatus;
b := not b;
end;
finally
FreeMem1(rgPropertyIDSets);
FCommand.FConnection.Malloc.Free(rgPropertySets.rgProperties);
FCommand.FConnection.Malloc.Free(rgPropertySets);
end;
end;
}
begin
try
if FNativeRowset then begin
Assert(FIRowset = nil, 'Duplicate call to TOLEDBRecordSet.QueryRecordSetInterfaces');
Assert(FCommand.FIUnknown <> nil, 'FCommand.FIUnknown must be setted');
QueryIntf(FCommand.FIUnknown, {$IFDEF CLR}IRowset{$ELSE}IID_IRowset{$ENDIF}, FIRowset);
if FCursorType in [ctKeyset, ctStatic] then begin
QueryIntf(FIRowset, {$IFDEF CLR}IRowsetLocate{$ELSE}IID_IRowsetLocate{$ENDIF}, FIRowsetLocate);
Assert(FIRowsetLocate <> nil);
end;
{if (FCursorType in [ctKeyset, ctDynamic]) then
GetProperties;}
if (FCursorType in [ctKeyset, ctDynamic])
and not FReadOnly
and FCursorUpdate then
QueryIntf(FIRowset, {$IFDEF CLR}IRowsetUpdate{$ELSE}IID_IRowsetUpdate{$ENDIF}, FIRowsetUpdate);
FCommand.FIUnknown := nil;
end;
except
ReleaseRecordSetInterfaces;
end;
end;
procedure TOLEDBRecordSet.ReleaseRecordSetInterfaces;
begin
FIRowsetUpdate := nil;
FIRowset := nil;
FIRowsetLocate := nil;
if FNativeRowset then
RequestParamsIfPossible;
end;
procedure TOLEDBRecordSet.ReleaseAllInterfaces(const ReleaseMultipleResults: boolean);
begin
FreeFetchBlock;
FCommand.FIUnknown := nil;
ReleaseRecordSetInterfaces;
end;
procedure TOLEDBRecordSet.InternalOpen;
begin
FLastFetchBack := False;
FLastFetchOK := True;
FLastFetchEnd := False;
FHRowAccessible := False;
if FCursorType = ctDynamic then
FRecordCount := - 1;
FProcessDynBofEof := False;
try
if FNativeRowset then
QueryCommandInterfaces(False); // If QueryInterfaces already called then do nothing. Need to prevent clear FICommandText & FICommandProperties after command.execute before CreateFieldDescByRowset
inherited;
except
if FNativeRowset then
ReleaseCommandInterfaces;
if FCommand.GetCursorState = csFetched then
FCommand.SetCursorState(csInactive);
raise;
end;
end;
procedure TOLEDBRecordSet.InternalClose;
begin
if FCommand.FNonBlocking and (FFetchExecutor <> nil) then
BreakFetch;
ClearHRowIfNeed;
FreeFetchBlock;
if FNativeRowset then begin
if not FLockClearMultipleResults then begin
FCommand.ClearIMultipleResults;
FCommand.FIUnknownNext := nil;
end;
FCommand.FIUnknown := nil;
RequestParamsIfPossible;
end;
if FIRowset <> nil then // If FIRowset is not closed on Fetch by any reason
ReleaseRecordSetInterfaces;
FreeData; // To destroy Blobs
if Assigned(FAfterExecFetch) then
FAfterExecFetch(True);
if FNativeRowset then
ReleaseCommandInterfaces;
FCommand.FCursorState := csInactive;
if not Prepared then
CommandType := ctUnknown;
FCommand.FNextResultRequested := False;
FLastFetchEnd := False;
inherited;
end;
procedure TOLEDBRecordSet.ExecCommand;
procedure ProcessCursorType;// Analyze CursorType changes
var
ActualCursorType: TMSCursorType; // Cursor type after OLEDB execute.
ActualSCReadOnly: boolean; // ReadOnly after OLEDB execute. Only for server cursors and CursorUpdate = True
procedure AnalyzeCursorType; // Analyzed by FCommand.FIUnknown
var
RowsetInfo: IRowsetInfo;
PropValues: TPropValues;
begin
with TOLEDBPropertiesGet.Create(FCommand.FConnection, DBPROPSET_ROWSET) do
try
AddPropId(DBPROP_SERVERCURSOR);
AddPropId(DBPROP_OTHERUPDATEDELETE);
AddPropId(DBPROP_IRowsetLocate);
AddPropId(DBPROP_IRowsetUpdate);
// Getting info interface
if FCommand.FIUnknown <> nil then begin
QueryIntf(FCommand.FIUnknown, {$IFDEF CLR}IRowsetInfo{$ELSE}IID_IRowsetInfo{$ENDIF}, RowsetInfo);
GetProperties(RowsetInfo, PropValues);
end
else
begin
Assert(FCommand.FICommandProperties <> nil);
GetProperties(FCommand.FICommandProperties, PropValues);
end;
finally
Free;
end;
if {DBPROP_SERVERCURSOR} PropValues[0] = False then
ActualCursorType := ctDefaultResultSet
else
begin // Static, KeySet, Dynamic
if {DBPROP_OTHERUPDATEDELETE} PropValues[1] = False then begin // Static
ActualCursorType := ctStatic;
ActualSCReadOnly := True;
end
else
begin // KeySet, Dynamic
if {DBPROP_IRowsetLocate} PropValues[2] = False then // Dynamic
ActualCursorType := ctDynamic
else
ActualCursorType := ctKeySet; // KeySet
ActualSCReadOnly := {DBPROP_IRowsetUpdate} PropValues[3] = False;
end;
end;
end;
var
IsChanged, IsROChanged: boolean;
begin
ActualCursorType := FCursorType;
ActualSCReadOnly := FReadOnly;
AnalyzeCursorType;
IsROChanged := (FCursorType in ServerCursorTypes) and FCursorUpdate and (FReadOnly <> ActualSCReadOnly);
IsChanged := (FCursorType <> ActualCursorType)
or IsROChanged;
if IsChanged then begin
FCursorType := ActualCursorType;
if IsROChanged then
FReadOnly := ActualSCReadOnly;
Assert(Assigned(FCursorTypeChanged));
try
FCursorTypeChanged; // may be exception
except
FCommand.FIUnknown := nil;
FCommand.ClearIMultipleResults;
raise;
end;
end;
end;
begin
if not FNativeRowset then
Exit; // CommandExec is not need for non-Native rowsets
QueryCommandInterfaces(False);
try
if not Prepared
and (FCommand.FIMultipleResults = nil)
and FNativeRowset then // This is a first call to non-prepared DataSet.Command.Execute
SetCommandProp;
inherited;
if (FCommand.FIUnknown <> nil)
and FCommand.FLastExecWarning then
ProcessCursorType;
/// Must be after ProcessCursorType to prevent wrong setting CommandType
if (FCommand.FIUnknown <> nil)
or (FIRowset <> nil) then
CommandType := ctCursor
else
CommandType := ctStatement;
finally
ReleaseCommandInterfaces;
if CommandType <> ctCursor then
FCommand.SetCursorState(csInactive);
end;
end;
procedure TOLEDBRecordSet.Open;
begin
try
inherited;
except
if FCommand.FQueryIntCnt > 0 then
FCommand.ReleaseInterfaces;
raise;
end;
end;
procedure TOLEDBRecordSet.Reopen;
begin
if not FNativeRowset then begin
Close;
SetIRowset(FCommand.FConnection.GetSchemaRowset(FSchema, FRestrictions), False);
end;
inherited;
end;
function TOLEDBRecordSet.GetSchemaRowset(const Schema: TGUID; rgRestrictions: TRestrictions): IRowset;
begin
FSchema := Schema;
FRestrictions := rgRestrictions;
Assert(FCommand.FConnection <> nil);
Result := FCommand.FConnection.GetSchemaRowset(FSchema, FRestrictions);
end;
procedure TOLEDBRecordSet.Disconnect;
begin
Assert(FCommand <> nil);
FCommand.FIUnknown := nil;
// FCommand.FIMultipleRes
//Cache connection depenednt information
GetProviderPrimaryVer;
GetDBMSPrimaryVer;
GetProviderId;
GetProvider;
GetDisconnectedMode;
GetDatabase;
ReleaseAllInterfaces(True);
inherited;
end;
procedure TOLEDBRecordSet.CreateCommand;
var
Cmd: TOLEDBCommand;
begin
Cmd := TOLEDBCommand.Create;
Cmd.FRequestIUnknown := True;
SetCommand(Cmd);
end;
procedure TOLEDBRecordSet.SetCommand(Value: TCRCommand);
begin
inherited;
FCommand := TOLEDBCommand(Value);
end;
function TOLEDBRecordSet.GetIRowset: IRowset;
begin
Result := FIRowset;
end;
function TOLEDBRecordSet.GetICommandText: ICommandText;
begin
Result := FCommand.FICommandText;
end;
procedure TOLEDBRecordSet.SetIRowset(
Rowset: IRowset;
const IsColumnsRowset: boolean); // If True then FieldDescs was stored in FColumnsRowsetFieldDescs
begin
Close;
Unprepare;
FIRowset := Rowset;
FNativeRowset := False;
FReadOnly := True; // Non-native rowset cannot be modified
FCommand.FCursorState := csExecuted;
FFlatBuffers := True;
CommandType := ctUnknown;
FIsColumnsRowset := IsColumnsRowset;
end;
procedure TOLEDBRecordSet.Check(const Status: HRESULT);
begin
if FNativeRowset then
FCommand.FConnection.Check(Status, Component)
else
if Status <> S_OK then
raise EOLEDBError.Create(Status, Format(SOLEDBError, [Status]));
end;
procedure TOLEDBRecordSet.RequestParamsIfPossible;
begin
if (FIRowsetLocate = nil) and (FIRowsetUpdate = nil) and (FIRowset = nil) then begin
FCommand.RequestParamsIfPossible;
if (FCommand.FIUnknown = nil)
and ((FCommand.GetCursorState = csFetching) or (FCommand.GetCursorState = csFetchingAll)) then begin
FCommand.SetCursorState(csFetched);
if not Prepared then
ReleaseCommandInterfaces;
end;
end;
end;
class function TOLEDBRecordSet.GetTableInfoClass: TTableInfoClass;
begin
Result := TOLEDBTableInfo;
end;
function TOLEDBRecordSet.GetProviderPrimaryVer: integer;
begin
if (FCommand <> nil) and (FCommand.FConnection <> nil) then
FProviderPrimaryVer := FCommand.FConnection.ProviderPrimaryVer;
Result := FProviderPrimaryVer;
end;
function TOLEDBRecordSet.GetDBMSPrimaryVer: integer;
begin
if (FCommand <> nil) and (FCommand.FConnection <> nil) then
FDBMSPrimaryVer := FCommand.FConnection.DBMSPrimaryVer;
Result := FDBMSPrimaryVer;
end;
function TOLEDBRecordSet.GetProviderId: TGuid;
begin
if (FCommand <> nil) and (FCommand.FConnection <> nil) then
FProviderId := FCommand.FConnection.FProviderId;
Result := FProviderId;
end;
function TOLEDBRecordSet.GetProvider: TOLEDBProvider;
begin
if (FCommand <> nil) and (FCommand.FConnection <> nil) then
FProvider := FCommand.FConnection.FProvider;
Result := FProvider;
end;
function TOLEDBRecordSet.GetDisconnectedMode: boolean;
begin
if (FCommand <> nil) and (FCommand.FConnection <> nil) then
FDisconnectedMode := FCommand.FConnection.DisconnectedMode;
Result := FDisconnectedMode;
end;
function TOLEDBRecordSet.GetDatabase: string;
begin
if (FCommand <> nil) and (FCommand.FConnection <> nil) then
FDatabase := FCommand.FConnection.FDatabase;
Result := FDatabase;
end;
procedure TOLEDBRecordSet.CheckBCDOverflow(const FieldNo: integer {from 1}; RecBuf: IntPtr);
begin
if (Fields[FieldNo - 1].DataType = dtBCD)
and (GetStatus(FieldNo - 1, RecBuf) = DBSTATUS_E_DATAOVERFLOW) then
raise Exception.Create(SBCDOverflow);
end;
procedure TOLEDBRecordSet.CheckAndAnalyzeFieldsStatus(const Status: HRESULT; const pRec: IntPtr);
const
FieldHeader = 'Field[%d] %s - %s (Status = %Xh).';
var
i: integer;
FieldStatus: DWORD;
FieldName: string;
Msg: WideString;
begin
if (Status <> S_OK) and (Status <> DB_S_ERRORSOCCURRED) then
try
Check(Status);
except
on E: Exception do begin
Msg := '';
for i := 0 to FFields.Count - 1 do
if FFields[i].FieldDescKind = fdkData then begin
FieldName := FFields[i].Name;
if FieldName = '' then
FieldName := IntToStr(i)
else
FieldName := ':' + FieldName;
FieldStatus := GetStatus(i, pRec);
case FieldStatus of
DBSTATUS_S_OK, DBSTATUS_S_ISNULL, DBSTATUS_S_DEFAULT:;
DBSTATUS_E_BADACCESSOR:
AddInfoToErr(Msg, FieldHeader, [i, FieldName, SBadAccessor, FieldStatus]);
DBSTATUS_E_CANTCONVERTVALUE:
AddInfoToErr(Msg, FieldHeader, [i, FieldName, SInvalidValue, FieldStatus]);
DBSTATUS_S_TRUNCATED:
AddInfoToErr(Msg, FieldHeader, [i, FieldName, SDataTruncated, FieldStatus]);
DBSTATUS_E_SIGNMISMATCH:
AddInfoToErr(Msg, FieldHeader, [i, FieldName, SSignMismatch, FieldStatus]);
DBSTATUS_E_DATAOVERFLOW:
AddInfoToErr(Msg, FieldHeader, [i, FieldName, SDataOverflow, FieldStatus]);
DBSTATUS_E_CANTCREATE:
AddInfoToErr(Msg, FieldHeader, [i, FieldName, SCantCreate, FieldStatus]);
DBSTATUS_E_UNAVAILABLE:
{AddInfoToErr(Msg, FieldHeader, [i, FieldName, SUnavaible, FieldStatus])};
DBSTATUS_E_PERMISSIONDENIED:
AddInfoToErr(Msg, FieldHeader, [i, FieldName, SPermissionDenied, FieldStatus]);
DBSTATUS_E_INTEGRITYVIOLATION:
AddInfoToErr(Msg, FieldHeader, [i, FieldName, SIntegrityViolation, FieldStatus]);
DBSTATUS_E_SCHEMAVIOLATION:
AddInfoToErr(Msg, FieldHeader, [i, FieldName, SShemaViolation, FieldStatus]);
DBSTATUS_E_BADSTATUS:
AddInfoToErr(Msg, FieldHeader, [i, FieldName, SBadStatus, FieldStatus]);
else
AddInfoToErr(Msg, FieldHeader, [i, FieldName, SUnknownStatus, FieldStatus]);
end;
end;
AddInfoToErr(E, Msg, []);
raise E;
end;
end;
end;
procedure TOLEDBRecordSet.InternalInitFields;
function ConvertDBCOLUMNINFOToFieldDesc(
// const prgInfoEl: PDBCOLUMNINFO;
const FieldName: string; // prgInfoEl.pwszName
const ActualFieldName: string; // if prgInfoEl.columnid.eKind = DBKIND_NAME then ActualFieldName := prgInfoEl.columnid.uName.pwszName else ActualFieldName := prgInfoEl.pwszName;
const FieldNo: integer; // prgInfoEl.iOrdinal
const OLEDBType: DBTYPE; // prgInfoEl.wType
const dwFlags: DBCOLUMNFLAGS; // prgInfoEl.dwFlags
const IsAutoIncrement: boolean;
const Precision: integer; //prgInfoEl.bPrecision
const Scale: integer; //prgInfoEl.bScale
const ColumnSize: UINT; // prgInfoEl.ulColumnSize
// Options
const LongStrings: boolean;
// Result
Field: TOLEDBFieldDesc
): boolean;// return False, if this field type not supported
function IsFlagSetted(const Flag: UINT): boolean;
begin
Result := (dwFlags and Flag) <> 0;
end;
procedure ConvertFlags;
begin
// DBCOLUMNFLAGS_ISFIXEDLENGTH, DBCOLUMNFLAGS_ISLONG,
// DBCOLUMNFLAGS_ISNULLABLE, DBCOLUMNFLAGS_MAYBENULL
// DBCOLUMNFLAGS_WRITE, DBCOLUMNFLAGS_WRITEUNKNOWN
// DBCOLUMNFLAGS_ISROWID, DBCOLUMNFLAGS_ISROWVER
// DBCOLUMNFLAGS_SCALEISNEGATIVE
Field.Fixed := IsFlagSetted(DBCOLUMNFLAGS_ISFIXEDLENGTH);
Field.IsKey := IsFlagSetted(DBCOLUMNFLAGS_KEYCOLUMN);
Field.Required := not IsFlagSetted(DBCOLUMNFLAGS_ISNULLABLE);
Field.FIsTimestamp := IsFlagSetted(DBCOLUMNFLAGS_ISROWVER);
Field.ReadOnly :=
(not IsFlagSetted(DBCOLUMNFLAGS_WRITE) and
not IsFlagSetted(DBCOLUMNFLAGS_WRITEUNKNOWN));
if FNativeRowset
and not (FCursorType in ServerCursorTypes)
and Field.ReadOnly then
Field.ReadOnly := Field.FIsTimestamp or IsAutoIncrement;
Field.FIsAutoIncrement := IsAutoIncrement;
end;
function CreateUniqueFieldName(const FieldName: string): string;
var
AliasNum: integer;
begin
if FieldName = '' then begin
AliasNum := 1;
repeat
Result := 'COLUMN' + IntToStr(AliasNum);
Inc(AliasNum);
until FindField(Result) = nil;
end
else
Result := FieldName;
end;
var
InternalType: word;
begin
Field.SubDataType := dtUnknown;
Result := ConvertOLEDBTypeToInternalFormat(OLEDBType, IsFlagSetted(DBCOLUMNFLAGS_ISLONG), FEnableBCD, {$IFDEF VER6P}FEnableFMTBCD{$ELSE}False{$ENDIF}, FWideStrings, False, InternalType, DBMSPrimaryVer);
if not Result then
Exit;
// --- Correct access to SQL 2000 server from 7.0 Client
if FNativeRowset
and ((ProviderPrimaryVer < 8) and not IsWindowsVista)
and (Provider <> prCompact)
and (OLEDBType = DBTYPE_NUMERIC)
and (Precision = 19) then
InternalType := dtInt64;
// ---
{$IFDEF LITE}
if (InternalType = dtFmtBCD)
and not ((Scale > 4) or (Precision > 14)) then
InternalType := dtBCD;
{$ENDIF}
Field.DataType := InternalType;
if FNativeRowset then
Field.Name := CreateUniqueFieldName(FieldName)
else
Field.Name := FieldName;
Field.ActualName := ActualFieldName;
Field.FieldNo := FieldNo;
ConvertFlags;
// Correct access to 'bigint' fields from Delphi4
{$IFDEF VER4}
if Field.DataType = dtInt64 then
Field.ReadOnly := True;
{$ENDIF}
{if FNativeRowset then
Field.Hidden := integer(prgInfoEl.columnid.uGuid.pguid) <> 1;
// :( This is impossible becouse we needs TField for update SQLs and for ColumnsMetaInfo}
// WAR Field.Size must be syncronized with actual data size in PutFieldData, GetFieldData, and possible PutFieldAsVariant, GetFieldAsVariant
case InternalType of
// Integer fields
dtBoolean:
Field.Size := sizeof(WordBool);
dtInt8: begin
Field.Size := sizeof(byte);
if DBMSPrimaryVer = 3 then
Field.SubDataType := Field.SubDataType or dtUInt8;
end;
dtWord: begin
if (DBMSPrimaryVer = 3) and (OLEDBType = DBTYPE_UI1) then
Field.SubDataType := Field.SubDataType or dtUInt8;
Field.Size := sizeof(word);
end;
dtInt16:
Field.Size := sizeof(smallint);
dtInt32, dtUInt32:
Field.Size := sizeof(integer);
dtInt64:
Field.Size := sizeof(int64);
// Float fields
dtFloat:
begin
Field.Size := sizeof(double);
Field.Scale := Scale;
Field.Length := Precision; // Precision cannot be greater then 15
if OLEDBType = DBTYPE_R4 then begin
Field.Length := 7;
if DBMSPrimaryVer = 3 then
Field.SubDataType := Field.SubDataType or dtSingle;
end
else
if OLEDBType = DBTYPE_R8 then
Field.Length := 15;
end;
dtCurrency:
begin
Field.Size := sizeof(double);
//Field.Size := sizeof(currency); //Currency type cannot be used over TCurrencyField uses double to store
Field.Scale := Scale;
Field.Length := Precision; // Precision cannot be greater then 15
end;
// Multibyte fields
dtBCD:
begin
Field.Size := sizeof(Currency);
Field.Scale := Scale;
Field.Length := Precision;
end;
{$IFDEF VER6P}
dtFmtBCD:
begin
if Precision < SizeOfTBcd then
Field.Size := SizeOfTBcd + 1{'+/-'} + 1{'.'} + 1{#0}
else
Field.Size := Precision + 1{'.'} + 1 {#0}; // To right notation of large NUMERIC values
Field.Scale := Scale;
Field.Length := Precision;
end;
{$ENDIF}
dtDateTime:
if DBMSPrimaryVer <> 3 then
Field.Size := sizeof(TDateTime)
else
Field.Size := sizeof(TDBTimeStamp);
dtDate, dtTime:
Field.Size := sizeof(TDateTime);
{$IFDEF VER5P}
dtGuid:
begin
Field.Length := 38; { Length(GuidString) }
Field.Size := Field.Length + 1;
end;
{$ENDIF}
dtString, dtWideString, dtMemo, dtWideMemo, dtMSXML:
begin
Field.Length := 0; // WAR Field.Size must be syncronized with actual data size in PutFieldData, GetFieldData, and possible PutFieldAsVariant, GetFieldAsVariant
{$IFNDEF VER5P}
if prgInfoEl.wType = DBTYPE_GUID then
begin
Field.Length := 38; { Length(GuidString) }
Field.Size := Word(Field.Length + 1);
end
else
{$ENDIF}
if IsFlagSetted(DBCOLUMNFLAGS_ISLONG) then begin
// This is a MS SQL 'text' or 'ntext' field
Field.SubDataType := dtText;
Field.Size := Word(sizeof(IntPtr)) {ISeqStream};
if not FReadOnly then
Field.Size := Word(Field.Size + Word(sizeof(integer))) {DBLENGTH};
end
else // This is a MS SQL 'char', 'varchar', 'nchar' or 'nvarchar' field
begin
if not LongStrings and (ColumnSize > 255) then begin
if InternalType = dtWideString then
Field.DataType := dtWideMemo
else
Field.DataType := dtMemo;
Field.Size := Word(sizeof(IntPtr)) {ISeqStream};
if not FReadOnly then
Field.Size := Word(Field.Size + Word(sizeof(integer))) {DBLENGTH};
end
else
begin
Field.Length := ColumnSize;
if InternalType = dtWideString then
Field.Size := Word((ColumnSize + 1) * sizeof(WideChar))
else
Field.Size := Word(ColumnSize + 1);
if not FFlatBuffers and (Field.Size >= FlatBufferLimit) and (FCursorType = ctDefaultResultSet) then
begin
Field.Size := Word(sizeof(IntPtr));
if InternalType = dtString then
Field.DataType := dtExtString
else
Field.DataType := dtExtWideString;
end;
end;
end;
if (OLEDBType = DBTYPE_WSTR) or (OLEDBType = DBTYPE_XML) then
Field.SubDataType := Field.SubDataType or dtWide;
end;
dtBytes, dtVarBytes, dtBlob:
begin
if IsFlagSetted(DBCOLUMNFLAGS_ISLONG) then begin
// This is a MS SQL 'image' field
// WAR Field.Size must be syncronized with actual data size in PutFieldData, GetFieldData, and possible PutFieldAsVariant, GetFieldAsVariant
Field.Size := Word(sizeof(IntPtr)) {ISeqStream};
if not FReadOnly then
Field.Size := Word(Field.Size + Word(sizeof(integer))) {DBLENGTH};
end
else
begin
Field.Length := Word(ColumnSize);
if Field.Fixed then begin
if FReadOnly then
Field.Size := Word(Field.Length)
else
Field.Size := Word(Field.Length + Word(sizeof(UINT))) {OLE DB readed bytes};
end
else
if FFlatBuffers or (ColumnSize < FlatBufferLimit) or (FCursorType <> ctDefaultResultSet) then
begin
Field.DataType := dtVarBytes;
Field.Size := Word(Word(sizeof(word)) {Readed bytes} + Field.Length + Word(sizeof(UINT))) {OLE DB readed bytes};
end
else
begin
Field.Length := Word(ColumnSize);
Field.DataType := dtExtVarBytes;
Field.Size := Word(sizeof(IntPtr) {IntPtr to OLEDBBuf/StringHeap} + sizeof(UINT)) {OLE DB readed bytes};
end;
end;
end;
{$IFDEF VER5P}
dtVariant:
Field.Size := sizeof(TVariantObject);
{$ENDIF}
else
Result := False;
end;
end;
procedure CreateFieldDescs(
const IUnk: IUnknown;
const ByInfo: boolean // if True, then FieldDescs creates with using ColumnsInfo, otherwise - using ColumnsRowset
);
procedure CreateFieldDescsByInfo;
function GetHiddenColumnsCount: UINT;
var
PropValues: TPropValues;
begin
with TOLEDBPropertiesGet.Create(FCommand.FConnection, DBPROPSET_ROWSET) do
try
AddPropId(DBPROP_HIDDENCOLUMNS);
GetProperties(FCommand.FICommandProperties, PropValues);
finally
Free;
end;
Result := PropValues[0];
end;
var
ColumnsInfo: IColumnsInfo;
i: integer;
Field, BookmarkField: TOLEDBFieldDesc;
cColumns: UINT;
prgInfo: PDBCOLUMNINFO;
prgInfoEl: PDBCOLUMNINFO;
rgInfoEl: {$IFDEF CLR}DBCOLUMNINFO{$ELSE}PDBCOLUMNINFO{$ENDIF};
pStringsBuffer: IntPtr;
//Malloc: IMalloc;
ActualFieldName: string;
begin
if IUnk = nil then
Exit; // This query does not return rowset
QueryIntf(IUnk, {$IFDEF CLR}IColumnsInfo{$ELSE}IID_IColumnsInfo{$ENDIF}, ColumnsInfo);
Assert(ColumnsInfo <> nil);
pStringsBuffer := nil;
Check(ColumnsInfo.GetColumnInfo(cColumns, PDBCOLUMNINFO(prgInfo), pStringsBuffer));
{$IFDEF LITE}
Assert(not FUniqueRecords);
{$ENDIF}
// Add hidden columns count for SQL 2000
if FNativeRowset and ((ProviderPrimaryVer >= 8) or IsWindowsVista) and FUniqueRecords then
cColumns := cColumns + GetHiddenColumnsCount;
if cColumns > 0 then
try
BookmarkField := nil;
prgInfoEl := prgInfo;
for i := 0 to cColumns - 1 do begin
{$IFDEF CLR}
Assert(prgInfoEl <> nil);
rgInfoEl := DBCOLUMNINFO(Marshal.PtrToStructure(prgInfoEl, TypeOf(DBCOLUMNINFO)));
{$ELSE}
rgInfoEl := prgInfoEl;
{$ENDIF}
Field := TOLEDBFieldDesc.Create;
try
if rgInfoEl.columnid.eKind = DBKIND_NAME then
ActualFieldName := Marshal.PtrToStringUni(rgInfoEl.columnid.uName{$IFNDEF CLR}.pwszName{$ENDIF})
else
ActualFieldName := rgInfoEl.pwszName;
if ConvertDBCOLUMNINFOToFieldDesc(
// rgInfoEl
rgInfoEl.pwszName,
ActualFieldName,
rgInfoEl.iOrdinal,
rgInfoEl.wType,
rgInfoEl.dwFlags,
False,
rgInfoEl.bPrecision,
rgInfoEl.bScale,
rgInfoEl.ulColumnSize,
FLongStrings, Field) then begin
Field.FOLEDBType := rgInfoEl.wType;
if Field.FieldNo > 0 then
FFields.Add(Field)
else // Bookmark column have FieldNo = 0
begin
Field.Hidden := True;
BookmarkField := Field;
FBookmarkOffset := - 1;
end;
end
else
if FNativeRowset then
DatabaseErrorFmt(SBadFieldType, [rgInfoEl.pwszName, rgInfoEl.wType])
else
Field.Free;
except
Field.Free;
BookmarkField.Free;
raise;
end;
prgInfoEl := IntPtr(Integer(prgInfoEl) +
{$IFDEF CLR}
Marshal.SizeOf(TypeOf(DBCOLUMNINFO))
{$ELSE}
sizeof(DBCOLUMNINFO)
{$ENDIF});
end;
if BookmarkField <> nil then
FFields.Add(BookmarkField);
finally
{if FCommand.FConnection = nil then
CoGetMalloc(1, Malloc)
else
Malloc := FCommand.FConnection.Malloc;}
FreeCoMem(prgInfo);
FreeCoMem(pStringsBuffer);
//Malloc.Free(prgInfo);
//Malloc.Free(pStringsBuffer);
//Malloc := nil;
end;
end;
{$IFNDEF LITE}
procedure CreateFieldDescsByRowset;
var
RecBuf: IntPtr;
ColumnsMetaInfo: TOLEDBRecordSet;
procedure CheckColumnsMetaInfo;
begin
if FCommand.FConnection.FColumnsMetaInfo <> nil then
ColumnsMetaInfo := FCommand.FConnection.FColumnsMetaInfo
else
begin
ColumnsMetaInfo := TOLEDBRecordSet.Create;
FCommand.FConnection.FColumnsMetaInfo := ColumnsMetaInfo;
ColumnsMetaInfo.SetConnection(FCommand.FConnection);
ColumnsMetaInfo.SetProp(prFetchAll, False);
ColumnsMetaInfo.SetProp(prFetchRows, 1);
ColumnsMetaInfo.SetProp(prUniDirectional, True);
FCommand.FConnection.FFldCatalogNameIdx := -1;
end;
end;
procedure CheckColumnsMetaInfoIdx;
begin
Assert(ColumnsMetaInfo <> nil);
if FCommand.FConnection.FFldCatalogNameIdx <> - 1 then
Exit;
with FCommand.FConnection do begin
FFldCatalogNameIdx := FColumnsMetaInfo.Fields.IndexOf(FColumnsMetaInfo.FindField('DBCOLUMN_BASECATALOGNAME')); // SQL Everywhere
FFldSchemaNameIdx := FColumnsMetaInfo.Fields.IndexOf(FColumnsMetaInfo.FindField('DBCOLUMN_BASESCHEMANAME')); // SQL Everywhere
FFldTableNameIdx := FColumnsMetaInfo.Fields.IndexOf(FColumnsMetaInfo.FieldByName('DBCOLUMN_BASETABLENAME'));
FFldColumnNameIdx := FColumnsMetaInfo.Fields.IndexOf(FColumnsMetaInfo.FieldByName('DBCOLUMN_BASECOLUMNNAME'));
FFldPrecisionIdx := FColumnsMetaInfo.Fields.IndexOf(FColumnsMetaInfo.FieldByName('DBCOLUMN_PRECISION'));
FFldScaleIdx := FColumnsMetaInfo.Fields.IndexOf(FColumnsMetaInfo.FieldByName('DBCOLUMN_SCALE'));
FFldGuidIdx := FColumnsMetaInfo.Fields.IndexOf(FColumnsMetaInfo.FieldByName('DBCOLUMN_GUID'));
/// ??? May be swap?
FFldFieldNameIdx := FColumnsMetaInfo.Fields.IndexOf(FColumnsMetaInfo.FieldByName('DBCOLUMN_IDNAME'));
FFldActualFieldNameIdx := FColumnsMetaInfo.Fields.IndexOf(FColumnsMetaInfo.FieldByName('DBCOLUMN_NAME'));
FFldColumnNumberIdx := FColumnsMetaInfo.Fields.IndexOf(FColumnsMetaInfo.FieldByName('DBCOLUMN_NUMBER'));
FFldIsAutoIncIdx := FColumnsMetaInfo.Fields.IndexOf(FColumnsMetaInfo.FindField('DBCOLUMN_ISAUTOINCREMENT')); // SQL Everywhere
FFldTypeIdx := FColumnsMetaInfo.Fields.IndexOf(FColumnsMetaInfo.FieldByName('DBCOLUMN_TYPE'));
FFldFlagsIdx := FColumnsMetaInfo.Fields.IndexOf(FColumnsMetaInfo.FieldByName('DBCOLUMN_FLAGS'));
FFldColumnSizeIdx := FColumnsMetaInfo.Fields.IndexOf(FColumnsMetaInfo.FieldByName('DBCOLUMN_COLUMNSIZE'));
FFldComputeModeIdx := FColumnsMetaInfo.Fields.IndexOf(FColumnsMetaInfo.FindField('DBCOLUMN_COMPUTEMODE'));
// xml schema support
FFldXMLSchemaCollCatalogNameIdx := FColumnsMetaInfo.Fields.IndexOf(FColumnsMetaInfo.FindField('DBCOLUMN_XML_SCHEMACOLLECTION_CATALOGNAME'));
FFldXMLSchemaCollSchemaNameIdx := FColumnsMetaInfo.Fields.IndexOf(FColumnsMetaInfo.FindField('DBCOLUMN_XML_SCHEMACOLLECTION_SCHEMANAME'));
FFldXMLSchemaCollNameIdx := FColumnsMetaInfo.Fields.IndexOf(FColumnsMetaInfo.FindField('DBCOLUMN_XML_SCHEMACOLLECTIONNAME'));
end;
end;
procedure FillTablesAliases;
var
Parser: TMSParser;
TableName: string;// Table or view name
StLex, Alias: string;
CodeLexem: integer;
TableInfo: TCRTableInfo;
begin
TablesInfo.BeginUpdate;
Parser := TMSParser.Create(FCommand.SQL);
Parser.OmitBlank := False;
Parser.OmitComment := True;
try
if Parser.ToLexem(lxSELECT) <> lcEnd then
if Parser.ToLexem(lxFROM) <> lcEnd then
repeat
repeat
CodeLexem := Parser.GetNext(StLex);// Omit blank
until CodeLexem <> lcBlank;
// TableName
TableName := StLex;
while True do begin
CodeLexem := Parser.GetNext(StLex);
if (Length(StLex) > 0) and (StLex[1] = ',') then
Break;
if {(Length(StLex) > 0) and (StLex[1] in ['[, ' + '], ' + '", ' + '.']) and} (CodeLexem <> 0) and (CodeLexem <> lcBlank) then
TableName := TableName + StLex
else
Break;
end;
// 'AS' clause
if Parser.GetNext(Alias) = lxAS then
Parser.GetNext(Alias)
else
Parser.Back;
// Alias
if Parser.GetNext(Alias) = lcIdent then
Parser.GetNext(StLex)
else begin
Alias := '';
Parser.Back;
end;
TableName := UnBracketIfPossible(TableName);
Assert(TableName <> '', 'TableName cannot be empty'); // ++++
TableInfo := TablesInfo.FindByName(TableName);
if TableInfo = nil then begin
TableInfo := TablesInfo.Add;
TableInfo.TableName := TableName;
TableInfo.TableAlias := '';
TableInfo.IsView := True;
end;
if Alias <> '' then
TableInfo.TableAlias := TableInfo.NormalizeName(Alias);
until (StLex <> ',');
finally
Parser.Free;
TablesInfo.EndUpdate;
end;
end;
function GetStrValue(Idx: integer): string;
var
Field: TOLEDBFieldDesc;
begin
if ColumnsMetaInfo.GetNull(Idx + 1, RecBuf) then
Result := ''
else
begin
Field := TOLEDBFieldDesc(ColumnsMetaInfo.Fields[Idx]);
if (Field.SubDataType and dtWide) = 0 then
Result := Marshal.PtrToStringAnsi(IntPtr(Integer(RecBuf) + Field.Offset))
else
Result := Marshal.PtrToStringUni(IntPtr(Integer(RecBuf) + Field.Offset));
end;
end;
function GetWordValue(Idx: integer): Word;
begin
if ColumnsMetaInfo.GetNull(Idx + 1, RecBuf) then
Result := 0
else
Result := Word(Marshal.ReadInt16(RecBuf, ColumnsMetaInfo.Fields[Idx].Offset));
end;
function GetLongWordValue(Idx: integer): Word;
begin
if ColumnsMetaInfo.GetNull(Idx + 1, RecBuf) then
Result := 0
else
Result := LongWord(Marshal.ReadInt32(RecBuf, ColumnsMetaInfo.Fields[Idx].Offset));
end;
function GetUINTValue(Idx: integer): UINT;
begin
if ColumnsMetaInfo.GetNull(Idx + 1, RecBuf) then
Result := 0
else
Result := UINT(Marshal.ReadInt32(RecBuf, ColumnsMetaInfo.Fields[Idx].Offset));
end;
function GetSmallIntValue(Idx: integer): SmallInt;
begin
if ColumnsMetaInfo.GetNull(Idx + 1, RecBuf) then
Result := 0
else
Result := SmallInt(Marshal.ReadInt16(RecBuf, ColumnsMetaInfo.Fields[Idx].Offset));
end;
var
ColumnsRowset: IColumnsRowset;
CMIRowset: IRowset;
Field, BookmarkField: TOLEDBFieldDesc;
FieldNo: integer;
TableName: string;
FieldName, ActualFieldName: string;
iu: IUnknown;
FldGuidValue: string;
TableInfo: TCRTableInfo;
IsAutoIncrement: boolean;
ColumnsRecordSet: TOLEDBRecordSet;
Value: variant;
begin
if IUnk = nil then
Exit; // This query does not return rowset
Assert (FRequestSQLObjects and FNativeRowset);
QueryIntf(IUnk, {$IFDEF CLR}IColumnsRowset{$ELSE}IID_IColumnsRowset{$ENDIF}, ColumnsRowset);
Check(ColumnsRowset.GetColumnsRowset(nil, 0, nil, IID_IRowset, 0, nil, iu));{Default properties - default result set}
CMIRowset := IRowset(iu);
Assert(CMIRowset <> nil);
try
FBookmarkOffset := - 2;
BookmarkField := nil;
CheckColumnsMetaInfo;
ColumnsMetaInfo.SetIRowset(CMIRowset, True);
//ColumnsMetaInfo.Prepare;
ColumnsMetaInfo.Open;
RecBuf := nil;
try
CheckColumnsMetaInfoIdx;
ColumnsMetaInfo.AllocRecBuf(IntPtr(RecBuf));
while True do begin
ColumnsMetaInfo.GetNextRecord(RecBuf);
if ColumnsMetaInfo.Eof then
Break;
FieldNo := GetLongWordValue(FCommand.FConnection.FFldColumnNumberIdx);
Assert(FieldNo >= 0); // Bookmark column have FieldNo = 0
Field := TOLEDBFieldDesc.Create;
try
{
SELECT BaseColumnName AS ColumnAlias ...
FIConnection.ProviderVer = [07.01.0623, 07.01.0690, 07.01.0819, 07.01.0961]
FieldName = BaseColumnName
ActualName = ColumnAlias
BaseColumnName = BaseColumnName
FIConnection.ProviderVer = [08.00.0194, 08.00.0528, 08.10.7430, 08.10.9001]
FieldName = ColumnAlias
ActualName = ColumnAlias
BaseColumnName = BaseColumnName
}
ActualFieldName := GetStrValue(FCommand.FConnection.FFldActualFieldNameIdx);
if (ProviderPrimaryVer < 8) and not IsWindowsVista then
FieldName := ActualFieldName
else
FieldName := GetStrValue(FCommand.FConnection.FFldFieldNameIdx);
IsAutoIncrement := False;
if FCommand.FConnection.FFldIsAutoIncIdx <> - 1 then
IsAutoIncrement := WordBool(GetWordValue(FCommand.FConnection.FFldIsAutoIncIdx));
if ConvertDBCOLUMNINFOToFieldDesc(
// prgInfoEl
FieldName,
ActualFieldName,
FieldNo,
GetWordValue(FCommand.FConnection.FFldTypeIdx),
GetUINTValue(FCommand.FConnection.FFldFlagsIdx),
IsAutoIncrement,
GetWordValue(FCommand.FConnection.FFldPrecisionIdx),
GetSmallIntValue(FCommand.FConnection.FFldScaleIdx),
GetUINTValue(FCommand.FConnection.FFldColumnSizeIdx),
// Options
FLongStrings, Field) then begin
Field.FOLEDBType := GetWordValue(FCommand.FConnection.FFldTypeIdx);
if FCommand.FConnection.FFldCatalogNameIdx <> -1 then
Field.FBaseCatalogName := GetStrValue(FCommand.FConnection.FFldCatalogNameIdx);
if FCommand.FConnection.FFldSchemaNameIdx <> -1 then
Field.FBaseSchemaName := GetStrValue(FCommand.FConnection.FFldSchemaNameIdx);
Field.FBaseTableName := GetStrValue(FCommand.FConnection.FFldTableNameIdx);
Field.FBaseColumnName := GetStrValue(FCommand.FConnection.FFldColumnNameIdx);
if FCommand.FConnection.FFldXMLSchemaCollCatalogNameIdx <> -1 then
Field.FXMLSchemaCollectionCatalogName := GetStrValue(FCommand.FConnection.FFldXMLSchemaCollCatalogNameIdx);
if FCommand.FConnection.FFldXMLSchemaCollSchemaNameIdx <> -1 then
Field.FXMLSchemaCollectionSchemaName := GetStrValue(FCommand.FConnection.FFldXMLSchemaCollSchemaNameIdx);
if FCommand.FConnection.FFldXMLSchemaCollNameIdx <> -1 then
Field.FXMLSchemaCollectionName := GetStrValue(FCommand.FConnection.FFldXMLSchemaCollNameIdx);
Field.FXMLTyped := (Field.XMLSchemaCollectionCatalogName <> '') or (Field.XMLSchemaCollectionSchemaName <> '') or
(Field.FXMLSchemaCollectionName <> '');
Field.ReadOnly := Field.ReadOnly or (Field.FBaseColumnName = '');
if FCommand.FConnection.FFldComputeModeIdx <> -1 then
Field.ReadOnly := Field.ReadOnly or (GetUINTValue(FCommand.FConnection.FFldComputeModeIdx) <> DBCOMPUTEMODE_NOTCOMPUTED);
if (not FUniqueRecords) or (FCursorType in ServerCursorTypes) then // Hide implicitly requested columns
if (ProviderPrimaryVer >= 8) or IsWindowsVista then begin
FldGuidValue := LowerCase(GetStrValue(FCommand.FConnection.FFldGuidIdx));
Field.Hidden := (FldGuidValue <> '') and (FldGuidValue <> '{' + LowerCase(IntToHex(FieldNo, 8))+'-0000-0000-0000-000000000000' + '}')
end
else
Field.Hidden := not ColumnsMetaInfo.GetNull(FCommand.FConnection.FFldGuidIdx + 1, RecBuf);
// Fill TablesInfo structure
TableName := GenerateTableName(Field.BaseCatalogName, Field.BaseSchemaName, Field.BaseTableName, Database);
if TableName <> '' then begin
TableInfo := TablesInfo.FindByName(TableName);
TablesInfo.BeginUpdate;
try
if TableInfo = nil then begin
TableInfo := TablesInfo.Add;
TableInfo.TableName := TableName;
TableInfo.TableAlias := '';
end;
finally
TablesInfo.EndUpdate;
end;
Field.TableInfo := TableInfo;
end
else
Field.TableInfo := nil;
if FieldNo > 0 then
FFields.Add(Field)
else // Bookmark column have FieldNo = 0
begin
Field.Hidden := True;
BookmarkField := Field;
FBookmarkOffset := - 1;
end;
end
else
if FNativeRowset then
DatabaseErrorFmt(SBadFieldType, [FieldName, GetWordValue(FCommand.FConnection.FFldTypeIdx)])
else
Field.Free;
except
Field.Free;
BookmarkField.Free;
raise;
end;
end;
if BookmarkField <> nil then
FFields.Add(BookmarkField);
if (Provider = prCompact) and (not FPopulatingKeyInfo) and (FUniqueRecords or not FReadOnly) then begin
if TablesInfo.Count > 0 then begin
TableInfo := TablesInfo[0];
ColumnsRecordSet := TOLEDBRecordSet.Create;
FPopulatingKeyInfo := True;
try
ColumnsRecordSet.SetConnection(FCommand.FConnection);
ColumnsRecordSet.SetSQL(Format(
'SELECT' + LineSeparator +
' A.COLUMN_NAME, B.AUTOINC_INCREMENT' + LineSeparator +
'FROM' + LineSeparator +
' INFORMATION_SCHEMA.KEY_COLUMN_USAGE A, INFORMATION_SCHEMA.COLUMNS B' + LineSeparator +
'WHERE' + LineSeparator +
' A.TABLE_NAME = B.TABLE_NAME and A.COLUMN_NAME = B.COLUMN_NAME and A.TABLE_NAME = %s', [QuotedStr(TableInfo.TableName)]));
ColumnsRecordSet.Open;
if RecBuf <> nil then
ColumnsMetaInfo.FreeRecBuf(RecBuf);
ColumnsRecordSet.AllocRecBuf(RecBuf);
while True do begin
ColumnsRecordSet.GetNextRecord(RecBuf);
if ColumnsRecordSet.Eof then
Break;
if not ColumnsRecordSet.GetNull(ColumnsRecordSet.FieldByName('COLUMN_NAME').FieldNo, RecBuf) then begin
ColumnsRecordSet.GetFieldAsVariant(ColumnsRecordSet.FieldByName('COLUMN_NAME').FieldNo, RecBuf, Value);
Field := TOLEDBFieldDesc(FFields.FindField(String(Value)));
if Field <> nil then begin
Field.IsKey := True;
Field.FIsAutoIncrement := not ColumnsRecordSet.GetNull(ColumnsRecordSet.FieldByName('AUTOINC_INCREMENT').FieldNo, RecBuf);
if FNativeRowset and not (FCursorType in ServerCursorTypes) then
Field.ReadOnly := Field.FIsTimestamp or Field.IsAutoIncrement;
end;
end;
end;
finally
ColumnsRecordSet.FreeRecBuf(RecBuf);
RecBuf := nil;
ColumnsRecordSet.Close;
ColumnsRecordSet.Free;
FPopulatingKeyInfo := False;
end;
end;
end;
finally
if RecBuf <> nil then
ColumnsMetaInfo.FreeRecBuf(RecBuf);
if ColumnsMetaInfo <> nil then begin
ColumnsMetaInfo.Close;
ColumnsMetaInfo.UnPrepare;
end;
if IsLibrary then
FreeAndNil(FCommand.FConnection.FColumnsMetaInfo);
end;
finally
{$IFDEF CLR}
if CMIRowset <> nil then
Marshal.ReleaseComObject(CMIRowset);
{$ENDIF}
end;
Assert(not (FCursorType in [ctStatic, ctKeySet]) or (FBookmarkOffset <> - 2));
TablesInfo.Normalize;
FillTablesAliases;
// For
// SELECT FieldName FieldAlias FROM TableName TableAlias
// must be
// Field.Name = 'FieldAlias'
// Field.ActualName = 'FieldAlias'
// Field.TableName = '' ???
// Field.BaseColumnName = 'c_int'
// Field.BaseTableName = 'ALL_TYPES'
end;
{$ENDIF}
var
Connection: TOLEDBConnection;
begin
if ByInfo then begin
if FNativeRowset or not FIsColumnsRowset then
CreateFieldDescsByInfo
else
begin
// Detect true connection
Connection := FCommand.FConnection;
if Connection.FColumnsRowsetFieldDescs <> nil then
Connection.AssignFieldDescs(Connection.FColumnsRowsetFieldDescs, FFields)
else
begin
CreateFieldDescsByInfo;
Connection.FColumnsRowsetFieldDescs := TFieldDescs.Create;
try
try
Connection.AssignFieldDescs(FFields, Connection.FColumnsRowsetFieldDescs) // Save fields for columnsrowset
except
FreeAndNil(Connection.FColumnsRowsetFieldDescs);
raise;
end;
finally
if IsLibrary then
FreeAndNil(Connection.FColumnsRowsetFieldDescs);
end;
end;
end;
end
else
{$IFNDEF LITE}
CreateFieldDescsByRowset;
{$ELSE}
Assert(False);
{$ENDIF}
end;
begin
inherited; // Empty proc call
if not FNativeRowset then
CommandType := ctCursor;
if CommandType = ctUnknown then begin // This is a FieldDefs.Update call
QueryCommandInterfaces(False);
try
SetCommandProp;
FCommand.Execute;
finally
ReleaseCommandInterfaces; /// FCommand.QueryIntCnt counter is increased in inherited
end;
CreateFieldDescs(FCommand.FIUnknown, not FRequestSQLObjects);
// Free interfaces
{$IFDEF CLR}
if FCommand.FIMultipleResults <> nil then
Marshal.ReleaseComObject(FCommand.FIMultipleResults);
if FCommand.FIUnknown <> nil then
Marshal.ReleaseComObject(FCommand.FIUnknown);
{$ENDIF}
FCommand.FIUnknown := nil;
FCommand.ClearIMultipleResults;
// Free param accessors (must be after clearing interfaces)
RequestParamsIfPossible;
// We does not need to process non-Native rowsets or ServerCursors
// QueryRecordSetInterfaces not required too
Exit;
end;
if not FNativeRowset then
CreateFieldDescs(FIRowset, True)
else
begin
Assert(FIRowset = nil);
if Prepared and not FCommand.FRPCCall then
CreateFieldDescs(FCommand.FICommandPrepare, not FRequestSQLObjects)
else
CreateFieldDescs(FCommand.FIUnknown, not FRequestSQLObjects);
end;
end;
procedure TOLEDBRecordSet.AllocFetchBlock;
var
UseIRowsetUpdate: boolean;
function AddFieldToABList(const FieldNum: integer): integer; // Add new AB, if need. If AB already present then return its index
function AddAB(const BlockType: TAccessorBlockType): integer;
var
l: integer;
begin
l := Length(FFetchAccessorData.AccessorBlocks);
SetLength(FFetchAccessorData.AccessorBlocks, l + 1);
FFetchAccessorData.AccessorBlocks[l].BlockType := BlockType;
FFetchAccessorData.AccessorBlocks[l].hAcc := 0;
FFetchAccessorData.AccessorBlocks[l].BlobFieldNum := -1;
Result := l;
end;
var
BlockType: TAccessorBlockType;
FieldDesc: TOLEDBFieldDesc;
i: integer;
IsLarge: boolean;
IsDBNumeric: boolean;
begin
Result := -1;
try
FieldDesc := Fields[FieldNum] as TOLEDBFieldDesc;
IsLarge := IsLargeDataTypeUsed(FieldDesc);
IsDBNumeric := (ProviderPrimaryVer = 3) and (FieldDesc.OLEDBType = DBTYPE_NUMERIC);
if IsNeedFetchBlock(FieldDesc, ProviderPrimaryVer) then
BlockType := abFetchBlock // This is a string by ref - long string conversion used
else
if FieldDesc.ReadOnly and UseIRowsetUpdate then
BlockType := abReadOnly
else
if IsLarge and UseIRowsetUpdate then
BlockType := abBLOB
else
BlockType := abOrdinary;
if not (FCursorType in [ctKeySet, ctDynamic]) // CR 4082
and (BlockType <> abBLOB) then
for i := 0 to Length(FFetchAccessorData.AccessorBlocks) - 1 do
if FFetchAccessorData.AccessorBlocks[i].BlockType = BlockType then begin
// Test BLOB fields
if IsLarge then begin
if FFetchAccessorData.AccessorBlocks[i].BlobFieldNum = - 1 then
FFetchAccessorData.AccessorBlocks[i].BlobFieldNum := FieldNum
else
begin
BlockType := abBLOB;
Result := AddAB(BlockType);
FFetchAccessorData.AccessorBlocks[Result].BlobFieldNum := FieldNum;
Exit;
end;
end;
// Test numeric fields in Everywhere
if IsDBNumeric then begin
Result := AddAB(BlockType);
Exit;
end;
Result := i;
Exit;
end;
// Accessor block not found! Create new
Result := AddAB(BlockType);
if IsLarge then
FFetchAccessorData.AccessorBlocks[Result].BlobFieldNum := FieldNum;
finally
Assert(Result <> - 1);
i := Length(FFetchAccessorData.AccessorBlocks[Result].FieldNums);
SetLength(FFetchAccessorData.AccessorBlocks[Result].FieldNums, i + 1);
FFetchAccessorData.AccessorBlocks[Result].FieldNums[i] := FieldNum;
end;
end;
// Fill internal structures in accessor block
procedure FillBindingStructInAccBlock(
rgBindings: TDBBindingArray;
var AccessorBlock: TAccessorBlock);
var
Cnt, i, l: integer;
FieldNum: integer;
Field: TFieldDesc;
Obj: OLEDBIntf.DBOBJECT;
begin
Cnt := Length(AccessorBlock.FieldNums);
Assert(Cnt > 0);
//OFS('+FillBindingStructInAccBlock');
for i := 0 to Cnt - 1 do
with rgBindings[i] do begin
FieldNum := AccessorBlock.FieldNums[i];
Field := FFields[FieldNum];
iOrdinal := Field.FieldNo;
obValue := Field.Offset;
obLength := 0;
obStatus := DataSize + FieldNum * OLE_DB_INDICATOR_SIZE;
dwPart := DBPART_VALUE or DBPART_STATUS;
dwMemOwner := DBMEMOWNER_CLIENTOWNED;
eParamIO := DBPARAMIO_NOTPARAM;
cbMaxLen := Field.Size;
if (FCursorType in [ctStatic, ctKeyset]) and (iOrdinal = 0) then
dwFlags := DBCOLUMNFLAGS_ISBOOKMARK
else
dwFlags := 0;
wType := ConvertInternalTypeToOLEDB(Field.dataType, False, DBMSPrimaryVer);
if (DBMSPrimaryVer = 3) then begin
if (TOLEDBFieldDesc(Field).OLEDBType = DBTYPE_R4) then
wType := DBTYPE_R4;
if (TOLEDBFieldDesc(Field).OLEDBType = DBTYPE_UI1) then begin
wType := DBTYPE_UI1;
cbMaxLen := SizeOf(Word);
end;
if (TOLEDBFieldDesc(Field).OLEDBType = DBTYPE_NUMERIC) then begin
wType := DBTYPE_NUMERIC;
cbMaxLen := SizeOfTDBNumeric;
end;
end;
if not IsLargeDataTypeUsed(Field) then begin //???
case Field.DataType of
dtExtString, dtExtWideString:
begin
if Field.DataType = dtExtString then
l := 1
else
if Field.DataType = dtExtWideString then
l := 2
else
begin
l := 0;
Assert(False);
end;
Assert(AccessorBlock.BlockType = abFetchBlock);
dwPart := DBPART_VALUE or DBPART_STATUS or DBPART_LENGTH;
cbMaxLen := MaxNonBlobFieldLen + l;
obStatus := FFetchBlockSize;
obLength := obStatus + OLE_DB_INDICATOR_SIZE;
obValue := obLength + 4;
IncFetchBlockOffset(FFetchBlockSize, Field.DataType);
end;
dtMemo, dtWideMemo, dtMSXML: // Long string conversion used
begin
Assert(AccessorBlock.BlockType = abFetchBlock);
if (Field.SubDataType and dtWide) = 0 then begin
wType := DBTYPE_STR;
l := 1;
end
else
begin
wType := DBTYPE_WSTR;
l := 2;
end;
cbMaxLen := MaxNonBlobFieldLen + l;
obStatus := FFetchBlockSize;
obValue := obStatus + OLE_DB_INDICATOR_SIZE;
IncFetchBlockOffset(FFetchBlockSize, dtMemo);
end;
dtVariant:
begin
Assert(AccessorBlock.BlockType = abFetchBlock);
wType := DBTYPE_VARIANT;
cbMaxLen := sizeof(OleVariant);
obStatus := FFetchBlockSize;
obValue := obStatus + OLE_DB_INDICATOR_SIZE;
IncFetchBlockOffset(FFetchBlockSize, dtVariant);
end;
dtBytes:
if not FReadOnly then begin
dwPart := DBPART_VALUE or DBPART_STATUS or DBPART_LENGTH;
obValue := Field.Offset;
obLength := obValue + Field.Length;
cbMaxLen := Field.Length;
end;
dtVarBytes:
begin
dwPart := DBPART_VALUE or DBPART_STATUS or DBPART_LENGTH;
obValue := Field.Offset + sizeof(word);
obLength := obValue + Field.Length;
cbMaxLen := Field.Length;
end;
dtExtVarBytes:
begin
Assert(AccessorBlock.BlockType = abFetchBlock);
cbMaxLen := MaxNonBlobFieldLen; // WAR on changing must change FetchExternalAccessorBlock FetchExternalAccessorBlock
dwPart := DBPART_VALUE or DBPART_STATUS or DBPART_LENGTH;
obStatus := FFetchBlockSize;
obValue := obStatus + OLE_DB_INDICATOR_SIZE;
obLength := obValue + cbMaxLen;
IncFetchBlockOffset(FFetchBlockSize, Field.DataType);
end;
dtFloat, dtBcd:
if (DBMSPrimaryVer = 3) and (TOLEDBFieldDesc(Field).OLEDBType = DBTYPE_NUMERIC) then begin
Assert(AccessorBlock.BlockType = abFetchBlock);
wType := DBTYPE_NUMERIC;
cbMaxLen := SizeOfTDBNumeric;
obStatus := FFetchBlockSize;
obValue := obStatus + OLE_DB_INDICATOR_SIZE;
IncFetchBlockOffset(FFetchBlockSize, Field.DataType);
end;
end;
end
else
begin
Assert(Field.DataType in [dtMemo, dtWideMemo, dtBlob, dtMSXML], 'Non-compartible values of Field.DataType and IsStreamUsed');
Obj.iid := IID_ISequentialStream;
Obj.dwFlags := STGM_READ;
l := sizeof(DBOBJECT);
pObject := Marshal.AllocHGlobal(l);
{$IFDEF CLR}
Marshal.StructureToPtr(TObject(Obj), pObject, False);
{$ELSE}
DBOBJECT(pObject^) := Obj;
{$ENDIF}
if not FReadOnly then begin
dwPart := DBPART_VALUE or DBPART_STATUS or DBPART_LENGTH;
obLength := obValue + sizeof(IntPtr);
end;
end;
if wType in [DBTYPE_NUMERIC, DBTYPE_VARNUMERIC] then begin
bPrecision := Field.Length;
bScale := Field.Scale;
end;
{OFS('---');
OFS('Field.Name = ' + Field.Name);
OFS('iOrdinal = ' + IntToStr(iOrdinal));
OFS('obValue = ' + IntToStr(obValue));
OFS('obLength = ' + IntToStr(obLength));
OFS('obStatus = ' + IntToStr(obStatus));
OFS('pTypeInfo = ' + IntToStr(Integer(pTypeInfo)));
//OFS('pObject = ' + IntToStr(Integer(pObject)));
OFS('pBindExt = ' + IntToStr(Integer(pBindExt)));
OFS('dwPart = ' + IntToStr(Integer(dwPart)));
//dwMemOwner: DBMEMOWNER;
//eParamIO: DBPARAMIO;
OFS('cbMaxLen = ' + IntToStr(cbMaxLen));
OFS('dwFlags = ' + IntToStr(dwFlags));
OFS('wType = ' + IntToStr(Integer(wType)));
OFS('bPrecision = ' + IntToStr(bPrecision));
OFS('bScale = ' + IntToStr(bScale));}
end;
//OFS('-FillBindingStructInAccBlock');
end;
var
i, j: integer;
rgStatus: PUINT;
rgBindings: TDBBindingArray;
{$IFDEF CLR}
rgBindingsGC: GCHandle;
{$ENDIF}
hr: HResult;
FieldCntAB: integer;
begin
rgStatus := nil;
FFetchBlock := nil;
FFetchBlockSize := 0;
UseIRowsetUpdate := (FCursorType in [ctKeyset, ctDynamic]) and FCursorUpdate;
QueryIntf(FIRowset, {$IFDEF CLR}IAccessor{$ELSE}IID_IAccessor{$ENDIF}, FFetchAccessorData.Accessor);
// Separate fields to AccessorBlocks
for i := 0 to Fields.Count - 1 do
if Fields[i].FieldDescKind = fdkData then
AddFieldToABList(i);
// CreateAccessors
for i := 0 to Length(FFetchAccessorData.AccessorBlocks) - 1 do begin
FieldCntAB := Length(FFetchAccessorData.AccessorBlocks[i].FieldNums);
try
rgStatus := Marshal.AllocHGlobal(FieldCntAB * SizeOf(UINT));
SetLength(rgBindings, FieldCntAB);
for j := 0 to FieldCntAB - 1 do
with rgBindings[j] do begin
{$IFDEF CLR}
if pTypeInfo <> nil then
Marshal.Release(pTypeInfo);
{$ELSE}
pTypeInfo := nil;
{$ENDIF}
pObject := nil;
pBindExt := nil;
end;
FillBindingStructInAccBlock(rgBindings, FFetchAccessorData.AccessorBlocks[i]);
// Create accessor
{$IFDEF CLR}
rgBindingsGC := GCHandle.Alloc(rgBindings, GCHandleType.Pinned);
try
hr := FFetchAccessorData.Accessor.CreateAccessor(DBACCESSOR_ROWDATA, FieldCntAB, Marshal.UnsafeAddrOfPinnedArrayElement(rgBindings, 0), 0, FFetchAccessorData.AccessorBlocks[i].hAcc, rgStatus);
finally
rgBindingsGC.Free;
end;
{$ELSE}
hr := FFetchAccessorData.Accessor.CreateAccessor(DBACCESSOR_ROWDATA, FieldCntAB, rgBindings, 0, FFetchAccessorData.AccessorBlocks[i].hAcc, rgStatus);
{$ENDIF}
Check(hr);
finally
if Length(rgBindings) <> 0 then begin
for j := 0 to FieldCntAB - 1 do
if rgBindings[j].pObject <> nil then
Marshal.FreeHGlobal(rgBindings[j].pObject);
SetLength(rgBindings, 0);
end;
if rgStatus <> nil then begin
Marshal.FreeHGlobal(rgStatus);
rgStatus := nil;
end;
end;
end;
if FFetchBlockSize <> 0 then
FFetchBlock := Marshal.AllocHGlobal(FFetchBlockSize);
end;
procedure TOLEDBRecordSet.FreeFetchBlock;
var
AccNum: integer;
begin
if FFetchAccessorData.Accessor = nil then
Exit;
with FFetchAccessorData do begin
for AccNum := 0 to Length(AccessorBlocks) - 1 do
Check(Accessor.ReleaseAccessor(AccessorBlocks[AccNum].hAcc, nil));
{$IFDEF CLR}
Marshal.ReleaseComObject(Accessor);
{$ENDIF}
Accessor := nil;
SetLength(AccessorBlocks, 0);
end;
if FFetchBlock <> nil then
Marshal.FreeHGlobal(FFetchBlock);
end;
function TOLEDBRecordSet.Fetch(FetchBack: boolean = False): boolean;
var
OldFetchFromBookmark: boolean;
procedure GetDataFromRow(const Row: hRow; const pRec: IntPtr);
procedure PrepareConvertableFields; // After get data from OLEDB
var
i: integer;
pValue: IntPtr;
OleDbBuf: IntPtr;
Field: TOLEDBFieldDesc;
{$IFDEF VER6P}
{$IFOPT C+}
FieldStatus: DWORD;
{$ENDIF}
{$IFDEF CLR}
BcdOut: TBcd;
g: TGuid;
p: IntPtr;
j: integer;
BcdBuf: TBytes;
s: string;
DBNum: TDBNumeric;
Data: TBytes;
{$ELSE}
FieldLength, FieldScale: word;
{$IFDEF VER9}
Delta: word;
{$ENDIF}
{$ENDIF}
Bcd: TBcd;
{$ENDIF}
DBTimeStamp: TDBTimeStamp;
dt: TDateTime;
d: double;
CurrTimestamp: Int64;
begin
for i := 0 to Fields.Count - 1 do begin
Field := TOLEDBFieldDesc(Fields[i]);
if Field.FieldDescKind <> fdkData then
SetNull(i + 1, pRec, True)
else
begin
pValue := IntPtr(Integer(pRec) + Field.Offset);
// Get max Timestamp value for RefreshQuick
if Field.IsTimestamp and (Field.TableInfo <> nil) then begin
{$IFDEF CLR}
SetLength(Data, SizeOf(Int64));
Marshal.Copy(pValue, Data, 0, SizeOf(Int64));
System.Array.Reverse(Data, 0, SizeOf(Int64));
CurrTimestamp := BitConverter.ToInt64(Data, 0);
{$ELSE}
CurrTimestamp := Marshal.ReadInt64(pValue);
Reverse8(@CurrTimestamp);
{$ENDIF}
if {$IFDEF VER7P}UInt64{$ENDIF}(TOLEDBTableInfo(Field.TableInfo).FMaxTimestamp) < {$IFDEF VER7P}UInt64{$ENDIF}(CurrTimestamp) then
TOLEDBTableInfo(Field.TableInfo).FMaxTimestamp := CurrTimestamp;
end;
OleDbBuf := nil;
try
case Field.DataType of
dtVarBytes:
Marshal.WriteInt16(pValue, SmallInt(UINT(Marshal.ReadInt32(pValue, sizeof(word) + Field.Length))));
{$IFDEF VER6P}
dtFmtBCD:
if not GetNull(i + 1, pRec) then begin
{$IFOPT C+}
FieldStatus := GetStatus(i, pRec);
Assert(FieldStatus = DBSTATUS_S_OK, Field.Name + ': FieldStatus = $' + IntToHex(FieldStatus, 8){ + ', Value = ' + Marshal.PtrToStringAnsi(pValue)});
{$ENDIF}
{$IFDEF CLR}
DBNum := TDBNumeric(Marshal.PtrToStructure(pValue, TypeOf(TDBNumeric)));
Bcd := DBNumericToBCD(DBNum);
NormalizeBcd(Bcd, BcdOut, Field.Length, Field.Scale);
// Copied from TBcd.ToBytes
SetLength(BcdBuf, 34);
BcdBuf[0] := BcdOut.Precision;
BcdBuf[1] := BcdOut.SignSpecialPlaces;
for j := 0 to 31 do
BcdBuf[j + 2] := BcdOut.Fraction[j];
Marshal.Copy(BcdBuf, 0, pValue, 34);
{$ELSE}
Bcd := DBNumericToBCD(TDBNumeric(pValue^));
FieldLength := Field.Length;
FieldScale := Field.Scale;
{$IFDEF VER9} // Delphi 9 NormalizeBcd Bug
Delta := FieldLength - FieldScale;
if Delta > 34 then begin
Delta := 34;
FieldLength := FieldScale + Delta;
end;
{$ENDIF}
NormalizeBcd(Bcd, PBcd(pValue)^, FieldLength, FieldScale);
{$ENDIF}
end;
{$ENDIF}
{$IFDEF VER5P}
dtGuid:
if not GetNull(i + 1, pRec) then
{$IFDEF CLR}
begin
g := TGUID(Marshal.PtrToStructure(pValue, TypeOf(TGUID)));
s := '{' + GUIDToString(g) + '}';
p := Marshal.StringToHGlobalAnsi(s);
try
StrLCopy(pValue, p, 38);
finally
Marshal.FreeHGlobal(p);
end;
end;
{$ELSE}
StrLCopy(pValue, @GUIDToString(PGUID(pValue)^)[1], 38);
{$ENDIF}
{$ENDIF}
dtDateTime:
if (Provider = prCompact) and (not GetNull(i + 1, pRec)) then begin
{$IFDEF CLR}
DBTimeStamp := TDBTimeStamp(Marshal.PtrToStructure(pValue, TypeOf(TDBTimeStamp)));
{$ELSE}
DBTimeStamp := PDBTimeStamp(pValue)^;
{$ENDIF}
dt := {$IFNDEF CLR}MemUtils.{$ENDIF}EncodeDateTime(DBTimeStamp.year, DBTimeStamp.month, DBTimeStamp.day, DBTimeStamp.hour, DBTimeStamp.minute, DBTimeStamp.second, DBTimeStamp.fraction div 1000000{Billionths of a second to milliseconds});
Marshal.WriteInt64(pValue, BitConverter.DoubleToInt64Bits(Double(dt)));
end;
dtCurrency:
if Provider = prCompact then begin
{$IFDEF CLR}
d := Marshal.ReadInt64(pValue);
d := d / 10000;
{$ELSE}
d := Currency(pValue^);
{$ENDIF}
Marshal.WriteInt64(pValue, BitConverter.DoubleToInt64Bits(d));
end;
dtFloat:
if (not GetNull(i + 1, pRec)) and (Provider = prCompact) then begin
if (Field.SubDataType and dtSingle) <> 0 then begin
{$IFDEF CLR}
BcdBuf := BitConverter.GetBytes(Marshal.ReadInt64(pValue));
d := BitConverter.ToSingle(BcdBuf, 0);
{$ELSE}
d := Single(pValue^);
{$ENDIF}
Marshal.WriteInt64(pValue, BitConverter.DoubleToInt64Bits(d));
end
end;
dtWord:
if (not GetNull(i + 1, pRec)) and (Provider = prCompact) and ((Field.SubDataType and dtUInt8) <> 0) then
Marshal.WriteByte(IntPtr(Integer(pValue) + 1), 0);
end;
finally
if OleDbBuf <> nil then
FreeCoMem(OleDbBuf);
end;
end;
end;
end;
procedure FetchPlainAccessorBlock(const AccessorBlock: TAccessorBlock);
var
hr: HResult;
Blob: TBlob;
Field: TFieldDesc;
pValue: IntPtr;
Length: integer;
begin
// Get data from IRowset
hr := FIRowset.GetData(Row, AccessorBlock.hAcc, pRec);
CheckAndAnalyzeFieldsStatus(hr, pRec);
// ConvertMemoToBlob;
if AccessorBlock.BlobFieldNum <> -1 then begin
Field := Fields[AccessorBlock.BlobFieldNum];
pValue := IntPtr(Integer(pRec) + Field.Offset);
Length := Marshal.ReadInt32(pRec, Field.Offset + SizeOf(IntPtr));
if FReadOnly then
Length := 0;
{$IFDEF HAVE_COMPRESS}
if Field.DataType = dtBlob then
Blob := TCompressedBlob.Create((Field.SubDataType and dtWide) <> 0)
else
{$ENDIF}
Blob := TBlob.Create((Field.SubDataType and dtWide) <> 0);
try
if (GetStatus(AccessorBlock.BlobFieldNum, pRec) <> DBSTATUS_S_ISNULL) then // Can't use GetNull->GetNullByBlob
ConvertStreamToBlob(pValue, Length, Blob{$IFDEF HAVE_COMPRESS}, FCommand.FCompressBlob{$ENDIF},
(Field is TOLEDBFieldDesc) and (TOLEDBFieldDesc(Field).OLEDBType = DBTYPE_XML));
finally
Marshal.WriteInt32(pValue, Integer(Blob.GCHandle));
end;
end;
end;
var
FetchBlockOffset: integer;
procedure FetchExternalAccessorBlock(const AccessorBlock: TAccessorBlock);
var
hr: HResult;
i, FieldNum: integer;
Status: DWORD;
Blob: TSharedObject;
pc: IntPtr;
pValue, pFetchBlockValue: IntPtr;
Field: TFieldDesc;
l: integer;
Size: word;
HeapBuf: IntPtr;
t: boolean;
DBNumeric: TDBNumeric;
d: double;
{$IFNDEF CLR}
c: currency;
{$ENDIF}
i64: Int64;
begin
Assert(AccessorBlock.BlobFieldNum = - 1);
// Get data from IRowset
hr := FIRowset.GetData(Row, AccessorBlock.hAcc, FFetchBlock);
// Copy status from external buf to pRec. Need to correct work CheckAndAnalyzeFieldsStatus
for i := 0 to Length(AccessorBlock.FieldNums) - 1 do begin
FieldNum := AccessorBlock.FieldNums[i];
Field := Fields[FieldNum];
if IsNeedFetchBlock(Field, ProviderPrimaryVer) and (Field.FieldDescKind = fdkData) then begin
Status := DWORD(Marshal.ReadInt32(FFetchBlock, FetchBlockOffset));
SetStatus(FieldNum, pRec, Status);
pFetchBlockValue := IntPtr(Integer(FFetchBlock) + FetchBlockOffset + OLE_DB_INDICATOR_SIZE);
pValue := IntPtr(Integer(pRec) + Field.Offset);
case Field.DataType of
dtExtString, dtExtWideString: begin
if GetNull(FieldNum + 1, pRec) then
Marshal.WriteIntPtr(pValue, nil)
else
begin
if Field.Fixed then
t := TrimFixedChar
else
t := TrimVarChar;
l := Marshal.ReadInt32(pFetchBlockValue);
pFetchBlockValue := IntPtr(Integer(pFetchBlockValue) + 4);
if Field.DataType = dtExtString then
Marshal.WriteIntPtr(pValue, StringHeap.AllocStr(pFetchBlockValue, t, l))
else
Marshal.WriteIntPtr(pValue, StringHeap.AllocWideStr(pFetchBlockValue, t, l div 2));
end;
end;
dtExtVarBytes:
if GetNull(FieldNum + 1, pRec) then
Marshal.WriteIntPtr(pValue, nil)
else
begin
Size := UINT(Marshal.ReadInt32(pFetchBlockValue, MaxNonBlobFieldLen));
HeapBuf := StringHeap.NewBuf(Size + sizeof(Word));
CopyBuffer(pFetchBlockValue, IntPtr(Integer(HeapBuf) + sizeof(Word)), Size);
Marshal.WriteIntPtr(pValue, HeapBuf);
Marshal.WriteInt16(HeapBuf, SmallInt(Word(Size)));
end;
dtMemo, dtWideMemo, dtMSXML: begin
Blob := TBlob.Create((Field.SubDataType and dtWide) <> 0);
if Status <> DBSTATUS_S_ISNULL then begin
pc := pFetchBlockValue;
if TBlob(Blob).IsUnicode then
l := integer(StrLenW(pc)) * integer(sizeof(WideChar)) // D2005 CLR bug
else
l := StrLen(pc);
if l > 0 then begin
TBlob(Blob).Write(0, l, pc);
TBlobUtils.SetModified(TBlob(Blob), False);
end;
end;
Marshal.WriteInt32(pValue, Integer(Blob.GCHandle));
end;
dtVariant: begin
Blob := TVariantObject.Create;
TVariantObject(Blob).Value := GetOleVariant(pFetchBlockValue);
OleVarClear(pFetchBlockValue);
Marshal.WriteInt32(pValue, Integer(Blob.GCHandle));
end;
dtFloat, dtBcd:
if not GetNull(FieldNum + 1, pRec) then begin
{$IFDEF CLR}
DBNumeric := TDBNumeric(Marshal.PtrToStructure(pFetchBlockValue, TypeOf(TDBNumeric)));
{$ELSE}
DBNumeric := TDBNumeric(pFetchBlockValue^);
{$ENDIF}
d := DBNumericToDouble(DBNumeric);
if Field.DataType = dtFloat then
Marshal.WriteInt64(pValue, BitConverter.DoubleToInt64Bits(d))
else begin
{$IFDEF CLR}
d := d * 10000;
i64 := Round(d);
{$ELSE}
c := d;
i64 := Int64((@c)^);
{$ENDIF}
Marshal.WriteInt64(pValue, i64);
end;
end;
else
Assert(False);
end;
IncFetchBlockOffset(FetchBlockOffset, Field.DataType);
Assert(FetchBlockOffset <= FFetchBlockSize);
end;
end;
CheckAndAnalyzeFieldsStatus(hr, pRec);
end;
var
AccNum: integer;
begin
FetchBlockOffset := 0;
for AccNum := 0 to Length(FFetchAccessorData.AccessorBlocks) - 1 do
if FFetchAccessorData.AccessorBlocks[AccNum].BlockType = abFetchBlock then
FetchExternalAccessorBlock(FFetchAccessorData.AccessorBlocks[AccNum])
else
FetchPlainAccessorBlock(FFetchAccessorData.AccessorBlocks[AccNum]);
PrepareConvertableFields;
end;
procedure CreateBlockStruct(const pHBlock: PBlockHeader; const RowsObtained: UINT);
var
pHItem: PItemHeader;
i: integer;
ui: UINT;
begin
// Create Items
pHItem := IntPtr(Integer(pHBlock) + sizeof(TBlockHeader));
if IntPtr(FirstItem) = nil then
FirstItem := pHItem;
if IntPtr(LastItem) = nil then begin
LastItem := pHItem;
pHItem.Order := 0;
end;
for i := 0 to RowsObtained - 1 do begin
pHItem.Prev := LastItem;
pHItem.Next := nil;
pHItem.Block := pHBlock;
pHItem.Flag := flUsed;
pHItem.Rollback := nil;
pHItem.Status := isUnmodified;
pHItem.UpdateResult := urNone;
pHItem.FilterResult := fsNotChecked;
LastItem.Next := pHItem;
if not (FCursorType in ServerCursorTypes) then
pHItem.Order := LastItem.Order + 1;
LastItem := pHItem;
UpdateCachedBuffer(pHItem, pHItem);
pHItem := IntPtr(Integer(pHItem) + sizeof(TItemHeader) + RecordSize);
end;
FirstItem.Prev := nil;
LastItem.Next := nil;
case FCursorType of
ctDefaultResultSet:
if Filtered and not FFetchAll then
InitFetchedItems(IntPtr(Integer(pHBlock) + sizeof(TBlockHeader)), False, FetchBack)
else
Inc(FRecordCount, RowsObtained);
ctStatic, ctKeySet:
begin
if FBookmarkOffset = - 1 then
FBookmarkOffset := sizeof(TBlockHeader) + sizeof(TItemHeader) + Fields[Fields.Count - 1].Offset;
LastItem.Order := Marshal.ReadInt32(IntPtr(pHBlock), FBookmarkOffset);
FBookmarkValue := LastItem.Order;
end;
ctDynamic:;
end;
// Free items
ui := UINT(FFetchRows) - RowsObtained;
if ui > 0 then
for i := 0 to ui - 1 do begin
pHItem.Prev := nil;
pHItem.Next := BlockMan.FirstFree;
pHItem.Block := pHBlock;
pHItem.Flag := flFree;
pHItem.Rollback := nil;
if IntPtr(BlockMan.FirstFree) <> nil then
BlockMan.FirstFree.Prev := pHItem;
BlockMan.FirstFree := pHItem;
pHItem := IntPtr(Integer(pHItem) + sizeof(TItemHeader) + RecordSize);
end;
pHBlock.UsedItems := RowsObtained;
end;
procedure InitBlock(pHBlock: PBlockHeader);
var
i, j: integer;
Ptr: IntPtr;
Field: TFieldDesc;
begin
if not HasComplexFields then
Exit;
// Create complex filds
for i := 0 to FFetchRows - 1 do begin
Ptr := IntPtr(Integer(pHBlock) + sizeof(TBlockHeader) + i * (RecordSize + sizeof(TItemHeader)) + sizeof(TItemHeader));
/// We does not need to call CreateComplexFields(Ptr, True) because (in difference with ODAC) we fetch BLOB(IStream) IntPtrs directly to RecBuf
for j := 0 to FieldCount - 1 do begin
Field := Fields[j];
if Field.FieldDescKind <> fdkCalculated then
case Field.DataType of
dtBlob, dtMemo, dtWideMemo, dtMSXML, dtVariant, dtExtString, dtExtWideString, dtExtVarBytes:
Marshal.WriteIntPtr(Ptr, Field.Offset, nil);
end;
end;
end;
end;
procedure ClearBlock(pHBlock: PBlockHeader);
var
i: integer;
Free: PItemHeader;
begin
if IntPtr(pHBlock) = nil then
Exit;
// Free complex filds
Free := IntPtr(Integer(pHBlock) + sizeof(TBlockHeader));
for i := 1 to pHBlock.ItemCount do begin
if HasComplexFields and (Free.Flag <> flFree) then
FreeComplexFields(IntPtr(Integer(Free) + sizeof(TItemHeader)), True);
Free := IntPtr(Integer(Free) + sizeof(TItemHeader) + RecordSize);
end;
end;
function GetRowsFromOLEDB(var RowsObtained: UINT; prghRows: PUintArray): HResult;
var
RowsOffset, RowsRequested: integer;
{$IFDEF CLR}
p: IntPtr;
{$ENDIF}
begin
// Backward fetch processing
if FetchBack then
RowsRequested := - FFetchRows
else
RowsRequested := FFetchRows;
RowsOffset := 0;
// Get data from OLEDB
if (FCursorType in [ctKeyset, ctStatic]) then begin
if not FFetchFromBookmark then
if FetchBack then
RowsOffset := - 1
else
RowsOffset := + 1;
Assert(FIRowsetLocate <> nil);
/// FIRowsetLocate.GetRowsAt does not change current IRowset fetch position
{$IFDEF CLR}
p := Marshal.AllocHGlobal(SizeOf(Integer));
try
Marshal.WriteInt32(p, FBookmarkValue);
Result := FIRowsetLocate.GetRowsAt(0, DB_NULL_HCHAPTER, FBookmarkSize, p, RowsOffset, RowsRequested, RowsObtained, prghRows);
finally
Marshal.FreeHGlobal(p);
end;
{$ELSE}
Result := FIRowsetLocate.GetRowsAt(0, DB_NULL_HCHAPTER, FBookmarkSize, @FBookmarkValue, RowsOffset, RowsRequested, RowsObtained, prghRows);
{$ENDIF}
end
else
begin
if (FCursorType = ctDynamic) then begin
if FLastFetchOK then begin
if FFetchFromBookmark then begin // Reread previous readed row
if FLastFetchBack = FetchBack then begin
if FetchBack then
RowsOffset := + 1
else
RowsOffset := - 1;
end;
end
else
if FLastFetchBack <> FetchBack then
if FetchBack then
RowsOffset := - 1
else
RowsOffset := + 1;
end
else
if FLastFetchBack = FetchBack then
if FetchBack then
RowsOffset := + 1
else
RowsOffset := - 1;
end;
Result := FIRowset.GetNextRows(DB_NULL_HCHAPTER, RowsOffset, RowsRequested, RowsObtained, prghRows);
end;
FLastFetchBack := FetchBack;
FFetchFromBookmark := False; // Clear flag, setted on InternalOpen
end;
procedure ProcessNoResult;
begin
case FCursorType of
ctDefaultResultSet:
ReleaseAllInterfaces(False); // Process parameters
ctStatic:
begin
Assert(not FFetchFromBookmark, 'Cannot fetch to bookmark with Static cursor type');
if not OldFetchFromBookmark {to prevent recursion on empty resultset} then
FetchToBookmarkValue;
end;
ctKeySet:
begin
if FCursorUpdate then
Assert(not FFetchFromBookmark, 'Cannot fetch to bookmark with KeySet cursor type');
{ else
FBookmarkValue := - 1;}
end;
ctDynamic:
begin
CurrentItem := nil; // FHRow is not accessible and we need to refetch data from server
if not FProcessDynBofEof then begin
try
FProcessDynBofEof := True;
if FetchBack then begin
FBof := True;
// Server cursor position is under first row, FHRow is not accessible
// Need to call GetNextRows with params (RowsOffset = 1, RowsRequested = - 1)
FLastFetchOK := True;
if not FetchToBookmarkValue(True) then
FEof := True;
end
else
begin
FEof := True;
// Server cursor position is below last row, FHRow is not accessible
// Need to call GetNextRows with params (RowsOffset = - 1, RowsRequested = 1)
FLastFetchOK := True;
if not FetchToBookmarkValue then
FBof := True;
end;
if not FLastFetchOK then begin
FLastFetchOK := True;
FLastFetchBack := False;
end;
finally
FProcessDynBofEof := False;
end;
if FBof or FEof then
CurrentItem := nil;
end;
end;
end;
end;
procedure FirstFetch;
var
Field: TOLEDBFieldDesc;
i: integer;
begin
// This is a first call to Fetch.
// Query interfaces, create accessors etc
Assert(FCommand.GetCursorState >= csExecuted);
if FCommand.GetCursorState = csExecuted then
FCommand.SetCursorState(csFetching);
QueryRecordSetInterfaces;
AllocFetchBlock;
if FCursorType in [ctStatic, ctKeySet] then begin
// Setting FRecordCount for ctStatic, ctKeySet
SetToEnd;
if IntPtr(LastItem) <> nil then begin
FRecordCount := LastItem.Order;
SetToBegin;
end;
FFetchFromBookmark := FCursorType in [ctKeyset, ctStatic]; /// First record reading without offsetting
end;
FBookmarkValue := DBBMK_FIRST;
FBookmarkSize := sizeof(FBookmarkValue);
// Clear MaxTimestamp for RefreshQuick
for i := 0 to Fields.Count - 1 do begin
Field := TOLEDBFieldDesc(Fields[i]);
if Field.IsTimestamp and (Field.TableInfo <> nil) then
TOLEDBTableInfo(Field.TableInfo).FMaxTimestamp := 0;
end;
end;
var
pHBlock: PBlockHeader;
NewBlock: boolean;
hr: HResult;
RowsObtained: UINT;
rghRows: TUintArray;
prghRows: PUintArray;
GCHandle: IntPtr;
i: integer;
pRec, pData: IntPtr;
Cancel: boolean;
IsThisFirstFetch: boolean;
InThread: boolean;
begin
Result := False;
Assert(FCommand <> nil);
{$IFDEF CLR}
InThread := FCommand.FNonBlocking and (FFetchExecutor <> nil) and (Thread.CurrentThread = FFetchExecutor.Thread.Handle);
{$ELSE}
InThread := FCommand.FNonBlocking and (FFetchExecutor <> nil) and (GetCurrentThreadId = FFetchExecutor.Thread.ThreadID);
{$ENDIF}
try
if Fields.Count = 0 then
DatabaseError(SNoResultSet, nil); /// Warning - constant SNoResultSet used for detecting in TCustomMSDataSet.OpenNext
IsThisFirstFetch :=
((FCommand.FIUnknown <> nil) or not FNativeRowset)
and (Length(FFetchAccessorData.AccessorBlocks) = 0);
try
if IsThisFirstFetch then
FirstFetch; // This is a first call to Fetch. FIUnknown tested for prevent recreating accessors after fetching all strings
DoBeforeFetch(Cancel);
if Cancel or FWaitForFetchBreak then
Exit;
if FIRowset = nil then
begin
Result := False;
Exit;
end;
if (FCursorType = ctKeySet) and not FCursorUpdate and (FBookmarkValue = - 1) then
begin
Result := False;
Exit;
end;
OldFetchFromBookmark := FFetchFromBookmark;
// Clear previous obtained rows
ClearHRowIfNeed;
Assert(not FHRowAccessible);
pHBlock := nil;
GCHandle := nil;
prghRows := nil;
RowsObtained := 0;
SetLength(rghRows, FFetchRows);
try
// Get next rows
GCHandle := AllocGCHandle(rghRows, True);
prghRows := GetAddrOfPinnedObject(GCHandle);
// prghRows := @rghRows[0];
if FLastFetchEnd then
RowsObtained := 0
else
begin
hr := GetRowsFromOLEDB(RowsObtained, prghRows);
FLastFetchEnd := FNativeRowset and (FCursorType = ctDefaultResultSet) and (hr = DB_S_ENDOFROWSET); // CR10007
// Process rows
if (hr <> DB_S_ENDOFROWSET)
and (hr <> DB_S_ROWLIMITEXCEEDED)
and not ((hr = DB_E_BADBOOKMARK) and (FBookmarkValue = DBBMK_FIRST))
and not ((hr = DB_E_BADSTARTPOSITION) and (ProviderPrimaryVer = 7))then
Check(hr);
end;
if RowsObtained > 0 then begin
NewBlock := (IntPtr(BlockMan.FirstBlock) = nil) or (not FUniDirectional and not (FCursorType in ServerCursorTypes));
if NewBlock then
BlockMan.AllocBlock(pHBlock, FFetchRows)
else begin
pHBlock := BlockMan.FirstBlock;
// Refresh block: drop values of blobs
ClearBlock(pHBlock);
end;
InitBlock(pHBlock);
pRec := IntPtr(Integer(pHBlock) + sizeof(TBlockHeader) + sizeof(TItemHeader));
for i := 0 to RowsObtained - 1 do
begin
pData := IntPtr(Integer(pRec) + i * (RecordSize + sizeof(TItemHeader)));
GetDataFromRow(rghRows[i], pData);
end;
end;
finally
FreeGCHandle(GCHandle);
if RowsObtained > 0 then begin
// Release row handle(s) if need
if FCursorType in ServerCursorTypes then begin
Assert(RowsObtained = 1);
FHRow := rghRows[0];
FHRowAccessible := True;
end
else
Check(FIRowset.ReleaseRows(RowsObtained, prghRows, nil, nil, nil));
end;
if Length(rghRows) <> 0 then
SetLength(rghRows, 0);
end;
Result := RowsObtained > 0;
FLastFetchOK := Result;
if IntPtr(pHBlock) <> nil then begin
if Result then
CreateBlockStruct(pHBlock, RowsObtained)
else
BlockMan.FreeBlock(pHBlock);
end;
if FNativeRowset and not Result then
ProcessNoResult;
Assert(not (FCursorType in [ctDynamic]{ServerCursorTypes}) or FProcessDynBofEof or (FHRowAccessible or (FBOF and FEOF)), 'Row must be accessible after Fetch for non-empty dataset with server cursor');
except
on e: exception do begin
if FetchBack then
FBOF := True
else
FEOF := True;
ClearBlock(pHBlock);
FreeFetchBlock;
ReleaseRecordSetInterfaces;
raise;
end;
end;
finally
if Assigned(FOnAfterFetch) then
if InThread and FAfterFetch then
FFetchExecutor.Thread.SendEvent(TObject(FE_AFTERFETCH))
else
DoAfterFetch;
end;
end;
function TOLEDBRecordSet.GetProp(Prop: integer; var Value: variant): boolean;
begin
Result := True;
case Prop of
prReadOnly:
Value := FReadOnly;
prEnableBCD:
Value := FEnableBCD;
{$IFDEF VER6P}
prEnableFMTBCD:
Value := FEnableFMTBCD;
{$ENDIF}
prUniqueRecords:
Value := FUniqueRecords;
prCursorType:
Value := Integer(TMSCursorType(FCursorType));
prCursorUpdate:
Value := FCursorUpdate;
prLockClearMultipleResults:
Value := FLockClearMultipleResults;
prIsSProc:
FCommand.GetProp(prIsSProc, Value);
prNonBlocking:
FCommand.GetProp(prNonBlocking, Value);
{ prBeforeFetch:
Value := FBeforeFetch;
prAfterFetch:
Value := FAfterFetch;}
else
Result := inherited GetProp(Prop, Value);
end;
end;
function TOLEDBRecordSet.SetProp(Prop: integer; const Value: variant): boolean;
begin
Result := True;
case Prop of
prReadOnly:
FReadOnly := Value;
prCommandTimeout:
begin
Assert(FCommand <> nil);
FCommand.FCommandTimeout := Value;
end;
prEnableBCD:
FEnableBCD := Value;
{$IFDEF VER6P}
prEnableFMTBCD:
FEnableFMTBCD := Value;
{$ENDIF}
prUniqueRecords:
FUniqueRecords := Value;
prCursorType:
begin
FCursorType := TMSCursorType(Integer(Value));
if FCursorType in ServerCursorTypes then
FFetchAll := False;
end;
prRequestSQLObjects:
FRequestSQLObjects := Value;
prCursorUpdate:
FCursorUpdate := Value;
prLockClearMultipleResults:
FLockClearMultipleResults := Value;
prRoAfterUpdate:
FroAfterUpdate := Value;
prWideStrings:
FWideStrings := Value;
prIsSProc:
FCommand.SetProp(prIsSProc, Value);
prSmartRefresh:
FCommand.SetProp(prSmartRefresh, Value);
prSmartRefreshMsg:
FCommand.SetProp(prSmartRefreshMsg, Value);
prSmartRefreshService:
FCommand.SetProp(prSmartRefreshService, Value);
prNonBlocking:
FCommand.SetProp(prNonBlocking, Value);
{ prBeforeFetch:
FBeforeFetch := Boolean(Value);
prAfterFetch:
FAfterFetch := Boolean(Value);}
else
Result := inherited SetProp(Prop, Value);
end;
end;
{ TOLEDBProperties }
{ TOLEDBPropertiesSet }
const
MaxPropCount = 20;
constructor TOLEDBPropertiesSet.Create(Connection: TOLEDBConnection; const GuidPropertySet: TGUID);
begin
inherited Create;
FConnection := Connection;
FInitPropSet := Marshal.AllocHGlobal(SizeOf(DBPROPSET));
FInitPropSet.cProperties := 0;
FInitPropSet.guidPropertySet := GuidPropertySet;
FInitPropSet.rgProperties := nil;
FInitPropSet.rgProperties := Marshal.AllocHGlobal(MaxPropCount * SizeOfDBProp);
FillChar(FInitPropSet.rgProperties, MaxPropCount * SizeOfDBProp, 0);
end;
destructor TOLEDBPropertiesSet.Destroy;
var
i: integer;
rgProperty: PDBProp;
begin
if IntPtr(FInitPropSet) <> nil then begin
if FInitPropSet.rgProperties <> nil then begin
for i := 0 to Integer(FInitPropSet.cProperties) - 1 do begin
rgProperty := GetDBPropPtr(i);
rgProperty.vValue := Unassigned;
end;
Marshal.FreeHGlobal(FInitPropSet.rgProperties);
end;
Marshal.FreeHGlobal(FInitPropSet);
end;
inherited;
end;
procedure TOLEDBPropertiesSet.Check(const Status: HRESULT);
begin
try
FConnection.Check(Status, nil);
except
on E: Exception do begin
AddInfoToErr(E, GetInitPropSetStatus, []);
raise E;
end;
end;
end;
function TOLEDBPropertiesSet.GetInitPropSetStatus: string;
var
i: integer;
p: PDBProp;
begin
Result := GUIDToString(FInitPropSet.guidPropertySet);
for i := 0 to FInitPropSet.cProperties - 1 do begin
p := GetDBPropPtr(i);
if p.dwStatus <> 0 then
Result := Format('%s'#$D#$A'[%d] := $%X. PropId := %d', [Result, i, p.dwStatus, p.dwPropertyID]);
end;
end;
function TOLEDBPropertiesSet.GetDBPropPtr(Index: UINT): PDBProp;
begin
Assert(Index <= FInitPropSet.cProperties);
Result := IntPtr(Integer(FInitPropSet.rgProperties) + Integer(Index * SizeOfDBProp));
end;
function TOLEDBPropertiesSet.InitProp(const dwPropertyID: DBPROPID; const Required: boolean = False): PDBProp;
begin
Assert(FInitPropSet.cProperties <= MaxPropCount);
Result := GetDBPropPtr(FInitPropSet.cProperties);
Result.dwPropertyID := dwPropertyID;
if Required then
Result.dwOptions := DBPROPOPTIONS_REQUIRED
else
Result.dwOptions := DBPROPOPTIONS_OPTIONAL;
Result.colid := DB_NULLID;
end;
procedure TOLEDBPropertiesSet.AddPropSmallInt(const dwPropertyID: DBPROPID; const Value: Smallint);
var
p: PDBProp;
begin
p := InitProp(dwPropertyID);
p.vValue := VarAsType(Value, VT_I2);
FInitPropSet.cProperties := FInitPropSet.cProperties + 1;
end;
procedure TOLEDBPropertiesSet.AddPropInt(const dwPropertyID: DBPROPID; const Value: Integer);
var
p: PDBProp;
begin
p := InitProp(dwPropertyID, True);
p.vValue := VarAsType(Value, VT_I4);
FInitPropSet.cProperties := FInitPropSet.cProperties + 1;
end;
procedure TOLEDBPropertiesSet.AddPropBool(const dwPropertyID: DBPROPID; const Value: boolean; const Required: boolean = False);
var
p: PDBProp;
begin
p := InitProp(dwPropertyID, Required);
p.vValue := VarAsType(Value, VT_BOOL);
FInitPropSet.cProperties := FInitPropSet.cProperties + 1;
end;
procedure TOLEDBPropertiesSet.AddPropStr(const dwPropertyID: DBPROPID; const Value: string; const Required: boolean = False);
var
p: PDBProp;
begin
p := InitProp(dwPropertyID, Required);
p.vValue := Value;
FInitPropSet.cProperties := FInitPropSet.cProperties + 1;
end;
procedure TOLEDBPropertiesSet.SetProperties(Obj: IDBProperties);
begin
Assert(Obj <> nil);
Check(Obj.SetProperties(1, PDBPropSetArray(FInitPropSet)));
end;
procedure TOLEDBPropertiesSet.SetProperties(Obj: ISessionProperties);
begin
Assert(Obj <> nil);
Check(Obj.SetProperties(1, PDBPropSetArray(FInitPropSet)));
end;
procedure TOLEDBPropertiesSet.SetProperties(Obj: ICommandProperties);
begin
Assert(Obj <> nil);
Check(Obj.SetProperties(1, PDBPropSetArray(FInitPropSet)));
end;
{ TOLEDBPropertiesGet }
constructor TOLEDBPropertiesGet.Create(Connection: TOLEDBConnection; const GuidPropertySet: TGUID);
begin
inherited Create;
FConnection := Connection;
FInitPropSet := Marshal.AllocHGlobal(SizeOf(DBPROPSET));
FInitPropSet.cProperties := 0;
FInitPropSet.rgProperties := nil;
FInitPropSet.guidPropertySet := GuidPropertySet;
end;
destructor TOLEDBPropertiesGet.Destroy;
begin
Marshal.FreeHGlobal(FInitPropSet);
inherited;
end;
procedure TOLEDBPropertiesGet.AddPropId(Id: DBPROPID);
begin
Assert(FPropIdsGC = nil);
SetLength(FPropIds, Length(FPropIds) + 1);
FPropIds[Length(FPropIds) - 1] := Id;
end;
procedure TOLEDBPropertiesGet.Check(const Status: HRESULT);
begin
FConnection.Check(Status, nil);
end;
function TOLEDBPropertiesGet.GetDBPropPtr(rgProperties: PDBPropArray; Index: UINT): PDBProp;
begin
Assert(Index <= FInitPropSet.cProperties);
Result := IntPtr(Integer(rgProperties) + Integer(Index * SizeOfDBProp));
end;
procedure TOLEDBPropertiesGet.PrepareToGet;
begin
FPropIdsGC := AllocGCHandle(FPropIds, True);
FInitPropSet.rgProperties := GetAddrOfPinnedObject(FPropIdsGC);
FInitPropSet.cProperties := Length(FPropIds);
end;
procedure TOLEDBPropertiesGet.ProcessResult(rgPropertySets: PDBPropSet; var PropValues: TPropValues);
var
i: integer;
begin
SetLength(PropValues, FInitPropSet.cProperties);
for i := 0 to FInitPropSet.cProperties - 1 do
PropValues[i] := GetDBPropPtr(rgPropertySets.rgProperties, i).vValue;
end;
procedure TOLEDBPropertiesGet.ClearResult(rgPropertySets: PDBPropSet);
var
i: integer;
begin
FreeGCHandle(FPropIdsGC);
FPropIdsGC := nil;
FInitPropSet.rgProperties := nil;
for i := 0 to FInitPropSet.cProperties - 1 do
GetDBPropPtr(rgPropertySets.rgProperties, i).vValue := Unassigned;
FreeCoMem(rgPropertySets.rgProperties);
FreeCoMem(rgPropertySets);
//FConnection.Malloc.Free(rgPropertySets.rgProperties);
//FConnection.Malloc.Free(rgPropertySets);
end;
procedure TOLEDBPropertiesGet.GetProperties(Obj: IDBProperties; var PropValues: TPropValues);
var
cPropertySets: UINT;
rgPropertySets: PDBPropSet;
begin
Assert(Obj <> nil);
PrepareToGet;
try
Check(Obj.GetProperties(1, PDBPropIDSetArray(FInitPropSet), cPropertySets, rgPropertySets));
ProcessResult(rgPropertySets, PropValues);
finally
ClearResult(rgPropertySets);
end;
end;
procedure TOLEDBPropertiesGet.GetProperties(Obj: IRowsetInfo; var PropValues: TPropValues);
var
cPropertySets: UINT;
rgPropertySets: PDBPropSet;
begin
Assert(Obj <> nil);
PrepareToGet;
try
Check(Obj.GetProperties(1, PDBPropIDSetArray(FInitPropSet), cPropertySets, rgPropertySets));
ProcessResult(rgPropertySets, PropValues);
finally
ClearResult(rgPropertySets);
end;
end;
procedure TOLEDBPropertiesGet.GetProperties(Obj: ICommandProperties; var PropValues: TPropValues);
var
cPropertySets: UINT;
rgPropertySets: PDBPropSet;
begin
Assert(Obj <> nil);
PrepareToGet;
try
Check(Obj.GetProperties(1, PDBPropIDSetArray(FInitPropSet), cPropertySets, rgPropertySets));
ProcessResult(rgPropertySets, PropValues);
finally
ClearResult(rgPropertySets);
end;
end;
{ TOLEDBErrors }
constructor TOLEDBErrors.Create;
begin
inherited;
FList := TList.Create;
end;
destructor TOLEDBErrors.Destroy;
begin
Clear;
FList.Free;
inherited;
end;
procedure TOLEDBErrors.Clear;
var
i: integer;
begin
for i := 0 to FList.Count - 1 do
TObject(FList[i]).Free;
FList.Clear;
end;
function TOLEDBErrors.GetCount: integer;
begin
Result := FList.Count;
end;
function TOLEDBErrors.GetError(Index: Integer): EOLEDBError;
begin
Result := EOLEDBError(FList[Index]);
end;
procedure TOLEDBErrors.Assign(Source: TOLEDBErrors);
var
i: integer;
SrcErr, DstErr: EOLEDBError;
begin
Clear;
for i := 0 to Source.Count - 1 do begin
SrcErr := Source.Errors[i];
DstErr := nil;
if SrcErr is EMSError then
DstErr := EMSError.Create(SrcErr.ErrorCode, SrcErr.Message)
else
if SrcErr is EOLEDBError then
DstErr := EOLEDBError.Create(SrcErr.ErrorCode, SrcErr.Message)
else
Assert(False);
DstErr.Assign(SrcErr);
FList.Add(DstErr);
end;
end;
{ EOLEDBError }
constructor EOLEDBError.Create(ErrorCode: integer; Msg: WideString);
begin
{$IFDEF LITE}
inherited Create(Msg);
FErrorCode := ErrorCode;
Message := Msg;
{$ELSE}
inherited Create(ErrorCode, Msg);
{$ENDIF}
FMessageWide := Msg;
FErrors := TOLEDBErrors.Create;
end;
destructor EOLEDBError.Destroy;
begin
FErrors.Free;
inherited;
end;
function EOLEDBError.GetErrorCount: integer;
begin
Result := FErrors.Count;
end;
function EOLEDBError.GetError(Index: Integer): EOLEDBError;
begin
Result := FErrors[Index];
end;
procedure EOLEDBError.Assign(Source: EOLEDBError);
begin
FOLEDBErrorCode := Source.FOLEDBErrorCode;
Fiid := Source.Fiid;
{$IFNDEF LITE}
Component := Source.Component;
{$ENDIF}
FErrors.Assign(Source.FErrors);
end;
{ EMSError }
constructor EMSError.Create(const pServerErrorInfo: SSERRORINFO; OLEDBErrorCode: integer; Msg: WideString);
begin
inherited Create(pServerErrorInfo.lNative, Msg);
{$IFDEF LITE}
FErrorCode := pServerErrorInfo.lNative;
{$ENDIF}
FMSSQLErrorCode := pServerErrorInfo.lNative;
FServerName := pServerErrorInfo.pwszServer;
FProcName := pServerErrorInfo.pwszProcedure;
FState := pServerErrorInfo.bState;
FSeverityClass := pServerErrorInfo.bClass;
FLineNumber := pServerErrorInfo.wLineNumber;
FLastMessage := pServerErrorInfo.pwszMessage;
end;
procedure EMSError.Assign(Source: EOLEDBError);
var
Src: EMSError;
begin
inherited;
if Source is EMSError then begin
Src := EMSError(Source);
FMSSQLErrorCode := Src.FMSSQLErrorCode;
FServerName := Src.ServerName;
FProcName := Src.ProcName;
FState := Src.State;
FSeverityClass := Src.SeverityClass;
FLineNumber := Src.LineNumber;
FLastMessage := Src.LastMessage;
end;
end;
var
DataSourceTypes: TBytes;
{$IFDEF CLR}
DataSourceTypesGC: GCHandle;
{$ENDIF}
procedure InitDataSourceTypes;
var
pDataSourceTypes: IntPtr;
byteIndex: integer;
function AddType(const TypeName: WideString): IntPtr;
var
Cnt: integer;
begin
Result := IntPtr(Integer(pDataSourceTypes) + byteIndex);
Cnt := Encoding.Unicode.{$IFNDEF VER5}GetBytes{$ELSE}GetBytesWide{$ENDIF}(TypeName, 0, Length(TypeName), DataSourceTypes, byteIndex);
DataSourceTypes[byteIndex + Cnt] := 0;
DataSourceTypes[byteIndex + Cnt + 1] := 0;
byteIndex := byteIndex + Cnt + 2;
Assert(byteIndex + Cnt < Length(DataSourceTypes));
end;
begin
//SetLength(DataSourceTypes, 300);
SetLength(DataSourceTypes, 350);
{$IFDEF CLR}
DataSourceTypesGC := GCHandle.Alloc(DataSourceTypes, GCHandleType.Pinned);
pDataSourceTypes := Marshal.UnsafeAddrOfPinnedArrayElement(DataSourceTypes, 0);
{$ELSE}
pDataSourceTypes := @DataSourceTypes[0];
{$ENDIF}
byteIndex := 0;
dstSmallint := AddType('smallint');
dstInt := AddType('int');
dstReal := AddType('real');
dstFloat := AddType('float');
dstMoney := AddType('money');
dstDateTime := AddType('datetime');
dstNVarChar := AddType('nvarchar');
dstNVarCharMax := AddType('nvarchar(max)');
dstVarChar := AddType('varchar');
dstVarCharMax := AddType('varchar(max)');
dstBit := AddType('bit');
dstTinyInt := AddType('tinyint');
dstBigint := AddType('bigint');
dstSql_variant := AddType('sql_variant');
dstImage := AddType('image');
dstBinary := AddType('binary');
dstVarBinary := AddType('varbinary');
dstGuid := AddType('uniqueidentifier');
end;
procedure FinalizeDataSourceTypes;
begin
{$IFDEF CLR}
if IntPtr(DataSourceTypesGC) <> nil then
DataSourceTypesGC.Free;
{$ENDIF}
end;
var
OSVersionInfo: TOSVersionInfo;
initialization
__UseRPCCallStyle := True;
InitDataSourceTypes;
ParamsInfoOldBehavior := False; // delete 03.06.2006
// Windows Vista detecting
OSVersionInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
Windows.GetVersionEx(OSVersionInfo);
IsWindowsVista := OSVersionInfo.dwMajorVersion = 6;
finalization
{$IFDEF DEBUG} if StreamCnt <> 0 then MessageBox(0, PChar(IntToStr(StreamCnt) + ' Stream(s) hasn''t been released'), 'DA warning', MB_OK); {$ENDIF}
FinalizeDataSourceTypes;
{$IFNDEF CLR}
GlobaIMalloc := nil;
{$ENDIF}
end.
Reference in New Issue View Git Blame Copy Permalink