sdoledb.pas

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

      end;
    end else begin
	// The object doesn't support IErrorRecords;
      pIErrorInfo.GetDescription(ws);
      sMsg := OleStrToString(PWideChar(ws));
    end;
  end else begin
    MsgLen := FormatMessage( FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM,
		nil,
		Status,
		LANG_USER_DEFAULT,
		@szMsg,
		0,
		nil);
    if MsgLen > 0 then begin
      sMsg := StrNew(szMsg);
      LocalFree( Cardinal(szMsg) );
    end else begin
      nErrCode := GetLastError;
      if nErrCode = ERROR_MR_MID_NOT_FOUND then
        sMsg := SErrErrorNotFound + IntToHex(Status, 8);
    end;
  end;
  raise ESDOleDbError.Create(Status, nNativeError, sMsg, nErrPos);
end;

procedure TIOleDbDatabase.DoConnect(const sRemoteDatabase, sUserName, sPassword: string);
  function AddTagSep(const CStr: string): string;
  var
    i: Integer;
  begin
    Result := '';
    for i:=Length(CStr) downto 1 do
      if CStr[i] <> ' ' then begin
        if CStr[i] <> ';' then
          Result := ';';
        Break;
      end;
  end;
var
  pDataInit: IDataInitialize;
  ConnStr: WideString;
  sSrvName, sDbName, s: string;
begin
  ASSERT( FIDBInitialize = nil );
  LoadSqlLib;

    	// if DSN/connection string with options
  if Pos('=', sRemoteDatabase) > 0 then begin
    ConnStr := sRemoteDatabase;
  end else begin
    sSrvName := ExtractServerName(sRemoteDatabase);
    sDbName  := ExtractDatabaseName(sRemoteDatabase);
    ConnStr := CT_PROVIDER + ProgID_SQLOLEDB + ';' + CT_DATASOURCE + sSrvName;
    FIsMSSQLProv := True;
    if sDbName <> '' then
      ConnStr := ConnStr + ';' + CT_INITCATALOG + sDbName;
  end;
        // if connection string does not contain username parameter
  if not CT_UserIDExists(ConnStr) and (sUserName <> '') then
    ConnStr := ConnStr + AddTagSep(ConnStr) + CT_USERID + sUserName;
    // if connection string does not contain password parameter
  if not CT_PasswordExists(ConnStr) and (sPassword <> '') then
    ConnStr := ConnStr + AddTagSep(ConnStr) + CT_PASSWORD + sPassword;

        // create first high-level unintialized datasource object(CoType TDataSource)
  pDataInit := CreateComObject(CLSID_DataLinks) as IDataInitialize;
        // generates a new uninitialized data source object based on the information in sConnect
  Check( pDataInit.GetDataSource(nil, CLSCTX_INPROC_SERVER,
      PWideChar(ConnStr), IID_IDBInitialize, IUnknown(FIDBInitialize)) );
  pDataInit := nil;

        //Initialize the data source object.
  SetDBInitProps( True, not CT_UserIDExists(ConnStr) );
  Check( FIDBInitialize.Initialize() );

  Check( FIDBInitialize.QueryInterface(IID_IDBCreateSession, FIDBCreateSession) );
        // create a session object and return the required interface of the session object
        // IDBCreateCommand is optional interface of session object (some provider do not support commands)
  Check( FIDBCreateSession.CreateSession(nil, IID_IDBCreateCommand, IUnknown(FIDBCreateCommand)) );

        // Is IMultipleResults supported
  FMultResultsSupported := StrToIntDef( OleDbGetDBPropValue([DBPROP_MULTIPLERESULTS]), 0 ) <> 0;
  FProcSupportsCursors  := FMultResultsSupported;       // procedures can return result set(-s)
        // check Output Parameter Availability
  FOutputParamsReturned := StrToIntDef( OleDbGetDBPropValue([DBPROP_OUTPUTPARAMETERAVAILABILITY]), 0 );
        // get Commit/Rollback behaviours
  FCursorPreservedOnCommit:=StrToIntDef( OleDbGetDBPropValue([DBPROP_PREPARECOMMITBEHAVIOR]), 0 ) = DBPROPVAL_CB_PRESERVE;
  FCursorPreservedOnRollback:=StrToIntDef( OleDbGetDBPropValue([DBPROP_PREPAREABORTBEHAVIOR]), 0 ) = DBPROPVAL_CB_PRESERVE;
  if not IsMSSQLProv then begin
    s := OleDbGetDBPropValue([DBPROP_PROVIDERFRIENDLYNAME]);
    FIsMSSQLProv := (Pos('Microsoft', s) > 0) and (Pos('SQL Server', s) > 0);
  end;
  SetDBInitProps( False, False );  
