custarchiver.pas

本系统在一些大中型企业(跨多达24个区域)一直都在很好的服务过

unit CustArchiver;

interface
uses
  Windows,
  SysUtils,
  Classes,
  ArchiverMisc,
  ArchiverRoot,
  CustExtractor;

type
  TPathStorage = (psNone, psWhole, psRelative);

  TCompressionLevel = (clMaximum, clNormal, clFast, clSuperFast, clNone );

  TOnAddFileEvent          = procedure ( Sender : TObject; var FileEntry : TFileEntry; var Accept : Boolean ) of Object;
  TOnFileAddedEvent        = procedure ( Sender : TObject; const FileEntry : TFileEntry ) of Object;
  TOnCompressBlockEvent    = function ( Sender : TObject; DestBlock : PChar; var DestSize : Integer; SrcBlock : PChar; SrcSize : Integer; Level : TCompressionLevel) : Boolean of Object;
  TOnDeleteFileEvent       = procedure ( Sender : TObject; const FileEntry : TFileEntry; var Accept : Boolean ) of Object;
  TOnCryptBlockEvent       = procedure ( Sender : TObject; DestBlock, SrcBlock : PChar; var DestSize : Integer; SrcSize : Integer) of Object;
  TOnNeedNewDiskEvent      = procedure ( Sender : TObject; Segment : Integer; var Drive : String ) of Object;
  TOnNeedNewFolderEvent    = procedure ( Sender : TObject; Segment : Integer; var Path : String ) of Object;
  TOnClearDiskEvent        = procedure ( Sender : TObject; const Drive : String ) of Object;
  TOnWriteSFXCodeEvent     = procedure ( Sender : TObject; Stream : TStream ) of Object;

  EArchiverCompress = class( EArchiver );

  TArchMessages = class(TExtrMessages)
    protected
      FCouldNotCompressBlock : String;
      FDeleteFileEventNeeded : String;
      FCouldNotRenameArchive : String;
      FInsertNewDisk : String;
      FSelectNewPlace : String;
      FNotEnoughFreeSpaceOn : String;
      FUnableToDeleteFiles : String;
      FConfirmFileDeletion : String;
      FMaxSegmentSizeTooSmall : String;
      FCantPerformThisOp : String;
      FAddingFile : String;
      FDeletingFiles : String;
      FDeleteFile : String;
      FMakingSFXArchive : String;
      FCompressingSolidArchive : String;
      FCopyingArchive : String;
      FCouldNotCopyArchive : String;
      FUpdatingFile : String;
      FReplacingFile : String;

      procedure AssignTo(Dest: TPersistent); override;

    public
      procedure SetLanguage( language : TLanguage ); override;

    published
      property CouldNotCompressBlock : String read FCouldNotCompressBlock write FCouldNotCompressBlock;
      property DeleteFileEventNeeded : String read FDeleteFileEventNeeded write FDeleteFileEventNeeded;
      property CouldNotRenameArchive : String read FCouldNotRenameArchive write FCouldNotRenameArchive;
      property InsertNewDisk : String read FInsertNewDisk write FInsertNewDisk;
      property SelectNewPlace : String read FSelectNewPlace write FSelectNewPlace;
      property NotEnoughFreeSpaceOn : String read FNotEnoughFreeSpaceOn write FNotEnoughFreeSpaceOn;
      property UnableToDeleteFiles : String read FUnableToDeleteFiles write FUnableToDeleteFiles;
      property ConfirmFileDeletion : String read FConfirmFileDeletion write FConfirmFileDeletion;
      property MaxSegmentSizeTooSmall : String read FMaxSegmentSizeTooSmall write FMaxSegmentSizeTooSmall;
      property CantPerformThisOp : String read FCantPerformThisOp write FCantPerformThisOp;
      property AddingFile : String read FAddingFile write FAddingFile;
      property DeletingFiles : String read FDeletingFiles write FDeletingFiles;
      property DeleteFile : String read FDeleteFile write FDeleteFile;
      property MakingSFXArchive : String read FMakingSFXArchive write FMakingSFXArchive;
      property CompressingSolidArchive : String read FCompressingSolidArchive write FCompressingSolidArchive;
      property CopyingArchive : String read FCopyingArchive write FCopyingArchive;
      property CouldNotCopyArchive : String read FCouldNotCopyArchive write FCouldNotCopyArchive;
      property UpdatingFile : String read FUpdatingFile write FUpdatingFile;
      property ReplacingFile : String read FReplacingFile write FReplacingFile;
  end;

  TCustomArchiver = class( TCustomExtractor )
  protected
    FPathStorage : TPathStorage;
    FRelativePath : String;
    FMinFreeSpace : Integer;
    FCompressionLevel : TCompressionLevel;
    FReserveSpace : Integer;

    FOnAddFile : TOnAddFileEvent;
    FOnFileAdded : TOnFileAddedEvent;
    FOnCompressBlock : TOnCompressBlockEvent;
    FOnDeleteFile : TOnDeleteFileEvent;
    FOnCryptBlock : TOnCryptBlockEvent;
    FOnNeedNewDisk : TOnNeedNewDiskEvent;
    FOnNeedNewFolder : TOnNeedNewFolderEvent;
    FOnClearDisk : TOnClearDiskEvent;
    FOnWriteSFXCode : TOnWriteSFXCodeEvent;

    function  CreateMessages : TMessages; override;
    function  GetMessages : TArchMessages;
    procedure SetMessages( val : TArchMessages );
    procedure CompressStream( src : TStream );
    function  CompressBlock( DestBlock : PChar; var DestSize : Integer; SrcBlock : PChar; SrcSize : Integer ) : Boolean; virtual;
    procedure CryptBlock( DestBlock, SrcBlock : PChar; var DestSize : Integer; SrcSize : Integer); virtual;
    procedure SetMaxSegmentSize( val : Integer );
    function  RequestSpace( val : Integer ) :  Boolean; override;
    function  IsValidDrive( const drive : String ) : Boolean;
    function  CanUseDrive( const drive : String ) : Boolean;
    procedure AskNewDisk;
    procedure NextSegment;
    procedure CreateSegment;
    procedure CreateArchive; override;
    function  GetFreeSpace( drive : String ) : Integer;
    function  CompressionLevelAsInteger : Integer; virtual;
    procedure WriteSFXCode( S : TStream ); virtual;
    procedure AfterUpdate; override;
    function  CompressSolidData : String;
    procedure CloseSolidData; override;
    function  GetOpenMode : Integer; override;
    procedure UpdateArchiveSize;
    procedure BeforeClose; override;

  public
    // Creators & Destructor
    constructor Create( AOwner : TComponent ); override;

    // Public methods

    function  AddFile( const FileName : String ) : Boolean;
    function  AddFiles( files : TStrings ) : Boolean;
    function  AddDirectory( const Directory : String ) : Boolean;
    procedure DeleteFiles;
    function  MakeSFX : Boolean;
    procedure SetArchiveComment( const comment : String );

    // Misc methods
    procedure EraseDrive( const drive : String );

    // Public properties
    property ReserveSpace : Integer read FReserveSpace write FReserveSpace;

  published
    // Properties
    property CompressionLevel : TCompressionLevel read FCompressionLevel write FCompressionLevel;
    property MaxSegmentSize : Integer read FMaxSegmentSize write SetMaxSegmentSize;
    property Messages : TArchMessages read GetMessages write SetMessages;
    property MinFreeSpace : Integer read FMinFreeSpace write FMinFreeSpace;
    property PathStorage : TPathStorage read FPathStorage write FPathStorage;
    // Events
    property OnAddFile : TOnAddFileEvent read FOnAddFile write FOnAddFile;
    property OnCompressBlock : TOnCompressBlockEvent read FOnCompressBlock write FOnCompressBlock;
    property OnDeleteFile : TOnDeleteFileEvent read FOnDeleteFile write FOnDeleteFile;
    property OnFileAdded : TOnFileAddedEvent read FOnFileAdded write FOnFileAdded;
    property OnCryptBlock : TOnCryptBlockEvent read FOnCryptBlock write FOnCryptBlock;
    property OnNeedNewDisk : TOnNeedNewDiskEvent read FOnNeedNewDisk write FOnNeedNewDisk;
    property OnNeedNewFolder : TOnNeedNewFolderEvent read FOnNeedNewFolder write FOnNeedNewFolder;
    property OnClearDisk : TOnClearDiskEvent read FOnClearDisk write FOnClearDisk;
    property OnWriteSFXCode : TOnWriteSFXCodeEvent read FOnWriteSFXCode write FOnWriteSFXCode;
  end;


