sqlexpr.pas

多数代码可以直接在Delphi6和Delphi7环境下运行。部分涉及.NET技术内容的代码

begin
  Result := FTraceList.Count;
end;

procedure TSQLMonitor.LoadFromFile(AFileName: string);
begin
  if AFileName <> '' then
    FTraceList.LoadFromFile(AFileName)
  else if FFileName <> '' then
    FTraceList.LoadFromFile(string(FFileName))
  else
    DatabaseError(SFileNameBlank);
end;

procedure TSQLMonitor.SaveToFile(AFileName: string);
begin
  if AFileName <> '' then
    FTraceList.SaveToFile(AFileName)
  else if FFileName <> '' then
    FTraceList.SaveToFile(FFileName)
  else
    DatabaseError(SFileNameBlank);
end;

procedure TSQLMonitor.SetTraceList(Value: TStrings);
begin
  if FTraceList <> Value then
  begin
    FTraceList.BeginUpdate;
    try
      FTraceList.Assign(Value);
    finally
      FTraceList.EndUpdate;
    end;
  end;
end;


{ TSQLConnection }

constructor TSQLConnection.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FParams := TStringList.Create;
  FAutoClone := True;
  try
    FConnectionRegistryFile := GetConnectionRegistryFile(csDesigning in ComponentState);
  except
    FConnectionRegistryFile := '';
  end;
  FKeepConnection := True;
  FMonitorUsers := TList.Create;
  FSQLHourGlass := True;
  FQuoteChar := '';
  FTableScope := [tsTable, tsView];
  LoginPrompt := True;
end;

destructor TSQLConnection.Destroy;
begin
  Destroying;
  ClearConnectionUsers;
  Close;
  ClearMonitors;
  FreeAndNil(FMonitorUsers);
  inherited Destroy;
  FParams.Free;
end;

{ user registration }

procedure TSQLConnection.ClearConnectionUsers;
begin
  while DataSetCount > 0 do
  begin
    if TCustomSQLDataSet(DataSets[0]).Active then
      TCustomSQLDataSet(DataSets[0]).Close;
    TCustomSQLDataSet(DataSets[0]).FreeStatement;
    TCustomSQLDataSet(DataSets[0]).SetConnection(nil);
  end;
end;

procedure TSQLConnection.ClearMonitors;
var
  I: Integer;
begin
  for I := 0 to FMonitorUsers.Count -1 do
  begin
    if Self.FIsCloned then
      TSQLMonitor(FMonitorUsers[0]).SwitchConnection(Self.FCloneParent)
    else
    begin
      TSQLMonitor(FMonitorUsers[0]).SetActive(False);
      TSQLMonitor(FMonitorUsers[0]).FSQLConnection := nil;
    end;
  end;
end;

procedure TSQLConnection.RegisterTraceMonitor(Client: TObject);
begin
  FMonitorUsers.Add(Client);
end;

procedure TSQLConnection.UnregisterTraceMonitor(Client: TObject);
begin
  FMonitorUsers.Remove(Client);
end;

{ Exception handling routine }

procedure TSQLConnection.SQLError(OpStatus: SQLResult; eType: TSQLExceptionType; const Command: ISQLCommand = nil);
var
  ExceptionMessage: string;
  Message: PChar;
  Status: SQLResult;
  MessageLen: SmallInt;
begin
  Status := SQL_NULL_DATA;
  ExceptionMessage := SErrorMappingError;
  Message := nil;
  if (OpStatus > 0) and (OpStatus <=  DBX_MAXSTATICERRORS) then
    ExceptionMessage := DbxError[ OpStatus ]
  else if (OpStatus > 0) and (OpStatus < MaxReservedStaticErrors) then
    ExceptionMessage := SDBXUNKNOWNERROR
  else
    begin
      case eType of
        exceptCommand:
          begin
            Status := Command.getErrorMessageLen(MessageLen);
            if (Status = SQL_SUCCESS) and (MessageLen > 0) then
            begin
              Message := AllocMem(MessageLen + 1);
              Status := Command.getErrorMessage(Message);
            end;
          end;
        exceptConnection:
          begin
            Status := FISQLConnection.getErrorMessageLen(MessageLen);
            if (Status = SQL_SUCCESS) and (MessageLen > 0) then
            begin
              Message := AllocMem(MessageLen + 1);
              Status := FISQLConnection.getErrorMessage(Message);
            end;
          end;
        exceptMetaData:
          begin
            Status := FSQLMetaData.getErrorMessageLen(MessageLen);
            if (Status = SQL_SUCCESS) and (MessageLen> 0) then
            begin
              Message := AllocMem(MessageLen + 1);
              Status := FSQLMetaData.getErrorMessage(Message);
            end;
          end;
      end;
      if Status = SQL_SUCCESS then
      begin
        if MessageLen > 0 then
        begin
          SetString(ExceptionMessage, Message, StrLen(Message));
        end else
          ExceptionMessage := SErrorMappingError;
      end
      else if LastError <> '' then
        ExceptionMessage := LastError;
      if Assigned(Message) then
        FreeMem(Message);
      if ExceptionMessage = '' then
        ExceptionMessage := LastError;
    end;
  FLastError := ExceptionMessage;
  DatabaseError(ExceptionMessage);
