custextractor.pas

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

unit CustExtractor;
{
  TArchiver by Morgan Martinet (C) 1998 - [e-mail] or [e-mail]

  COPYRIGHT
  ---------

  This component is email-ware. You may use it, distribute it and modify it, but
  you may not charge for it. Please send me a mail if you use it, I'll be happy
  to see in which country it is used, and I'll be able to mail you the updates.

  In case of modifications you must mail me a copy of the modifications.
  The reason are simple: Any changes that improve this free-ware component should
  be to benefit for everybody, not only you. That way you can be pretty sure,
  that this component has few errors and much functionality.
  In case of modifications, you will be on the credits list beneath.

  DESCRIPTION
  -----------

  This component lets you add/extract files to/from an archive.

}

interface

uses
  Windows,
  SysUtils,
  ArchiverMisc,
  ArchiverRoot,
  CustSFXGenerator,
  Classes;

type
  TRestoreAction = (raOverwrite, raSkip, raUpdate, raAsk, raExistingOnly, raUpdateExisting);

  TOnEnumerationEvent        = procedure ( Sender : TObject; const FileEntry : TFileEntry ) of Object;
  TOnExtractFileEvent        = procedure ( Sender : TObject; const FileEntry : TFileEntry;
                                           var DestPath : String; var Accept : Boolean ) of Object;
  TOnFileExtractedEvent      = procedure ( Sender : TObject; const FileEntry : TFileEntry; const DestPath : String ) of Object;
  TOnUncompressBlockEvent    = function ( Sender : TObject; DestBlock : PChar; var DestSize : Integer; SrcBlock : PChar; SrcSize : Integer) : Boolean of Object;
  TOnDecryptBlockEvent       = procedure ( Sender : TObject; DestBlock, SrcBlock : PChar; var DestSize : Integer; SrcSize : Integer) of Object;
  TOnInsertDiskEvent         = procedure ( Sender : TObject; Segment : Integer; var Drive : String ) of Object;
  TOnInsertLastDiskEvent     = procedure ( Sender : TObject; var Drive : String ) of Object;
  TOnLocateSegmentEvent      = procedure ( Sender : TObject; Segment : Integer; var FileName : String ) of Object;
  TOnLocateLastSegmentEvent  = procedure ( Sender : TObject; var Path : String ) of Object;

  EArchiverUncompress = class( EArchiver );
  EArchiverBadCRC     = class( EArchiver );
  EArchiverBadKey     = class( EArchiver );

  TExtrMessages = class(TMessages)
    protected
      FCouldNotUncompressBlock : String;
      FAskOverwrite : String;
      FNeedExtractPath : String;
      FInsertDisk : String;
      FLocateSegment : String;
      FWrongSegment : String;
      FInsertLastSegment : String;
      FLocateLastSegment : String;
      FWrongLastSegment : String;
      FWrongNextSegment : String;
      FBadCRC : String;
      FBadKey : String;
      FReplaceFile : String;
      FWithFile : String;
      FConfirmFileOverwrite : String;
      FExtractingFile : String;
      FLoadingArchiveContnent : String;
      FUncompressingSolidArchive : String;
      FCheckingFile : String;

      procedure AssignTo(Dest: TPersistent); override;
      procedure SetGlobalStrings; override;

    public
      procedure SetLanguage( language : TLanguage ); override;

    published
      property CouldNotUncompressBlock : String read FCouldNotUncompressBlock write FCouldNotUncompressBlock;
      property AskOverwrite : String read FAskOverwrite write FAskOverwrite;
      property NeedExtractPath : String read FNeedExtractPath write FNeedExtractPath;
      property InsertDisk : String read FInsertDisk write FInsertDisk;
      property LocateSegment : String read FLocateSegment write FLocateSegment;
      property WrongSegment : String read FWrongSegment write FWrongSegment;
      property InsertLastSegment : String read FInsertLastSegment write FInsertLastSegment;
      property LocateLastSegment : String read FLocateLastSegment write FLocateLastSegment;
      property WrongLastSegment : String read FWrongLastSegment write FWrongLastSegment;
      property WrongNextSegment : String read FWrongNextSegment write FWrongNextSegment;
      property BadCRC : String read FBadCRC write FBadCRC;
      property BadKey : String read FBadKey write FBadKey;
      property ReplaceFile : String read FReplaceFile write FReplaceFile;
      property WithFile : String read FWithFile write FWithFile;
      property ConfirmFileOverwrite : String read FConfirmFileOverwrite write FConfirmFileOverwrite;
      property ExtractingFile : String read FExtractingFile write FExtractingFile;
      property LoadingArchiveContnent : String read FLoadingArchiveContnent write FLoadingArchiveContnent;
      property UncompressingSolidArchive : String read FUncompressingSolidArchive write FUncompressingSolidArchive;
      property CheckingFile : String read FCheckingFile write FCheckingFile;
  end;

  TCustomExtractor = class( TArchiverRoot )
  protected
    FExtractPath : String;
    FRestoreAction : TRestoreAction;
    FSFXGenerator : TCustomSFXGenerator;
    FAlwaysOverwrite : Boolean;

    FOnEnumeration : TOnEnumerationEvent;
    FOnExtractFile : TOnExtractFileEvent;
    FOnFileExtracted : TOnFileExtractedEvent;
    FOnUncompressBlock : TOnUncompressBlockEvent;
    FOnDecryptBlock : TOnDecryptBlockEvent;
    FOnInsertDisk : TOnInsertDiskEvent;
    FOnInsertLastDisk : TOnInsertLastDiskEvent;
    FOnLocateSegment : TOnLocateSegmentEvent;
    FOnLocateLastSegment : TOnLocateLastSegmentEvent;
    FOnSegmentChanged : TNotifyEvent;

    function  CreateMessages : TMessages; override;
    function  GetMessages : TExtrMessages;
    procedure SetMessages( val : TExtrMessages );
    procedure UncompressStream( dest : TStream );
    function  UncompressBlock( DestBlock : PChar; var DestSize : Integer; SrcBlock : PChar; SrcSize : Integer) : Boolean; virtual;
    procedure DecryptBlock( DestBlock, SrcBlock : PChar; var DestSize : Integer; SrcSize : Integer); virtual;
    procedure SkipFile( anOffset : Integer );
    function  Eof( S : TStream ) : Boolean;
    function  SegmentBelongsToArchive( const aFileName : String; var AHeader : TArchiveHeader ) : Boolean;
    procedure OpenSegment( val : Integer );
    procedure CloseSegment;
    procedure NeedFirstSegment;
    procedure NeedLastSegment;
    function  CheckEOF : Boolean; override;
    procedure GetProgressInformations; override;
    procedure ExtractFileData( const fileEntry : TFileEntry; const DestFileName : String );
    function  GetDestinationPath( const fileEntry : TFileEntry ) : String;
    procedure CheckCurrentFile( const last, new : TFileEntry );
    procedure AfterOpen; override;
    procedure BeforeClose; override;
    procedure CheckSFX( const aFileName : String ); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure AdjustSolidOptions;
    procedure OpenSolidData; override;
    procedure CloseSolidData; override;
    function  GetOpenMode : Integer; override;
    procedure Start; override;

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

    // Public methods

    procedure EnumerateFiles;
    procedure ExtractFile( aSegment : Word; anOffset, compressedSize : Integer );
    procedure ExtractFileTo( aSegment : Word; anOffset, compressedSize : Integer; const DestFileName : String );
    procedure ExtractFiles;
    procedure CheckIntegrity;

  published
    // Properties
    property ExtractPath : String read FExtractPath write FExtractPath;
    property Messages : TExtrMessages read GetMessages write SetMessages;
    property RestoreAction : TRestoreAction read FRestoreAction write FRestoreAction;
    property SFXGenerator : TCustomSFXGenerator read FSFXGenerator write FSFXGenerator;

    // Events
    property OnEnumeration : TOnEnumerationEvent read FOnEnumeration write FOnEnumeration;
    property OnExtractFile : TOnExtractFileEvent read FOnExtractFile write FOnExtractFile;
    property OnFileExtracted : TOnFileExtractedEvent read FOnFileExtracted write FOnFileExtracted;
    property OnUncompressBlock : TOnUncompressBlockEvent read FOnUncompressBlock write FOnUncompressBlock;
    property OnDecryptBlock : TOnDecryptBlockEvent read FOnDecryptBlock write FOnDecryptBlock;
    property OnInsertDisk : TOnInsertDiskEvent read FOnInsertDisk write FOnInsertDisk;
    property OnInsertLastDisk : TOnInsertLastDiskEvent read FOnInsertLastDisk write FOnInsertLastDisk;
    property OnLocateSegment : TOnLocateSegmentEvent read FOnLocateSegment write FOnLocateSegment;
    property OnLocateLastSegment : TOnLocateLastSegmentEvent read FOnLocateLastSegment write FOnLocateLastSegment;
    property OnSegmentChanged : TNotifyEvent read FOnSegmentChanged write FOnSegmentChanged;
  end;