implementation

////////////////////////////////////////////////////////////

procedure TArchMessages.AssignTo(Dest: TPersistent);
begin
  if Dest is TMessages then
    with TMessages( Dest ) do begin
      FCouldNotCompressBlock   := Self.FCouldNotCompressBlock;
      FDeleteFileEventNeeded   := Self.FDeleteFileEventNeeded;
      FCouldNotRenameArchive   := Self.FCouldNotRenameArchive;
      FInsertNewDisk           := Self.FInsertNewDisk;
      FSelectNewPlace          := Self.FSelectNewPlace;
      FNotEnoughFreeSpaceOn    := Self.FNotEnoughFreeSpaceOn;
      FUnableToDeleteFiles     := Self.FUnableToDeleteFiles;
      FConfirmFileDeletion     := Self.FConfirmFileDeletion;
      FMaxSegmentSizeTooSmall  := Self.FMaxSegmentSizeTooSmall;
      FCantPerformThisOp       := Self.FCantPerformThisOp;
      FAddingFile              := Self.FAddingFile;
      FDeletingFiles           := Self.FDeletingFiles;
      FDeleteFile              := Self.FDeleteFile;
      FMakingSFXArchive        := Self.FMakingSFXArchive;
      FCompressingSolidArchive := Self.FCompressingSolidArchive;
      FCopyingArchive          := Self.FCopyingArchive;
      FCouldNotCopyArchive     := Self.FCouldNotCopyArchive;
      FUpdatingFile            := Self.FUpdatingFile;
      FReplacingFile           := Self.FReplacingFile;
    end;
  inherited AssignTo( Dest );
