backup.pas

数据备份与恢复源码,给需要的一个参考,可以直接运行

unit backup;

interface

uses
  Windows, Messages, SysUtils, Classes,
  Graphics, Controls, Forms, Dialogs,
  stdCtrls, FileCtrl;

type
  TAlloc = function(AppData: Pointer; Items, Size: Integer): Pointer;
  TFree = procedure(AppData, Block: Pointer);

  // Internal structure.  Ignore.
  TZStreamRec = packed record
    next_in: PChar; // next input byte
    avail_in: Integer; // number of bytes available at next_in
    total_in: Integer; // total nb of input bytes read so far

    next_out: PChar; // next output byte should be put here
    avail_out: Integer; // remaining free space at next_out
    total_out: Integer; // total nb of bytes output so far

    msg: PChar; // last error message, NULL if no error
    internal: Pointer; // not visible by applications

    zalloc: TAlloc; // used to allocate the internal state
    zfree: TFree; // used to free the internal state
    AppData: Pointer; // private data object passed to zalloc and zfree

    data_type: Integer; //  best guess about the data type: ascii or binary
    adler: Integer; // adler32 value of the uncompressed data
    reserved: Integer; // reserved for future use
  end;

type
  TPercentage = 0..100;
  TBackupMode = (bmAll, bmIncremental);
  TRestoreMode = (rmAll, rmNoOverwrite, rmNewer, rmExisting, rmExistingNewer);
  TCompressionLevel = (clFastest, clNone, clDefault, clMax);
  TProgressEvent = procedure(Sender: TObject; Filename: string; Percent: TPercentage; var Continue: Boolean) of object;
  TNeedDiskEvent = procedure(Sender: TObject; DiskID: word; var Continue: Boolean) of object;
  TRestoreFileEvent = procedure(Sender: TObject; var Filename: string; FA: Integer; var DoRestore: Boolean) of object;
  TFileRestoredEvent = procedure(Sender: TObject; var Filename: string; var Stream: TFilestream) of object;
  TBackupErrorEvent = procedure(Sender: TObject; const Error: integer; ErrString: string) of object;

  TBackupFile = class(TComponent)
  private
    FBackupTitle: string;
    fMaxSize: Integer;
    fBackupMode: TBackupmode;
    fRestoreMode: TRestoremode;
    fCompressionLevel: TCompressionLevel;
    fSetArchiveFlag: Boolean;
    fFilesTotal, fFilesProcessed, fSizeTotal, fProgressSize, fCompressedTotal: Integer;
    CurrentFile: string;
    IsBusy, Continue: boolean;
    fLastErr: integer;

    fInputStream, fOutputStream: TStream;
    fRestoreFullPath: Boolean;
    fSaveFileID: Boolean;

    fOnProgress: TProgressEvent;
    fOnNeedDisk: TNeedDiskEvent;
    fOnRestoreFile: TRestoreFileEvent;
    fOnFileRestored: TFileRestoredEvent;
    fOnError: TBackupErrorEvent;
    function GetVersion: string;
    procedure SetVersion(dummy: string);
    procedure SetBackupMode(value: TBackupmode);
    procedure DeCompress(InStream, OutStream: TStream; DoWrite: Boolean);
    procedure MessageError(err: integer);
  protected
  public
    property FilesTotal: Integer read fFilesTotal;
    property SizeTotal: Integer read fSizeTotal;
    property FilesProcessed: Integer read fFilesProcessed;
    function BackupToStream(const Filelist: TStrings; Target: TStream): boolean;
    function Backup(const Filelist: TStrings; Target: string): boolean;
    function RestoreFromStream(Source: TStream; TargetPath: string): boolean;
    function Restore(Source: string; TargetPath: string): boolean;
    function GetArchiveTitle(const Source: string; var Filelist: TStringlist): string;
    function GetArchiveTitleFromStream(Source: TStream; var Filelist: TStringlist): string;
    function CompressionRate: integer;
    function Busy: boolean;
    procedure Stop;
  published
    property Version: string read GetVersion write SetVersion;
    property BackupTitle: string read fBackupTitle write fBackupTitle;
    property BackupMode: TBackupmode read fBackupMode write SetBackupMode;
    property CompressionLevel: TCompressionLevel read fCompressionLevel write fCompressionLevel;
    property RestoreMode: TRestoremode read fRestoreMode write fRestoreMode;
    property MaxSize: Integer read fMaxSize write fMaxSize;
    property SetArchiveFlag: Boolean read fSetArchiveFlag write fSetArchiveFlag;
    property OnProgress: TProgressEvent read fOnProgress write fOnProgress;
    property OnNeedDisk: TNeedDiskEvent read fOnNeedDisk write fOnNeedDisk;
    property OnRestoreFile: TRestoreFileEvent read fOnRestoreFile write fOnRestoreFile;
    property OnFileRestored: TFileRestoredEvent read fOnFileRestored write fOnFileRestored;
    property OnError: TBackupErrorEvent read fOnError write fOnError;
    property RestoreFullPath: Boolean read fRestoreFullPath write fRestoreFullPath;
    property SaveFileID: Boolean read fSaveFileID write fSaveFileID;
  end;