end;

procedure TIOleDbDatabase.DoDisconnect(Force: Boolean);
begin
  if Assigned(FITransaction) then
    DoRollback;
  FIDBCreateCommand := nil;
  FIDBCreateSession := nil;
  if Assigned( FIDBInitialize ) then
    FIDBInitialize.Uninitialize;
  FIDBInitialize := nil;
  FIsMSSQLProv := False;

  FreeSqlLib;
end;

// returns property value(-s) from Data Source Information group as string,
//where values are delimited using space
function TIOleDbDatabase.OleDbGetDBPropValue(APropIDs: array of DBPROPID): string;
var
  DBProperties: IDBProperties;
  PropIDSet: array[0..0] of TDBPropIDSet;
  prgPropertySets: PDBPropSet;
  PropSet: DBPropSet;
  nPropertySets: UINT;
  i: Integer;
  s: string;
begin
  Result := '';
  DBProperties := nil;
  Check( FIDBInitialize.QueryInterface(IID_IDBProperties, DBProperties) );
  try
    PropIDSet[0].rgPropertyIDs := @APropIDs;
    PropIDSet[0].cPropertyIDs  := High(APropIDs)+1;
    PropIDSet[0].guidPropertySet:=DBPROPSET_DATASOURCEINFO;
    nPropertySets := 0;
    prgPropertySets := nil;
    Check( DBProperties.GetProperties( 1, @PropIDSet, nPropertySets, prgPropertySets ) );
    ASSERT( nPropertySets = 1 );        // only one property set can be processed
    PropSet := prgPropertySets^;
    for i:=0 to PropSet.cProperties-1 do begin
      if PropSet.rgProperties^[i].dwStatus <> DBPROPSTATUS_OK then
        Continue;
      if Result <> '' then
        if PropSet.rgProperties^[i].dwPropertyID = DBPROP_DBMSVER then
          Result := Result + ' Release '
        else
          Result := Result + ' ';
      s := PropSet.rgProperties^[i].vValue;
      Result := Result + s;
    end;
        // free and clear elements of prgPropertySets^[0]
    for i:=0 to PropSet.cProperties-1 do
      VariantClear(PropSet.rgProperties^[i].vValue);
    CoTaskMemFree(PropSet.rgProperties);
        // free prgPropertySets
    CoTaskMemFree(prgPropertySets);
  finally
    DBProperties := nil;
  end;
end;

// if bInitPropSet is True then only properties of Initialization(DBPROPSET_DBINIT) properties group could be changed
// if bInitPropSet is False then other propeties group (except, Initialization) could be modified
// bIntegratedAuth means, when bInitPropSet is True
procedure TIOleDbDatabase.SetDBInitProps(bInitPropSet, bIntegratedAuth: Boolean);
const
  MaxPropCount = 20;
var
  pDBProps: IDBProperties;
  rgProperties: array[0..MaxPropCount-1] of TDBProp;
  rgPropertySets: DBPropSet;
  nProps: UINT;
  i: Integer;
  sValue: string;
  hr: HResult;
