tutil.pas

RxRich很有用的文字图像显示控件,这是它的Demo

{*******************************************************}
{                                                       }
{         Borland Delphi Unit                           }
{         TUTILITY.DLL Class Unit                       }
{                                                       }
{         Copyright (c) 1996 AO ROSNO                   }
{         Copyright (c) 1997 Master-Bank                }
{                                                       }
{*******************************************************}

Unit TUtil;

{$I RX.INC}

interface

{$IFDEF WIN32}
uses Windows, DB, BDE, SysUtils, DBTables;
{$ELSE}
uses WinTypes, WinProcs, DB, DbiTypes, DbiProcs, DbiErrs, SysUtils, DbTables;
{$ENDIF}

type
  HTUses = Word;
  PHTUses = ^HTUses;

{ Verify Callback processes }

  TUVerifyProcess = (TUVerifyHeader, TUVerifyIndex, TUVerifyData,
    TUVerifySXHeader, TUVerifySXIndex, TUVerifySXData, TUVerifySXIntegrity,
    TUVerifyTableName);

{ Call back info for Verify Callback function }

  PUVerifyCallBack = ^TUVerifyCallBack;
  TUVerifyCallBack = packed record
    PercentDone: SmallInt;
    TableName: DBIPath;
    Process: TUVerifyProcess;
    CurrentIndex: Word;
    TotalIndex: Word;
  end;

{ TUtility error }

  ETUtilityError = class(EDBEngineError)
  public
    constructor Create(ErrorCode: DBIResult);
  end;

{ Check and repair modes }

  TCheckRepair = (crNoRepair, crAutoRepair, crConfirmRepair);
  TVerifyOption = (vfAppendErrors, vfBypassSecondaryIndexes,
    vfIgnoreWarnings, vfVerifyHeaderOnly, vfNoLockTable, vfDialogHide);
  TVerifyOptions = set of TVerifyOption;

  TTUAction = procedure of object;

{ TTUtility }

  TTUtility = class(TObject)
  private
    FSession: HTUses;
    FCheckErrorTable, FErrorTable, FProblemTable,
    FKeyViolationTable, FBackupTable,
    FTableName: DBIPATH;
    FPassword: DBINAME;
    FTblDesc: CRTblDesc;
    FOptDataLen: Word;
    FCheckRepair: TCheckRepair;
    FVerifyOptions: TVerifyOptions;
    FShowNoError: Boolean;
    procedure SetTabName(const TabName: string; const Dest: DBIPATH);
    function CheckOpen(Status: DBIResult): Boolean;
    procedure Check(Status: DBIResult);
    function ProgressCallback(CBInfo: Pointer): CBRType;
    function VerifyFlag: Integer;
    function GetPassword: string;
    procedure SetPassword(const Value: string);
    function GetCheckErrorTable: string;
    procedure SetCheckErrorTable(const Value: string);
    function GetErrorTable: string;
    procedure SetErrorTable(const Value: string);
    function GetProblemTable: string;
    procedure SetProblemTable(const Value: string);
    function GetKeyViolationTable: string;
    procedure SetKeyViolationTable(const Value: string);
    function GetBackupTable: string;
    procedure SetBackupTable(const Value: string);
    function GetTableName: string;
    procedure SetTableName(const Value: string);
    function TULastErrorMessage: string;
    procedure CheckBackupTable;
    function ShowPasswordDialog: Boolean;
  protected
    procedure RunTUtility(Action: TTUAction);
    procedure FillTblDesc;
    procedure ClearTblDesc;
    procedure DoCheckTable; virtual;
    procedure DoRepairTable; virtual;
    function VerifyTable: Cardinal;
    property BackupTable: string read GetBackupTable write SetBackupTable;
  public
    constructor Create;
    destructor Destroy; override;
    function ErrorString(ErrorCode: DBIResult): string;
    procedure DefaultBackupNames;
    procedure CheckTable;
    procedure RepairTable;
    procedure DropErrorTable;
    property CheckRepair: TCheckRepair read FCheckRepair write FCheckRepair default crConfirmRepair;
    property CheckErrorTable: string read GetCheckErrorTable write SetCheckErrorTable;
    property ErrorTable: string read GetErrorTable write SetErrorTable;
    property KeyViolationTable: string read GetKeyViolationTable write SetKeyViolationTable;
    property ProblemTable: string read GetProblemTable write SetProblemTable;
    property Password: string read GetPassword write SetPassword;
    property ShowNoError: Boolean read FShowNoError write FShowNoError;
    property TableName: string read GetTableName write SetTableName;
    property VerifyOptions: TVerifyOptions read FVerifyOptions write FVerifyOptions
      default [vfIgnoreWarnings];
  end;

