backup.pas

delphi 实现备份

unit backup;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  stdCtrls, LZRW1KH, 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;
  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;
    fOnError: TBackupErrorEvent;
    function  GetVersion: string;
    procedure SetVersion(dummy: string);
    procedure SetBackupMode(value: TBackupmode);
    procedure DeCompress(InStream, OutStream: TStream; DoWrite: Boolean);
    procedure DeCompressOldMethod(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 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 = '3.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.0.4';

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
     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
         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 pattern := trim(copy(pattern, 1, pos('/s',pattern)-1));

        FindResult := FindFirst(pattern, faAnyFile, SR);
        while FindResult = 0 do
        begin
            if (SR.Name <> '.') and (SR.Name <> '..') then
            begin
              if (SR.Attr AND faDirectory > 0) then
              begin
                   S := ExpandFilename(ExtractFilepath(pattern)+SR.name+'\'+extractfilename(pattern))+' /s';
                   if IncludeSubs then FindFiles(lowercase(S));
              end else
              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;
              end;
            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;
               if fSaveFileID then FID.add(files[i] + #9 + inttostr(Fileage(Files[i])) + '=' + inttostr(SStr.size));
            finally
               SStr.free;
            end;

     if fSaveFileID then
     try