end;

procedure TArchMessages.SetLanguage( language : TLanguage );
var
  lang : TLanguage;
begin
  inherited;
  if FLanguage = lgAutomatic then
    lang := GetUserLanguage
  else
    lang := FLanguage;
  case lang of
    lgEnglish:
      begin
        FCouldNotCompressBlock := 'Could not compress Block';
        FDeleteFileEventNeeded := 'You must define the event OnDeleteFile in order to filter the files that must be deleted.';
        FCouldNotRenameArchive := 'Could not rename archive from "%s" to "%s"';
        FInsertNewDisk := 'Insert new disk for segment #%d in drive %s';
        FSelectNewPlace := 'Select a new place for storing the segment #%d of Archive %s';
        FNotEnoughFreeSpaceOn := 'There''s not enough free space on drive %s';
        FUnableToDeleteFiles := 'Unable to delete files from a segmented archive';
        FConfirmFileDeletion := 'Drive %s contains files. Do you want to delete them ?';
        FMaxSegmentSizeTooSmall := 'Maximum size of a Segment is too small (property MaxSegmentSize)';
        FCantPerformThisOp := 'Can''t perform this operation on a segmented archive';
        FAddingFile := 'Adding %s (%.0n)';
        FDeletingFiles := 'Deleting files...';
        FDeleteFile := 'Delete file %s';
        FMakingSFXArchive := 'Making a SFX archive...';
        FCompressingSolidArchive := 'Compressing solid archive';
        FCopyingArchive := 'Copying archive...';
        FCouldNotCopyArchive := 'Could not copy archive';
        FUpdatingFile := 'Updating %s (%.0n)';
        FReplacingFile := 'Replacing %s (%.0n)';
     end;
    lgFrench:
      begin
        FCouldNotCompressBlock := 'Impossible de compresser le bloc de donn閑s';
        FDeleteFileEventNeeded := 'Vous devez d閒inir l''関閚ement OnDeleteFile afin de filtrer les fichiers devant 阾re supprim閟.';
        FCouldNotRenameArchive := 'Impossible de renommer l''archive "%s" en "%s"';
        FInsertNewDisk := 'Ins閞ez un nouveau disque pour le segment #%d dans l''unit