{ Utility routines }

procedure CheckTables(const TablesDir: string; Repair: TCheckRepair);
procedure CheckTable(const TableName: string; Repair: TCheckRepair);

implementation

uses Classes, Controls, Dialogs, Forms, DbUtils, BdeUtils, DbPrgrss,
  VCLUtils, FileUtil;

const
{ Verify table options }
  TU_APPEND_ERRORS            =  1; { append errors to an existing errors table }
  TU_BYPASS_SECONDARY_INDEXES =  2; { bypass secondary indexes }
  TU_IGNORE_WARNINGS          =  4; { prevents reporting of warning errors }
  TU_VERIFY_HEADER_ONLY       =  8; { verify table header only }
  TU_DIALOG_HIDE              = 16; { hide TUtility dialogs }
  TU_NO_LOCK                  = 32; { lock table being verified (recommended) }

{ Verify table error codes }
  VFE_WARNING           = 0; { warning error }
  VFE_DAMAGE_VERIFY     = 1; { table is damaged, verification can continue }
  VFE_DAMAGE_NOT_VERIFY = 2; { table is damaged; verification cannot continue }
  VFE_REBUILD_MANUALLY  = 3; { table must be rebuilt manually }
  VFE_CANNOT_REBUILD    = 4; { table cannot be rebuilt; restore from a backup }

const
{$IFDEF WIN32}
  TULib = 'TUTIL32.DLL';
{$ELSE}
  TULib = 'TUTILITY.DLL';
{$ENDIF}
  TUHandle: THandle = 0;

var
  TUInit: function (hTUSession: PHTUses): DBIResult {$IFDEF WIN32} stdcall {$ENDIF};
  TUVerifyTable: function (hTUSession: HTUses; pszTableName,
    pszDriverType, pszErrTableName, pszPassword: PChar; iOptions: Integer;
    var piErrorLevel: Cardinal): DBIResult {$IFDEF WIN32} stdcall {$ENDIF};
  TURebuildTable: function (hTUSession: HTUses; pszTableName,
    pszDriverType, pszBackupTableName, pszKeyviolName,
    pszProblemTableName: PChar;
    pCrDesc: pCRTblDesc): DBIResult {$IFDEF WIN32} stdcall {$ENDIF};
  TUGetCRTblDescCount: function (hTUSession: HTUses;
    pszTableName: PChar; var iFldCount,iIdxCount, iSecRecCount,
    iValChkCount, iRintCount, iOptParams,
    iOptDataLen: Word): DBIResult {$IFDEF WIN32} stdcall {$ENDIF};
  TUFillCRTblDesc: function (hTUSession: HTUses; pCrDesc: pCRTblDesc;
    pszTableName,
    pszPassword: PChar): DBIResult {$IFDEF WIN32} stdcall {$ENDIF};
  TUFillCURProps: function (hTUSession: HTUses; pszTableName: PChar;
    tblProps: pCURProps): DBIResult {$IFDEF WIN32} stdcall {$ENDIF};
  TUExit: function (hTUSession: HTUses): DBIResult {$IFDEF WIN32} stdcall {$ENDIF};
  TUGetErrorString: function (iErrorCode: DBIResult;
    pszError: PChar): DBIResult {$IFDEF WIN32} stdcall {$ENDIF};