end;

{ loading, connecting and disconnecting }

procedure TSQLConnection.LoadSQLDll;
begin
{$IFDEF MSWINDOWS}
  if DllHandle = THandle(0) then
  begin
{$ENDIF}
  try
    SetCursor(HourGlassCursor);
    if SQLDllHandle = THandle(0) then
      SQLDllHandle := THandle(LoadLibrary(PChar(trim(LibraryName))));
    if SQLDllHandle = THandle(0) then
      DataBaseErrorFmt(sDLLLoadError, [LibraryName]);
    GetDriver := GetProcAddress(HMODULE(SQLDllHandle), PChar(trim(GetDriverFunc)));
    if not Assigned(GetDriver) then
      DataBaseErrorFmt(sDLLProcLoadError, [GetDriverFunc])
  finally
    SetCursor(DefaultCursor);
  end;
{$IFDEF MSWINDOWS}
end;
{$ENDIF}
end;

procedure TSQLConnection.CheckConnection(eFlag: eConnectFlag);
begin
  if (eFlag in [eDisconnect, eReconnect]) then
    Close;
  if (eFlag in [eConnect, eReconnect]) then
    Open
end;

procedure TSQLConnection.Login(LoginParams: TStrings);
var
  UserName, Password: string;

  function Login: Boolean;
  begin
    Result := Assigned(FOnLogin);
    if Result then FOnLogin(Self, LoginParams);
  end;

begin
  if not Login then
  begin
    UserName := LoginParams.Values[szUserName];
    if Assigned(LoginDialogExProc) then
    begin
      SetCursor(DefaultCursor);
      if not LoginDialogExProc(ConnectionName, UserName, Password, False) then
        DatabaseErrorFmt(SLoginError, [ConnectionName]);
      SetCursor(HourGlassCursor);
      LoginParams.Values[szUSERNAME] := UserName;
      LoginParams.Values[szPASSWORD] := Password;
    end;
  end;
end;

procedure TSQLConnection.CheckLoginParams;
var
  I: Integer;
begin
  if FLoadParamsOnConnect then LoadParamsFromIniFile;
  if LoadParamsOnConnect then FDriverName := GetProfileString(FConnectionName, DRIVERNAME_KEY, ConnectionRegistryFile);
  if FDriverName = '' then DataBaseError(SMissingDriverName);
  if LoadParamsOnConnect then
    FLibraryName := GetProfileString(FDriverName, DLLLIB_KEY, GetDriverRegistryFile(csDesigning in ComponentState));
  if FLibraryName = '' then DataBaseError(SMissingDLLName, Self);
  if LoadParamsOnConnect then
    FVendorLib := trim(GetProfileString(FDriverName, VENDORLIB_KEY, GetDriverRegistryFile));
  if FVendorLib = '' then DataBaseError(SMissingDLLName, Self);
  if LoadParamsOnConnect then
    FGetDriverFunc := GetProfileString(FDriverName, GETDRIVERFUNC_KEY, GetDriverRegistryFile);
  if Params.Values[DATABASENAME_KEY] = '' then
  begin
    if FConnectionName = '' then DataBaseError(SConnectionNameMissing)
    else DataBaseError(SMissingDatabaseName);
  end;
  for I := 0 to FMonitorUsers.Count -1 do
    TSQLMonitor(FMonitorUsers[i]).SetStreamedActive;
end;

function TSQLConnection.GetQuoteChar: string;
var
  Status: SQLResult;
  Len: SmallInt;
  Q: Char;