const
  BufferSize = 16384; //32768;  optimize buffer size, disk size and update speed

  cVersion = '5.00';
  cInsertDisk = 'Please insert disk %s and click OK to continue.';
  fSignature = 'EC2';
  fOldSignature = 'ECS';

  idCantreadFile = 1;
  idCantwriteFile = 2;
  idCantreadArchive = 3;
  idCantwriteArchive = 4;
  idInvalidfiletype = 5;
  idCompression = 6;
  idCantCreateFileID = 7;

  errCantreadFile = 'Cannot read file';
  errCantwriteFile = 'Overwriting file failed';
  errCantreadArchive = 'Cannot read archive';
  errCantwriteArchive = 'Cannot write to archive';
  errInvalidfiletype = 'Invalid archive type';
  errCompression = 'Compression error';
  errCantCreateFileID = 'Cannot create temporary file to save the file IDs';

  zlib_Version = '1.1.3';

procedure Register;

implementation

const
  Z_NO_FLUSH = 0;
  Z_PARTIAL_FLUSH = 1;
  Z_SYNC_FLUSH = 2;
  Z_FULL_FLUSH = 3;
  Z_FINISH = 4;

  Z_OK = 0;
  Z_STREAM_END = 1;
  Z_NEED_DICT = 2;
  Z_ERRNO = (-1);
  Z_STREAM_ERROR = (-2);
  Z_DATA_ERROR = (-3);
  Z_MEM_ERROR = (-4);
  Z_BUF_ERROR = (-5);
  Z_VERSION_ERROR = (-6);

  Z_NO_COMPRESSION = 0;
  Z_BEST_SPEED = 1;
  Z_BEST_COMPRESSION = 9;
  Z_DEFAULT_COMPRESSION = (-1);

  Z_FILTERED = 1;
  Z_HUFFMAN_ONLY = 2;
  Z_DEFAULT_STRATEGY = 0;

  Z_BINARY = 0;
  Z_ASCII = 1;
  Z_UNKNOWN = 2;

  Z_DEFLATED = 8;


{$L deflate.obj}
{$L inflate.obj}
{$L inftrees.obj}
{$L trees.obj}
{$L adler32.obj}
{$L infblock.obj}
{$L infcodes.obj}
{$L infutil.obj}
{$L inffast.obj}

procedure _tr_init; external;
procedure _tr_tally; external;
procedure _tr_flush_block; external;
procedure _tr_align; external;
procedure _tr_stored_block; external;
procedure adler32; external;
procedure inflate_blocks_new; external;
procedure inflate_blocks; external;
procedure inflate_blocks_reset; external;
procedure inflate_blocks_free; external;
procedure inflate_set_dictionary; external;
procedure inflate_trees_bits; external;
procedure inflate_trees_dynamic; external;
procedure inflate_trees_fixed; external;
procedure inflate_trees_free; external;
procedure inflate_codes_new; external;
procedure inflate_codes; external;
procedure inflate_codes_free; external;
procedure _inflate_mask; external;
procedure inflate_flush; external;
procedure inflate_fast; external;