{$IFDEF RX_D3}
resourcestring
{$ELSE}
const
{$ENDIF}
  STUNotLoaded = 'Unable to load %s library';
  STUNoTables = 'No Paradox tables to verify';
  STUVerifyComplete = 'Verification successful. ';
  STUVerifyOk = 'Table %s verify complete. No errors found.';
  STUDamage = 'Table %s is damaged. Rebuild it.';
  STURebuild = 'Table %s is damaged. Rebuild?';
  STURebuildManual = 'Table %s is damaged and must be rebuilt manually.';
  STUNoRebuild = 'Table %s is damaged and cannot be rebuilt; restore from a backup.';
  STUUnknownError = 'Unknown %s error, code %d';
  STUPwDlgCaption = 'Enter Table Password';
  STUPwDlgPrompt = 'Enter master password for table %s:';

function TUtilityLoaded: Boolean;
begin
  Result := TUHandle >= HINSTANCE_ERROR;
end;

function LoadTUtility: Boolean;
var
  OldError: Word;
  Path: string;
{$IFNDEF WIN32}
  P: array[0..255] of Char;
{$ENDIF}
begin
  OldError := SetErrorMode(SEM_NOOPENFILEERRORBOX);
  try
    Path := NormalDir(GetBdeDirectory) + TULib;
{$IFDEF WIN32}
    TUHandle := LoadLibrary(PChar(Path));
{$ELSE}
    TUHandle := LoadLibrary(StrPCopy(P, Path));
{$ENDIF}
    if not TUtilityLoaded then begin
      Path := TULib;
{$IFDEF WIN32}
      TUHandle := LoadLibrary(PChar(Path));
{$ELSE}
      TUHandle := LoadLibrary(StrPCopy(P, Path));
{$ENDIF}
    end;
    if TUtilityLoaded then begin
      @TUInit := GetProcAddress(TUHandle, 'TUInit');
      @TUVerifyTable := GetProcAddress(TUHandle, 'TUVerifyTable');
      @TURebuildTable := GetProcAddress(TUHandle, 'TURebuildTable');
      @TUGetCRTblDescCount := GetProcAddress(TUHandle, 'TUGetCRTblDescCount');
      @TUFillCRTblDesc := GetProcAddress(TUHandle, 'TUFillCRTblDesc');
      @TUFillCURProps := GetProcAddress(TUHandle, 'TUFillCURProps');
      @TUExit := GetProcAddress(TUHandle, 'TUExit');
      @TUGetErrorString := GetProcAddress(TUHandle, 'TUGetErrorString');
    end
    else TUHandle := 1;
  finally
    SetErrorMode(OldError);
  end;
  Result := TUtilityLoaded;
end;

procedure FreeTUtility; far;
begin
  if TUtilityLoaded then FreeLibrary(TUHandle);
  TUHandle := 0;
end;

procedure CheckTU;
begin
  if not TUtilityLoaded then
    raise EDatabaseError.CreateFmt(STUNotLoaded, [TULib]);
end;

{ ETUtilityError }

function TrimMessage(Msg: PChar): PChar;
var
  Blank: Boolean;
  Source, Dest: PChar;
begin
  Source := Msg;
  Dest := Msg;
  Blank := False;
  while Source^ <> #0 do
  begin
    if Source^ <= ' ' then Blank := True else
    begin
      if Blank then
      begin
        Dest^ := ' ';
        Inc(Dest);
        Blank := False;
      end;
      Dest^ := Source^;
      Inc(Dest);
    end;
    Inc(Source);
  end;
  if (Dest > Msg) and (Dest[Word(-1)] = '.') then Dec(Dest);
  Dest^ := #0;
  Result := Msg;
end;

type
  EDBEngineErrorHack = class(EDatabaseError)
  private
    FErrors: TList;
  end;

constructor ETUtilityError.Create(ErrorCode: DBIResult);
var
  ErrorIndex: Integer;
  NativeError: Longint;
  Msg, LastMsg: DBIMSG;