begin
  nProps := 0;
  pDBProps := nil;
  ASSERT( FIDBInitialize <> nil );
  Check( FIDBInitialize.QueryInterface(IID_IDBProperties, pDBProps) );
  try
        // initialize common property options
    for i:=0 to MaxPropCount-1 do begin
      rgProperties[i].dwOptions := DBPROPOPTIONS_REQUIRED;
      rgProperties[i].colid     := DB_NULLID;
      rgProperties[i].dwStatus  := 0;
      VariantInit( rgProperties[i].vValue );
    end;
    if bInitPropSet then begin
          // DBPROP_AUTH_INTEGRATED
      if bIntegratedAuth then begin
          // it is need to set vValue.vt = VT_BSTR, vValue.bstrVal = NULL
        rgProperties[nProps].dwPropertyID := DBPROP_AUTH_INTEGRATED;      // Integrated Security
        rgProperties[nProps].vValue       := '';                          // the default authentication service should be used
        Inc(nProps);
      end;
          // DBPROP_INIT_TIMEOUT and DBPROP_INIT_GENERALTIMEOUT
      sValue := Trim( Params.Values[szLOGINTIMEOUT] );
      if sValue <> '' then begin
        rgProperties[nProps].dwPropertyID := DBPROP_INIT_TIMEOUT;       // number of seconds
        rgProperties[nProps].vValue       := StrToIntDef(sValue, 0);
        Inc(nProps);
          // Indicates the number of seconds before a request, other than data source initialization and command execution, times out
        rgProperties[nProps].dwPropertyID := DBPROP_INIT_GENERALTIMEOUT;// number of seconds
        rgProperties[nProps].vValue       := StrToIntDef(sValue, 0);
        Inc(nProps);
      end;

      if nProps > 0 then begin
        rgPropertySets.guidPropertySet := DBPROPSET_DBINIT;
        rgPropertySets.cProperties := nProps;
        rgPropertySets.rgProperties := @rgProperties;

        hr := pDBProps.SetProperties( 1, TSDPtr(@rgPropertySets) );
        if not Succeeded( hr ) then
          if hr = DB_E_ERRORSOCCURRED then begin
            ResetIdleTimeOut;
            raise ESDOleDbError.Create(hr, hr, SErrDBPropsNotSupported + Format(' (error $%.8x in TIOleDbDatabase.SetDBInitProps)', [hr]), 0)
          end else
            Check(hr);

          // free and clear elements of rgPropertySets[]
        for i:=0 to nProps-1 do
          VariantInit( rgProperties[i].vValue );
      end;
        // set TDS packet size. It's supported for MSSQL provider only        
      sValue := Trim( Params.Values[szTDSPACKETSIZE] );
      if sValue <> '' then begin
        nProps := 0;
        rgProperties[nProps].dwPropertyID := SSPROP_INIT_PACKETSIZE;
        rgProperties[nProps].vValue       := StrToInt(sValue);
        Inc(nProps);

        rgPropertySets.guidPropertySet := DBPROPSET_SQLSERVERDBINIT;
        rgPropertySets.cProperties := nProps;
        rgPropertySets.rgProperties := @rgProperties;

        Check( pDBProps.SetProperties( 1, TSDPtr(@rgPropertySets) ) );

          // free and clear elements of rgPropertySets[]
        for i:=0 to nProps-1 do
          VariantInit( rgProperties[i].vValue );
      end;
    end else begin
          // force to use one session only (exclude implicitly spawning connections/sessions)
      if IsMSSQLProv then begin
        if IsSingleConn then begin
          nProps := 0;
          rgProperties[nProps].dwPropertyID := DBPROP_MULTIPLECONNECTIONS;
          rgProperties[nProps].vValue       := False;
          Inc(nProps);

          rgPropertySets.guidPropertySet := DBPROPSET_DATASOURCE;
          rgPropertySets.cProperties := nProps;
          rgPropertySets.rgProperties := @rgProperties;

          Check( pDBProps.SetProperties( 1, TSDPtr(@rgPropertySets) ) );

            // free and clear elements of rgPropertySets[]
          for i:=0 to nProps-1 do
            VariantInit( rgProperties[i].vValue );
        end;
      end;
    end;
  finally
    pDBProps := nil;
  end;