procedure _memset(P: Pointer; B: Byte; count: Integer); cdecl;
begin
  FillChar(P^, count, B);
end;

procedure _memcpy(dest, source: Pointer; count: Integer); cdecl;
begin
  Move(source^, dest^, count);
end;


function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar; recsize: Integer): Integer; external;
function deflate(var strm: TZStreamRec; flush: Integer): Integer; external;
function deflateEnd(var strm: TZStreamRec): Integer; external;

function inflateInit_(var strm: TZStreamRec; version: PChar; recsize: Integer): Integer; external;
function inflate(var strm: TZStreamRec; flush: Integer): Integer; external;
function inflateEnd(var strm: TZStreamRec): Integer; external;
function inflateReset(var strm: TZStreamRec): Integer; external;


function zlibAllocMem(AppData: Pointer; Items, Size: Integer): Pointer;
begin
  GetMem(Result, Items * Size);
end;

procedure zlibFreeMem(AppData, Block: Pointer);
begin
  FreeMem(Block);
end;


{ TBackupFile +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

function TBackupFile.GetVersion: string;
begin
  result := cVersion;
end;

procedure TBackupFile.SetVersion(dummy: string);
begin
end;

procedure TBackupFile.SetBackupMode(value: TBackupmode);
begin
  if value <> fBackupMode then
  begin
    if value = bmIncremental then SetArchiveFlag := true;
    fBackupMode := value;
  end;
end;

function TBackupFile.BackupToStream(const Filelist: TStrings; Target: TStream): boolean;
begin
  Result := false;
  if Target <> nil then
  try
    fOutputStream := Target;
    fMaxSize := 0;
    Result := Backup(Filelist, ':STREAM');
  except
    Result := false;
  end;
end;

function TBackupFile.Backup(const Filelist: TStrings; Target: string): boolean;
const
  Levels: array[TCompressionLevel] of ShortInt =
  (Z_BEST_SPEED, Z_NO_COMPRESSION, Z_DEFAULT_COMPRESSION, Z_BEST_COMPRESSION);

var
  ext: string;
  I, L: Integer;
  FA: integer;
  S: string;
  Files: TStringlist;
  Size: Longint;
  SStr: TFilestream;
  TStr: TStream;
  ArchiveNumber: Word;

  UseStream: boolean;

  FID: TStringlist;
  FIDTemp: string;
  TempFileP: array[0..255] of Char;

  procedure BackupFile;
  var
    InBuffer: array[0..BufferSize - 1] of Byte;
    OutBuffer: array[0..BufferSize - 1] of Byte;
    Res, CompressedSize, BytesRead: Integer;
    FZRec: TZStreamRec;
    IsCompressed: boolean;
  begin
    try
      IsCompressed := False;
      TStr.WriteBuffer(FSignature, SizeOf(FSignature)); //new signature "EC2" in ver 2.00!
      inc(fCompressedTotal, sizeof(FSignature));

      while (Size > 0) and Continue and ((TStr.position < (MaxSize - 100 - BufferSize)) or (MaxSize = 0)) do
      begin
//              if  (DiskFree(0)-10*1024) < size then break;

        BytesRead := SStr.Read(InBuffer, BufferSize);
        dec(Size, BytesRead);
        inc(fProgressSize, BytesRead);

        FillChar(FZRec, sizeof(FZRec), 0);
        FZRec.zalloc := zlibAllocMem;
        FZRec.zfree := zlibFreeMem;
        FZRec.next_out := @OutBuffer;
        FZRec.avail_out := sizeof(OutBuffer);

        if deflateInit_(FZRec, Levels[fCompressionLevel], zlib_version, sizeof(FZRec)) < 0 then
        begin
          fLastErr := idCompression;
          Continue := false;
        end;

        FZRec.next_in := @InBuffer;
        FZRec.avail_in := BytesRead;

        Res := deflate(FZRec, Z_FINISH);
        case Res of
          Z_OK: IsCompressed := false; //buffer to large, no compression
          Z_STREAM_END: IsCompressed := true; //compressed buffer
        else
          begin
            fLastErr := idCompression;
            continue := false;
          end;
        end;
        if Continue then
        begin
          if IsCompressed then
          begin
            CompressedSize := FZRec.total_out;
            TStr.WriteBuffer(CompressedSize, SizeOf(CompressedSize));
            TStr.Write(OutBuffer, CompressedSize);
          end
          else
          begin
            CompressedSize := BytesRead * (-1);
            TStr.WriteBuffer(CompressedSize, SizeOf(CompressedSize));
            TStr.Write(InBuffer, BytesRead);
          end;
        end;

        deflateEnd(FZRec);

        inc(fCompressedTotal, abs(CompressedSize));
        inc(fCompressedTotal, sizeof(CompressedSize));

        Application.processmessages;
        if assigned(fOnProgress) then fOnProgress(self, CurrentFile, (fProgressSize * 100) div fSizeTotal, Continue);
      end;

      CompressedSize := 0; //end of file or disk
      TStr.WriteBuffer(CompressedSize, SizeOf(CompressedSize));

      if (Size > 0) and Continue then
      begin
        inc(ArchiveNumber);
        ext := ('00' + inttostr(ArchiveNumber));
        ext := copy(ext, length(ext) - 2, 3);

        S := 'NEXT:DISK' + Ext;
        L := length(s);
        TStr.writeBuffer(L, sizeof(L)); //Size of file name
        TStr.writeBuffer(PChar(s)^, L); //file name

        TStr.free;
        TStr := nil;

        if assigned(fOnNeedDisk) then
          fOnNeedDisk(self, ArchiveNumber, Continue)
        else
          Continue := MessageDlg(Format(cInsertDisk, [inttostr(ArchiveNumber)]), mtInformation, mbOKCancel, 0) = mrOK;

        if Continue then
        begin
          Target := ChangeFileExt(target, '.' + ext);
          TStr := TFilestream.create(Target, fmCreate);
          TStr.seek(0, 0);
        end;
      end;

    except
      Continue := false;
      fLastErr := idCantWriteArchive;
    end;
  end;

  procedure FindFiles(pattern: string);
  var
    IncludeSubs: boolean;
    SR: TSearchRec;
    FindResult: Integer;
  begin
    pattern := lowercase(pattern);
    IncludeSubs := pos('/s', pattern) > 0;

    if IncludeSubs then
    begin
      pattern := trim(copy(pattern, 1, pos('/s', pattern) - 1));
      FindResult := FindFirst(ExtractFilePath(pattern) + '*.*', faDirectory, SR);
      while FindResult = 0 do
      begin
        if (SR.Name <> '.') and (SR.Name <> '..') and (sr.Attr and faDirectory > 0) then
        begin
          S := ExpandFilename(ExtractFilepath(pattern) + SR.name + '\' + extractfilename(pattern)) + ' /s';
          FindFiles(lowercase(S));
        end;
        FindResult := FindNext(SR);
      end;
      FindClose(SR);
    end;
    FindResult := FindFirst(pattern, faAnyFile - faDirectory, SR);
    while FindResult = 0 do
    begin
      S := lowercase(ExpandFilename(ExtractFilepath(pattern) + SR.name));
      if (files.indexof(S) = -1) and (S <> lowercase(Target)) then
      begin
        if BackupMode = bmAll then
          Files.add(S)
        else if (SR.Attr and faArchive > 0) then
          Files.add(S);
      end;
      FindResult := FindNext(SR);
    end;
    FindClose(SR);
  end;
begin
  UseStream := Target = ':STREAM';
  fLastErr := 0;
  IsBusy := true;
  Files := TStringlist.create;
  if fSaveFileID then FID := TStringlist.create;

  files.beginupdate;
  for I := 0 to Filelist.count - 1 do
    FindFiles(Filelist[i]);
  files.endupdate;

  result := false;
  Continue := true;
  if assigned(fOnProgress) then fOnProgress(self, '', 0, Continue);
  fSizeTotal := 0;
  fFilesProcessed := 0;
  for I := 0 to files.count - 1 do
    if Fileexists(files[i]) then
    try
      SStr := TFilestream.create(files[i], fmOpenRead or fmShareDenyNone);
      fSizeTotal := fSizeTotal + SStr.Size;