implementation

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

procedure TExtrMessages.AssignTo(Dest: TPersistent);
begin
  if Dest is TExtrMessages then
    with TExtrMessages( Dest ) do begin
      FCouldNotUncompressBlock   := Self.FCouldNotUncompressBlock;
      FAskOverwrite              := Self.FAskOverwrite;
      FNeedExtractPath           := Self.FNeedExtractPath;
      FInsertDisk                := Self.FInsertDisk;
      FLocateSegment             := Self.FLocateSegment;
      FWrongSegment              := Self.FWrongSegment;
      FInsertLastSegment         := Self.FInsertLastSegment;
      FLocateLastSegment         := Self.FLocateLastSegment;
      FWrongLastSegment          := Self.FWrongLastSegment;
      FWrongNextSegment          := Self.FWrongNextSegment;
      FBadCRC                    := Self.FBadCRC;
      FBadKey                    := Self.FBadKey;
      FReplaceFile               := Self.FReplaceFile;
      FWithFile                  := Self.FWithFile;
      FConfirmFileOverwrite      := Self.FConfirmFileOverwrite;
      FExtractingFile            := Self.FExtractingFile;
      FLoadingArchiveContnent    := Self.FLoadingArchiveContnent;
      FUncompressingSolidArchive := Self.FUncompressingSolidArchive;
      FCheckingFile              := Self.FCheckingFile;
    end;
  inherited AssignTo( Dest );
