sdoledb.pas

SQLDirect Component Library is a light-weight Borland Database Engine replacement for Borland Delphi

    procedure DoExecute; override;
    procedure DoExecDirect(ACommandValue: string); override;
    procedure DoPrepare(Value: string); override;

    procedure GetFieldDescs(Descs: TSDFieldDescList); override;
    procedure InitParamList; override;

    function FieldDataType(ExtDataType: Integer): TFieldType; override;
    function NativeDataSize(FieldType: TFieldType): Word; override;
    function NativeDataType(FieldType: TFieldType): Integer; override;
    function RequiredCnvtFieldType(FieldType: TFieldType): Boolean; override;

    function GetHandle: PSDCursor; override;
  public
    constructor Create(ASqlDatabase: TISqlDatabase); override;
	// command interface
    procedure CloseResultSet; override;
    procedure Disconnect(Force: Boolean); override;
    procedure Execute; override;
    function GetRowsAffected: Integer; override;
    function NextResultSet: Boolean; override;
    function ResultSetExists: Boolean; override;
	// cursor interface
    function FetchNextRow: Boolean; override;
    function GetCnvtFieldData(AFieldDesc: TSDFieldDesc; Buffer: TSDPtr; BufSize: Integer): Boolean; override;
    procedure GetOutputParams; override;

    function ReadBlob(AFieldDesc: TSDFieldDesc; var BlobData: TSDBlobData): Longint; override;

    property IsSrvCursor: Boolean read FIsSrvCursor;
    property SqlDatabase: TIOleDbDatabase read GetSqlDatabase;
  end;

{ TIOleDbSchemaCommand }
  TIOleDbSchemaCommand = class(TIOleDbCommand)
  protected
    FObjPattern: string;
    FSchemaRowsetGUID: TGUID;
    FRestrictions: PVariantArg;
    FRestrictCount: Integer;
    procedure CreateRestrictions; virtual; abstract;
    procedure DestroyRestrictions;
    procedure DoExecute; override;
    procedure DoExecDirect(Value: string); override;
    procedure DoPrepare(Value: string); override;
  public
    constructor Create(ASqlDatabase: TISqlDatabase); override;
    destructor Destroy; override;
    property ObjPattern: string read FObjPattern write FObjPattern;
    property SchemaRowsetGUID: TGUID read FSchemaRowsetGUID;
  end;

  TIOleDbSchemaTables = class(TIOleDbSchemaCommand)
  private
    FSysTables: Boolean;
    FSchName,
    FTblName: string;   // this can be used in FetchNextRow like wildcards
  protected
    procedure CreateRestrictions; override;
    procedure GetFieldDescs(Descs: TSDFieldDescList); override;
  public
    constructor Create(ASqlDatabase: TISqlDatabase); override;
    function FetchNextRow: Boolean; override;
    property SysTables: Boolean read FSysTables write FSysTables;
  end;

  TIOleDbSchemaColumns = class(TIOleDbSchemaCommand)
  private
    FColTypeFieldIdx,
    FColTypeNameLen,
    FColTypeNameFieldIdx: Integer;
    function GetDataTypeName(const TypeInd: Integer): string;
  protected
    procedure CreateRestrictions; override;
    procedure GetFieldDescs(Descs: TSDFieldDescList); override;
  public
    constructor Create(ASqlDatabase: TISqlDatabase); override;
    function FetchNextRow: Boolean; override;
  end;

  TIOleDbSchemaIndexes = class(TIOleDbSchemaCommand)
  private
    FIdxTypeFieldIdx,
    FIdxSortFieldIdx: Integer;
  protected
    procedure CreateRestrictions; override;
    procedure GetFieldDescs(Descs: TSDFieldDescList); override;
  public
    constructor Create(ASqlDatabase: TISqlDatabase); override;
    function FetchNextRow: Boolean; override;
  end;

  TIOleDbSchemaProcs = class(TIOleDbSchemaCommand)
  private
    FInParamsFieldIdx,
    FOutParamsFieldIdx: Integer;
  protected
    procedure CreateRestrictions; override;
    procedure GetFieldDescs(Descs: TSDFieldDescList); override;
  public
    constructor Create(ASqlDatabase: TISqlDatabase); override;
    function FetchNextRow: Boolean; override;
  end;

  TIOleDbSchemaProcParams = class(TIOleDbSchemaCommand)
  protected
    procedure CreateRestrictions; override;
  public
    constructor Create(ASqlDatabase: TISqlDatabase); override;
  end;

const
  DefSqlApiDLL	= '';

var
  SqlApiDLL: string;