begin
  inherited Create(0);
{$IFDEF WIN32}
  if not Session.Active then Exit;
{$ENDIF}
  with EDBEngineErrorHack(Self) do begin
    if FErrors <> nil then begin
      for ErrorIndex := FErrors.Count - 1 downto 0 do
        TDBError(FErrors[ErrorIndex]).Free;
      FErrors.Clear;
    end;
  end;
  ErrorIndex := 1;
  try
    TUGetErrorString(ErrorCode, Msg);
    TDBError.Create(Self, ErrorCode, 0, Msg);
    TrimMessage(Msg);
    if Msg[0] = #0 then
      Message := Format(STUUnknownError, [TULib, ErrorCode])
    else Message := StrPas(Msg);
    while True do begin
      StrCopy(LastMsg, Msg);
      ErrorCode := DbiGetErrorEntry(ErrorIndex, NativeError, Msg);
      if (ErrorCode = DBIERR_NONE) or
        (ErrorCode = DBIERR_NOTINITIALIZED) then Break;
      TDBError.Create(Self, ErrorCode, NativeError, Msg);
      TrimMessage(Msg);
      if (Msg[0] <> #0) and (StrComp(Msg, LastMsg) <> 0) then
        Message := Format('%s. %s', [Message, Msg]);
      Inc(ErrorIndex);
    end;
  except
    Message := Format(STUUnknownError, [TULib, ErrorCode]);
  end;
end;

{ TTUtility }

constructor TTUtility.Create;
begin
  inherited Create;
  FCheckRepair := crConfirmRepair;
  FVerifyOptions := [vfIgnoreWarnings];
end;

destructor TTUtility.Destroy;
begin
  ClearTblDesc;
  inherited Destroy;
end;

procedure TTUtility.RunTUtility(Action: TTUAction);
var
  FCallback: TDBCallback;
begin
  CheckTU;
  Check(TUInit(@FSession));
  try
    FCallback := TDBCallback.Create(Self, cbGENPROGRESS,
      SizeOf(TUVerifyCallBack), ProgressCallback, dcChain);
    try
      Action;
    finally
      FCallback.Free;
    end;
  finally
    TUExit(FSession);
  end;
end;

function TTUtility.CheckOpen(Status: DBIResult): Boolean;
begin
  Result := True;
  case Status of
    DBIERR_NONE: Result := True;
    DBIERR_NOTSUFFTABLERIGHTS:
      begin
        if not Session.GetPassword then Check(Status);
        Result := False;
      end;
    else if (Status <> 0) then Check(Status);
  end;
end;

procedure TTUtility.Check(Status: DBIResult);
var
  ErrInfo: DBIErrInfo;
begin
  if Status <> 0 then begin
    DbiGetErrorInfo(True, ErrInfo);
    if (ErrInfo.iError = Status) then DbiError(Status)
    else raise ETUtilityError.Create(Status);
  end;
end;

function TTUtility.ProgressCallback(CBInfo: Pointer): CBRType;
begin
  Result := cbrCONTINUE;
  with PUVerifyCallBack(CBInfo)^ do begin
    StrPCopy(TableName, Self.TableName);
    if (PercentDone = 0) then PercentDone := -1;
  end;
end;

function TTUtility.ErrorString(ErrorCode: DBIResult): string;
var
  Msg: DBIMSG;
begin
  CheckTU;
  TUGetErrorString(ErrorCode, Msg);
  TrimMessage(Msg);
  if Msg[0] = #0 then Result := Format(STUUnknownError, [TULib, ErrorCode])
  else Result := StrPas(Msg);
end;

function TTUtility.VerifyFlag: Integer;
const
  VerifyFlags: array[TVerifyOption] of Integer =
    (TU_APPEND_ERRORS, TU_BYPASS_SECONDARY_INDEXES, TU_IGNORE_WARNINGS,
    TU_VERIFY_HEADER_ONLY, TU_NO_LOCK, TU_DIALOG_HIDE);
var
  I: TVerifyOption;
begin
  Result := 0;
  for I := Low(TVerifyOption) to High(TVerifyOption) do