end;

procedure TExtrMessages.SetLanguage( language : TLanguage );
var
  lang : TLanguage;
begin
  inherited;
  if FLanguage = lgAutomatic then
    lang := GetUserLanguage
  else
    lang := FLanguage;
  case lang of
    lgEnglish:
      begin
        FCouldNotUncompressBlock := 'Could not uncompress Block';
        FNeedExtractPath := 'I need a path for the extraction (property ExtractPath)';
        FInsertDisk := 'Insert disk for segment #%d in drive %s';
        FLocateSegment := 'Locate segment #%d of Archive %s';
        FWrongSegment := 'This was not the segment #%d of Archive %s !';
        FInsertLastSegment := 'Insert disk containing the last segment in drive %s';
        FLocateLastSegment := 'Locate last segment of Archive %s';
        FWrongLastSegment := 'This is not the last segment !';
        FWrongNextSegment := 'This segment is not the next in the sequence';
        FBadCRC := 'Bad CRC: data stored in the archive is corrupted';
        FBadKey := 'The file could not be decrypted. You entered a bad key';
        FReplaceFile := 'Replace File :';
        FWithFile := 'With File :';
        FConfirmFileOverwrite := 'Confirm File Overwrite';
        FExtractingFile := 'Extracting %s (%d)';
        FLoadingArchiveContnent := 'Loading archive content...';
        FUncompressingSolidArchive := 'Uncompressing solid archive...';
        FCheckingFile := 'Checking %s (%d)';
      end;
    lgFrench:
      begin
        FCouldNotUncompressBlock := 'Impossible de d閏ompresser le bloc de donn閑s';
        FNeedExtractPath := 'J''ai besoin d''un r閜ertoire pour extraire les fichiers (propri閠