tutil.pas

jvcl driver development envionment

{******************************************************************

                       JEDI-VCL Demo

 Copyright (C) 2002 Project JEDI

 Original author:

 Contributor(s):

 You may retrieve the latest version of this file at the JEDI-JVCL
 home page, located at http://jvcl.sourceforge.net

 The contents of this file are used with permission, subject to
 the Mozilla Public License Version 1.1 (the "License"); you may
 not use this file except in compliance with the License. You may
 obtain a copy of the License at
 http://www.mozilla.org/MPL/MPL-1_1Final.html

 Software distributed under the License is distributed on an
 "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
 implied. See the License for the specific language governing
 rights and limitations under the License.

******************************************************************}

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

Unit TUtil;

{$I jvcl.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, JvDBUtils, JvBdeUtils,  JvBDEProgress, JvJCLUtils, JvJVCLUtils;

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}

var
  TUHandle: THandle = 0;
  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 COMPILER3_UP}
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: TJvDBCallback ;
begin
  CheckTU;
  Check(TUInit(@FSession));
  try
    FCallback := TJvDBCallback .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);