begin
  FQuoteChar := '';
  Len := 1;
  Q := #0;
  Status := FSQLMetadata.getOption(eMetaObjectQuoteChar, @Q, Len, Len);
  if (Q <> #0) and (Status = SQL_SUCCESS) then
    FQuoteChar := Q;
  Result := FQuoteChar;
end;

procedure TSQLConnection.SetCursor(CursorType: Integer);
begin
  if SQLHourGlass or (CursorType = DefaultCursor) then
    if Assigned(ScreenCursorProc) then
      ScreenCursorProc(CursorType);
end;

procedure TSQLConnection.ConnectionOptions;
var
  PropSize: SmallInt;
  SupTransactions: LongBool;
begin
  GetQuoteChar;
  if FParams.Values[MAXBLOBSIZE_KEY] <> '' then
    FISQLConnection.SetOption(eConnBlobSize, LongInt(StrToInt(trim(FParams.Values[MAXBLOBSIZE_KEY]))))
  else
    FISQLConnection.SetOption(eConnBlobSize, LongInt(DefaultMaxBlobSize));
  FSQLMetaData.GetOption(eMetaSupportsTransaction, @SupTransactions, SizeOf(Integer), PropSize);
  if SupTransactions then
    FTransActionsSupported := True
  else
    FTransActionsSupported := False;
  FSQLMetaData.GetOption(eMetaSupportsTransactions, @FSupportsMultiTrans, SizeOf(Integer), PropSize);
end;

procedure TSQLConnection.DoConnect;
var
  Status: SQLResult;
  LoginParams: TStrings;
  PropSize: SmallInt;
  TrimmedUserName: string;
begin
  CheckLoginParams;
  ConnectionState := csStateConnecting;
  LoadSQLDll;
  LoginParams := TStringList.Create;
  try
    SetCursor(HourGlassCursor);
    Status := getDriver(PChar(FVendorLib), PChar(Trim(FParams.Values[ERROR_RESOURCE_KEY])), FSQLDriver);
    if Status <> SQL_SUCCESS then
      DataBaseErrorFmt(sDLLLoadError, [FVendorLib]);
    Check(FSQLDriver.setOption(eDrvRestrict, GDAL));
    Check(FSQLDriver.getSQLConnection(FISQLConnection));
    GetLoginParams(LoginParams);
    SetCursor(HourGlassCursor);
    RegisterTraceCallback(True);
    SetConnectionParams;
    Check(Connection.connect(PChar(trim(LoginParams.Values[DATABASENAME_KEY])), PChar(LoginParams.Values[ szUSERNAME ]),
         PChar(LoginParams.Values[ szPASSWORD ])));
    FISQLConnection.getOption(eConnMaxActiveComm, @FMaxStmtsPerConn, Sizeof(Integer), PropSize);
    Check(Connection.getSQLMetaData(FSQLMetaData));
    TrimmedUserName := trim(LoginParams.Values[ szUSERNAME ]);
    if TrimmedUserName <> '' then
      FSQLMetaData.SetOption(eMetaSchemaName, LongInt(TrimmedUserName));
    ConnectionOptions;
    ConnectionState := csStateOpen;
  finally
    SetCursor(DefaultCursor);
    LoginParams.Free;
    if ConnectionState = csStateConnecting then
    begin
      ConnectionState := csStateClosed;
      SQLDllHandle := THandle(0);
      if Assigned(FISQLConnection) then
        FISQLConnection := nil;
    end;
  end;
end;

procedure TSQLConnection.GetLoginParams(LoginParams: TStrings);
var
  I: Integer;
  PName: string;
begin
  LoginParams.BeginUpdate;
  try
    LoginParams.Clear;
    for I := 0 to FParams.Count - 1 do
      begin
        if LoginParams.IndexOf(FParams[I]) > -1 then continue;
        PNAME := FParams.Names[I];
        if CompareText(PName, szPASSWORD) = 0 then
           LoginParams.Add(format('%s=%s',[szPASSWORD, FParams.Values[szPASSWORD] ]))
        else if CompareText(PName, szUSERNAME) = 0 then
           LoginParams.Add(format('%s=%s',[szUSERNAME, FParams.Values[szUSERNAME]]))
        else if CompareText(PName, DATABASENAME_KEY) = 0 then
          LoginParams.Add(format('%s=%s',[DATABASENAME_KEY, trim(FParams.Values[DATABASENAME_KEY])]));
      end;
  finally
    LoginParams.EndUpdate;
  end;
  if LoginPrompt then
     Login(LoginParams);
end;

function TSQLConnection.GetConnected: Boolean;
begin
  Result := Assigned(FISQLConnection) and (not
      (ConnectionState in [csStateClosed, csStateConnecting,
      csStateDisconnecting]));
end;

procedure TSQLConnection.DoDisconnect;
begin
  if FSQLDriver <> nil then
  begin
     ConnectionState := csStateDisconnecting;
     CloseDataSets;
     RegisterTraceCallback(False);
     if (FSQLMetaData <> nil) then