end;

function TIOleDbDatabase.GetClientVersion: LongInt;
begin
  Result := VersionStringToDWORD( OleDbGetDBPropValue([DBPROP_PROVIDERVER]) );
end;

function TIOleDbDatabase.GetServerVersion: LongInt;
begin
  Result := VersionStringToDWORD( OleDbGetDBPropValue([DBPROP_DBMSVER]) );
end;

function TIOleDbDatabase.GetVersionString: string;
begin
  Result := OleDbGetDBPropValue([DBPROP_DBMSNAME, DBPROP_DBMSVER]);
end;

procedure TIOleDbDatabase.DoCommit;
begin
  ASSERT( FITransaction <> nil );

	// SQL Server returns XACT_E_NOTSUPPORTED if fRetaining == TRUE
        // At general it is not necessary to start a new transaction for us
  Check( FITransaction.Commit(False, XACTTC_SYNC, 0) );
  FITransaction := nil;  
end;

procedure TIOleDbDatabase.DoRollback;
begin
  ASSERT( FITransaction <> nil );

  Check( FITransaction.Abort(nil, False, False) );
  FITransaction := nil;
end;

procedure TIOleDbDatabase.DoStartTransaction;
const
  IsolLevel: array[TISqlTransIsolation] of Integer =
  	(ISOLATIONLEVEL_READUNCOMMITTED,
         ISOLATIONLEVEL_READCOMMITTED,
         ISOLATIONLEVEL_REPEATABLEREAD
        );
begin
  ASSERT( FITransaction = nil );
  Check( FIDBCreateCommand.QueryInterface(IID_ITransactionLocal, FITransaction) );
  try
    Check( FITransaction.StartTransaction(IsolLevel[TransIsolation], 0, nil, nil) );
  except
    FITransaction := nil;
    raise;
  end;
end;

procedure TIOleDbDatabase.SetAutoCommitOption(Value: Boolean);
begin
  { nothing }
end;

procedure TIOleDbDatabase.SetTransIsolation(Value: TISqlTransIsolation);
begin
  { nothing }
end;

function TIOleDbDatabase.SPDescriptionsAvailable: Boolean;
begin
  Result := True;
end;

function TIOleDbDatabase.TestConnected: Boolean;
var
  cmd: TISqlCommand;
begin
  Result := False;
        // DBPROP_CONNECTIONSTATUS property does not return a correct status, when a server is down 
  cmd := GetSchemaInfo(stSysTables, 'X.DUMMY');
  if Assigned(cmd) then begin
    Result := True;
    cmd.Free;
  end;
end;

function TIOleDbDatabase.GetSchemaInfo(ASchemaType: TSDSchemaType; AObjectName: string): TISqlCommand;
var
  cmd: TIOleDbSchemaCommand;
begin
  cmd := nil;
  case ASchemaType of
    stTables,
    stSysTables:
    begin
      cmd := TIOleDbSchemaTables.Create(Self);
      cmd.ObjPattern := AObjectName;
      TIOleDbSchemaTables(cmd).SysTables := ASchemaType = stSysTables;
    end;
    stColumns:
    begin
      cmd := TIOleDbSchemaColumns.Create(Self);
      cmd.ObjPattern := AObjectName;
    end;
    stIndexes:
    begin
      cmd := TIOleDbSchemaIndexes.Create(Self);
      cmd.ObjPattern := AObjectName;
    end;
    stProcedures:
    begin
      cmd := TIOleDbSchemaProcs.Create(Self);
      cmd.ObjPattern := AObjectName;
    end;