{*******************************************************************************
		Load/Unload Sql-library
*******************************************************************************}
procedure LoadSqlLib;
procedure FreeSqlLib;

function InitSqlDatabase(ADbParams: TStrings): TISqlDatabase;

implementation

const
  SCantConvertFieldValueFmt     = 'Cannot convert value of field ''%s''';
  SErrErrorNotFound             = 'The system cannot find message for error number $';
  SErrDBPropsNotSupported       = 'Provider not support some database parameters';

  SSchemaGuidNotSupported       = 'Schema GUID %s not supported';

        // keywords of OLEDB connection string
  CT_PROVIDER   = 'PROVIDER=';          { Do not localize }
  CT_DATASOURCE = 'DATA SOURCE=';        { Do not localize }
  CT_INITCATALOG= 'INITIAL CATALOG=';   { Do not localize }
  CT_USERID     = 'USER ID=';           { Do not localize }
  CT_PASSWORD   = 'PASSWORD=';          { Do not localize }
  CT_USERID2    = 'UID=';               { Do not localize }
  CT_PASSWORD2  = 'PWD=';               { Do not localize }

  CT_FILENAME   = 'FILE NAME=';         { Do not localize }

var
  SqlLibRefCount: Integer;
  SqlLibLock: TCriticalSection;


{ Whether the specified connection tags are present }
function CT_UserIDExists(const ConnStr: string): Boolean;
var
  s: string;
begin
  s := UpperCase(ConnStr);
  Result := Pos(CT_USERID, s) > 0;
        // check the second form
  if not Result then
    Result := Pos(CT_USERID2, s) > 0;
end;

function CT_PasswordExists(const ConnStr: string): Boolean;
var
  s: string;
begin
  s := UpperCase(ConnStr);
  Result := Pos(CT_PASSWORD, s) > 0;
        // check the second form
  if not Result then
    Result := Pos(CT_PASSWORD2, s) > 0;
end;

function MakeLangID(usPrimaryLanguage, usSubLanguage: Short): Word;
begin
  Result := (usSubLanguage shl 10) or usPrimaryLanguage;
end;

function MakeLCID(wLanguageID, wSortID: Word): DWORD;
begin
  Result := (wSortID shl 16) or wLanguageID;
end;

function GetWideCharBufLen(const s: string): Integer;
begin
        // CP_ACP - default to ANSI code page
  Result := MultiByteToWideChar(CP_ACP, 0, PChar(s), Length(s), nil, 0);
end;

function AllocWideChar(const s: string): PWideChar;
var
  Len: Integer;
begin
  Len := GetWideCharBufLen(s);
  Result := SysAllocStringLen(nil, Len);        // desclared in ActiveX unit
        // CP_ACP - default to ANSI code page
  MultiByteToWideChar(CP_ACP, 0, PChar(s), Length(s), Result, Len);
end;

procedure FreeWideChar(const bstr: PWideChar);
begin
  SysFreeString(bstr);
end;

function InitSqlDatabase(ADbParams: TStrings): TISqlDatabase;
begin
  Result := TIOleDbDatabase.Create( ADbParams );
end;

procedure LoadSqlLib;
begin
  SqlLibLock.Acquire;
  try
    if SqlLibRefCount = 0 then begin
      OleCheck( CoInitialize(nil) );
      Inc(SqlLibRefCount);
    end else
      Inc(SqlLibRefCount);
  finally
    SqlLibLock.Release;
  end;
end;

procedure FreeSqlLib;
begin
  if SqlLibRefCount = 0 then
    Exit;

  SqlLibLock.Acquire;
  try
    if SqlLibRefCount = 1 then begin
      CoUninitialize;
      Dec(SqlLibRefCount);
    end else
      Dec(SqlLibRefCount);
  finally
    SqlLibLock.Release;
  end;
end;

{ TIOleDbDatabase }

constructor TIOleDbDatabase.Create(ADbParams: TStrings);
begin
  inherited Create(ADbParams);

  FIDBInitialize := nil;
  FIDBCreateSession:= nil;
  FIDBCreateCommand:=nil;
  FITransaction := nil;
  
  FIsMSSQLProv := False;
end;

destructor TIOleDbDatabase.Destroy;
begin

  inherited;
end;

function TIOleDbDatabase.CreateSqlCommand: TISqlCommand;
begin
  Result := TIOleDbCommand.Create( Self );
end;

procedure TIOleDbDatabase.ReleaseDBHandle(ASqlCmd: TISqlCommand; IsFetchAll: Boolean);
var
  ds: TISqlCommand;
begin
  if Assigned(FCurSqlCmd) and (ASqlCmd <> FCurSqlCmd) then begin
    ds := FCurSqlCmd;
    FCurSqlCmd := nil;
    try
      if IsFetchAll then
        ds.SaveResults;
    except
      FCurSqlCmd := ds;
      raise;
    end;
  end;
  FCurSqlCmd := ASqlCmd;
end;

procedure TIOleDbDatabase.Check(Status: HResult);
var
  sMsg: string;
  szMsg: PChar;
  MsgLen, nErrCode, i, j, nNativeError, nErrPos: Integer;
  pIErrorInfo, pIErrorInfo2: IErrorInfo;
  pIErrorRecords: IErrorRecords;
  pISQLErrorInfo: ISQLErrorInfo;
  pIMSSQLErrorInfo: ISQLServerErrorInfo;
  nErrRecords: ULONG;
  ws, wsSqlState: WideString;
  lcids: array[0..2] of TLCID;
  hr: HResult;
  SSErrorPtr: PSSErrorInfo;
  SSError: TSSErrorInfo;
  StringsBufferPtr: PWideChar;
begin
  ResetIdleTimeOut;

  if Succeeded(Status) then
    Exit;

  nNativeError := 0;
  nErrCode := 0;
  nErrPos := 0;
  pIErrorInfo := nil;
  pIErrorRecords:= nil;
  if Succeeded( GetErrorInfo(0, pIErrorInfo) ) and Assigned(pIErrorInfo) then begin
	// OLE DB extends the OLE Automation error model by allowing
	// Error objects to support the IErrorRecords interface; this
	// interface can expose information on multiple errors.
    if Succeeded( pIErrorInfo.QueryInterface( IID_IErrorRecords, pIErrorRecords ) ) and Assigned(pIErrorRecords) then begin
      lcids[0] := GetUserDefaultLCID;
      lcids[1] := GetSystemDefaultLCID;
      lcids[2] := MakeLCID( MakeLangID(LANG_ENGLISH, SUBLANG_DEFAULT), SORT_DEFAULT );
      pIErrorRecords.GetRecordCount( nErrRecords );
      for i:=nErrRecords-1 downto 0 do begin
        wsSqlState := '';
        nErrCode := 0;
        pISQLErrorInfo := nil;
        pIMSSQLErrorInfo:=nil;
                // get a native MS SQL Server error interface
        if IsMSSQLProv and Succeeded( pIErrorRecords.GetCustomErrorObject(i, IID_ISQLServerErrorInfo, IUnknown(pIMSSQLErrorInfo)) ) and Assigned(pIMSSQLErrorInfo) then begin
          SSErrorPtr := nil;
          StringsBufferPtr:= nil;
          try
            hr := pIMSSQLErrorInfo.GetErrorInfo(SSErrorPtr, StringsBufferPtr);
            if Succeeded(hr) and Assigned(SSErrorPtr) then begin
              SSError := SSErrorPtr^;
              nErrCode := SSError.lNative;
              nErrPos := SSError.wLineNumber;
            end;
          finally
            if Assigned(SSErrorPtr) then
              CoTaskMemFree(SSErrorPtr);
            if Assigned(StringsBufferPtr) then
              CoTaskMemFree(StringsBufferPtr);
            pIMSSQLErrorInfo := nil;
          end;
        end else if Succeeded( pIErrorRecords.GetCustomErrorObject(i, IID_ISQLErrorInfo, IUnknown(pISQLErrorInfo)) ) and Assigned(pISQLErrorInfo) then begin
          try   // use a common error interface
            pISQLErrorInfo.GetSQLInfo( wsSqlState, nErrCode );
          finally
            pISQLErrorInfo := nil;
          end;
        end;
        pIErrorInfo2 := nil;
                // save the first error code
        if nNativeError = 0 then
          nNativeError := nErrCode;

                // returns one error description in any locale
        for j:=0 to High(lcids) do begin
          pIErrorRecords.GetErrorInfo(i, lcids[j], pIErrorInfo2);
          if Assigned(pIErrorInfo2) then begin
            hr := pIErrorInfo2.GetDescription(ws);
            pIErrorInfo2 := nil;
            if Succeeded(hr) then begin
              if Length(sMsg) > 0 then
                sMsg := sMsg + CRLFString;
              if wsSqlState <> '' then
                sMsg := sMsg + 'SQLSTATE=' + OleStrToString(PWideChar(wsSqlState)) + '; ';
              sMsg := sMsg + OleStrToString(PWideChar(ws));
              Break;
            end;
          end;
        end;