vclzip.pas

一个delphi中压缩的组件VCLZip

{ ********************************************************************************** }
{                                                                                    }
{   COPYRIGHT 1997 Kevin Boylan                                                    }
{     Source File: VCLZip.pas                                                        }
{     Description: VCLZip component - native Delphi unzip component.                 }
{     Date:        March 1997                                                        }
{     Author:      Kevin Boylan, [e-mail]                                 }
{                                                                                    }
{                                                                                    }
{ ********************************************************************************** }
unit VCLZip;

{$I KPDEFS.INC}

{$P-} { turn off open parameters }
{$R-}   { 3/10/98 2.03 }
{$Q-}   { 3/10/98 2.03 }
{$B-} { turn off complete boolean eval } { 12/24/98  2.17 }

interface

uses
{$IFDEF WIN32}
 Windows,
{$ELSE}
 WinTypes, WinProcs, kpSHuge,
{$ENDIF}
  SysUtils, Messages, Classes,
  {$IFDEF KPSMALL}
   kpSmall,
  {$ELSE}
  Dialogs, Forms, Controls,
  {$ENDIF}
  KpLib, VCLUnZip, kpZipObj, kpMatch {$IFNDEF NO_RES}, kpzcnst {$ENDIF};

{$IFNDEF WIN32}
  {$DEFINE WIN16}
{$ELSE}
  {$IFOPT C+}
     {$DEFINE ASSERTS}
  {$ENDIF}
{$ENDIF}

type
  usigned = word;
  WPos = WORD;
  IPos = usigned;
  uch = Byte;
  EInvalidMatch = Class( Exception );
  ct_dataPtr = ^ct_data;
  ct_data = packed Record
     fc: Record
           Case Integer of
              0: (freq:   WORD );
              1: (code:   WORD );
         end;
     dl: Record
           Case Integer of
              0: (dad:    WORD );
              1: (len:    WORD );
         end;
  end;
  ct_dataArrayPtr = ^ct_dataArray;
 ct_dataArray = array [0..(MAX_USHORT div SizeOf(ct_data))-1] of ct_data;
  static_ltreePtr = ^static_ltree_type;
  static_dtreePtr = ^static_dtree_type;
  static_ltree_type = array [0..L_CODES+1] of ct_data;
  static_dtree_type = array [0..D_CODES-1] of ct_data;

  windowtypePtr = ^windowtype;
  prevtypePtr = ^prevtype;
  headtypePtr = ^headtype;
  l_buftypePtr = ^l_buftype;
  d_buftypePtr = ^d_buftype;
  flag_buftypePtr = ^flag_buftype;

  {$IFDEF WIN32}
  windowtype = array[0..2*WSIZE-1] of uch;
  prevtype = array[0..WSIZE-1] of WPos;
  headtype =  array[0..HASH_SIZE-1] of WPos;
  l_buftype = array [0..LIT_BUFSIZE-1] of Byte;
  d_buftype = array [0..DIST_BUFSIZE-1] of WORD;
  flag_buftype = array [0..(LIT_BUFSIZE div 8)-1] of Byte;
  {$ELSE}
  windowtype = array[0..0] of Byte;
  prevtype = array[0..0] of Word;
  headtype = array[0..0] of Word;
  l_buftype = array[0..0] of Byte;
  d_buftype = array[0..0] of Word;
  flag_buftype = array[0..0] of Byte;
  {$ENDIF}

  TZipAction = (zaUpdate, zaReplace, zaFreshen);

  TStartZipInfo = procedure( Sender: TObject; NumFiles: Integer; TotalBytes: Comp;
              var EndCentralRecord: TEndCentral; var StopNow: Boolean ) of Object;
  TStartZipEvent = procedure( Sender: TObject; FName: String;
                 var ZipHeader: TZipHeaderInfo; var Skip: Boolean ) of Object;
  TEndZipFileEvent = procedure( Sender: TObject; FName: String; UncompressedSize,
                             CompressedSize, CurrentZipSize: LongInt ) of Object;
  TDisposeEvent = procedure( Sender: TObject; FName: String; var Skip: Boolean ) of Object;
  TDeleteEvent = procedure( Sender: TObject; FName: String ; var Skip: Boolean ) of Object;
  TNoSuchFileEvent = procedure( Sender: TObject; FName: String ) of Object;
  TZipComplete = procedure( Sender : TObject; FileCount : Integer) of Object;
  TUpdateAction = (uaReplacing, uaKeeping);   { 7/5/99  2.18+ }
  TUpdateEvent = procedure( Sender: TObject; UDAction: TUpdateAction;
                             FileIndex: Integer ) of Object; { 7/5/99  2.18+ }
  TPrepareNextDisk = procedure( Sender: TObject; DiskNum: Integer ) of Object; { 7/9/00 2.21b3+ }
  TOnRecursingFile = procedure( Sender: TObject; FName: String ) of Object; { 7/9/01 2.21+ }
  TEncryptEvent = procedure( Sender: TObject; buffer: BytePtr; length: Integer;
                                Password: String ) of Object; {12/8/01 2.22+}

 TMultiZipInfo = class(TPersistent)
  private
    FBlockSize: LongInt;
    FFirstBlockSize: LongInt;
    FSaveOnFirstDisk: LongInt; { 8/15/99 2.18+ }
    FSaveZipInfo: Boolean;     { 8/15/99 2.18+ }
    FMultiMode: TMultiMode;
    FCheckDiskLabels: Boolean;
    FWriteDiskLabels: Boolean;

  public
    Constructor Create;
    procedure Assign(Source: TPersistent); override;
  published
    property BlockSize: LongInt read FBlockSize write FBlockSize default 1457600;
    property FirstBlockSize: LongInt read FFirstBlockSize write FFirstBlockSize default 1457600;
    property SaveOnFirstDisk: LongInt read FSaveOnFirstDisk write FSaveOnFirstDisk default 0;
    property SaveZipInfoOnFirstDisk: Boolean read FSaveZipInfo write FSaveZipInfo default False;
    property MultiMode: TMultiMode read FMultiMode write FMultiMode default mmNone;
    property CheckDiskLabels: Boolean read FCheckDiskLabels write FCheckDiskLabels default True;
    property WriteDiskLabels: Boolean read FWriteDiskLabels write FWriteDiskLabels default True;
 end;

 TVCLZip = class(TVCLUnZip)
  private
     FPackLevel:    Integer;
     FRecurse:      Boolean;
     FDispose:      Boolean;
     FStorePaths:   Boolean;
     FRelativePaths: Boolean;
     FStoreVolumes: Boolean;
     FZipAction:    TZipAction;
     FBlockSize:    LongInt;
     FMultiZipInfo: TMultiZipInfo;
     FStore83Names: Boolean;
     FTempPath:     String;
     FSkipIfArchiveBitNotSet: Boolean; { 7/4/98 2.13 }
     FResetArchiveBitOnZip: Boolean; { Added 4-Jun-98 SPF 2.13 }
     FExcludeList: TStrings;    { 9/27/98  2.15 }
     FNoCompressList: TStrings; { 9/27/98  2.15 }
     FOnZipComplete: TZipComplete;
     {$IFDEF UNDER_DEVELOPMENT}
     FOtherVCLZip:  TVCLZip;    { 10/24/99 2.20b3+ }
     {$ENDIF}

     FOnStartZipInfo: TStartZipInfo;
     FOnStartZip:   TStartZipEvent;
     FOnDisposeFile: TDisposeEvent;
     FOnEndZip: TEndZipFileEvent;
     FOnDeleteEntry: TDeleteEvent;
     FOnNoSuchFile: TNoSuchFileEvent;
     FOnUpdate: TUpdateEvent; { 7/5/99  2.18+ }
     FOnPrepareNextDisk: TPrepareNextDisk; { 7/9/00 2.21b3+ }
     FOnRecursingFile: TOnRecursingFile;  { 7/9/01 2.21+ }
     FOnEncrypt: TEncryptEvent; { 12/8/01 2.22+ }

     AmountWritten: BIGINT;
     AmountToWrite: BIGINT;
     UsingTempFile: Boolean;
     CreatingSFX: Boolean;
     SFXStubFile: TLFNFileStream;
     FPreserveStubs: Boolean;
     FAddDirEntries: Boolean;
     FFileOpenMode: Word;

  protected
    { Protected declarations }
     zfile:         TStream; { output compression file }
     IFile:         TStream; { input file to compress }
     mfile:         TStream; { temporary file during spanned file creation }
     IFileName:     String;
     isize:         LongInt;
     tmpfiles:      TSortedZip;
     tmpfiles2:     TSortedZip;
     tmpecrec:      TEndCentral;
     tmpfile_info:  TZipHeaderInfo;
     tmpZipName:    String;
     mZipName:      String;
     Deleting:      Boolean;
     FileBytes:     LongInt;
     SaveNewName:   String;

  static_ltree:  static_ltree_type;
  static_dtree:  static_dtree_type;
  bl_count:      array [0..MAX_ZBITS] of WORD;
  base_dist:     array [0..D_CODES-1] of Integer;
  length_code:   array [0..MAX_MATCH-MIN_MATCH] of Byte;
  dist_code:     array [0..511] of Byte;
  base_length:   array [0..LENGTH_CODES-1] of Integer;
  TRInitialized: Boolean;
  {$IFDEF WIN16}
  windowObj:     TkpHugeByteArray;
  prevObj:       TkpHugeWordArray;
  headObj:       TkpHugeWordArray;
  l_bufObj:      TkpHugeByteArray;
  d_bufObj:      TkpHugeWordArray;
  flag_bufObj:   TkpHugeByteArray;
  {$ENDIF}
  window:        windowtypePtr;
  prev:          prevtypePtr;
  head:          headtypePtr;
  l_buf:         l_buftypePtr;
  d_buf:         d_buftypePtr;
  flag_buf:      flag_buftypePtr;

    function zfwrite(buf: BytePtr; item_size, nb: Integer): LongInt;
    function zencode(c: Byte): Byte;
    function file_read( w: BytePtr; size: usigned ): LongInt;
    procedure CreateTempZip;
    function Deflate: LongInt;
    function ProcessFiles: Integer;
    function AddFileToZip( FName: String ): Boolean;
    {procedure MoveExistingFiles;}
    procedure MoveFile( Index: Integer );
    procedure MoveTempFile;
    procedure StaticInit;
    procedure CryptHead( passwrd: String );

    procedure SetZipName( ZName: String ); override;
    function GetIsModified: Boolean;
    procedure SetMultiZipInfo(Value: TMultiZipInfo);
    function GetCheckDiskLabels: Boolean; override;
    procedure SetStoreVolumes( Value: Boolean );
    function GetMultiMode: TMultiMode; override;
    procedure SetCheckDiskLabels( Value: Boolean ); override;
    procedure SetMultiMode( Value: TMultiMode ); override;
    procedure ResetArchiveBit(AFileName: string); { Added 4-Jun-98 SPF 2.13? }
    function DiskRoom: BIGINT;
    function RoomLeft: BIGINT;
    procedure NextPart;
    procedure LabelDisk;
    procedure SaveZipInfoToFile( Filename: String );   { 8/14/99 2.18+ }

    procedure SetDateTime(Index: Integer; DT: TDateTime );
    procedure SetPathname(Index: Integer; Value: TZipPathname);
    procedure SetFilename(Index: Integer; Value: String);
    procedure SetStorePaths(Value: Boolean);
    procedure SetRelativePaths(Value: Boolean);

    function  TemporaryPath: String;
    procedure SetExcludeList(Value: TStrings);             { 9/27/98  2.15 }
    procedure SetNoCompressList(Value: TStrings);          { 9/27/98  2.15 }
    function IsInExcludeList( N: String ): Boolean;        { 9/27/98  2.15 }
    function IsInNoCompressList( N: String ): Boolean;     { 9/27/98  2.15 }

    procedure Loaded; override;

  public
    { Public declarations }
    constructor Create( AOwner: TComponent ); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;  { 6/27/99 2.18+ }
    function Zip: Integer;
    function DeleteEntries: Integer;
    procedure SaveModifiedZipFile;
    function ZipFromStream( theStream: TStream; FName: String ): Integer;
    function FixZip( InputFile, OutputFile: String): Integer;
    procedure MakeSFX( SFXStub: String; ModHeaders: Boolean );
    function MakeNewSFX( SFXStub: String; FName: String; Options: PChar;
                                                      OptionsLen: Integer): Integer;
    function ZipFromBuffer( Buffer: PChar; Amount: Longint; FName: String ): Integer;
    procedure SFXToZip(DeleteSFX: Boolean);
    procedure encrypt_buff(buff: BytePtr; length: LongInt);
    function Split( DeleteOriginal: boolean ): boolean;           { 6/15/02  2.23+ }

    {$IFDEF UNDER_DEVELOPMENT}
    { 10/24/99 2.20b3+ }
    procedure GetRawCompressedFile( Index: Integer; var Header: TZipHeaderInfo; ZippedStream: TStream );
    procedure InsertRawCompressedFile( Header: TZipHeaderInfo; ZippedStream: TStream );
    {$ENDIF}

    property DateTime[Index: Integer]: TDateTime read GetDateTime write SetDateTime;
    property FileComment[Index: Integer]: String read GetFileComment write SetFileComment;
    property ZipComment: String read GetZipComment write SetZipComment;
    property IsModified: Boolean read GetIsModified;
    property CheckDiskLabels: Boolean read GetCheckDiskLabels write SetCheckDiskLabels;
    property MultiMode: TMultiMode read GetMultiMode write SetMultiMode;

    property Pathname[Index: Integer]: TZipPathname read GetPathname write SetPathname;
    property Filename[Index: Integer]: String read GetFilename write SetFilename;
    property PreserveStubs: Boolean read FPreserveStubs write FPreserveStubs default False;
    property FileOpenMode: Word read FFileOpenMode write FFileOpenMode default fmShareDenyNone;
    {$IFDEF UNDER_DEVELOPMENT}
    property OtherVCLZip: TVCLZip read FOtherVCLZip write FOtherVCLZip;   { 10/24/99 2.20b3+ }
    {$ENDIF}

  published
    { Published declarations }
    property PackLevel: Integer read FPackLevel write FPackLevel default 6;
    property Recurse: Boolean read FRecurse write FRecurse default False;
    property Dispose: Boolean read FDispose write FDispose default False;
    property StorePaths: Boolean read FStorePaths write SetStorePaths default False;
    property RelativePaths: Boolean read FRelativePaths write SetRelativePaths default False;
    property StoreVolumes: Boolean read FStoreVolumes write SetStoreVolumes default False;
    property ZipAction: TZipAction read FZipAction write FZipAction default zaUpdate;
    property MultiZipInfo: TMultiZipInfo read FMultiZipInfo write SetMultiZipInfo;
    property Store83Names: Boolean read FStore83Names write FStore83Names default False;
    property TempPath: String read FTempPath write FTempPath;  { 5/5/98  2.12 }
    property SkipIfArchiveBitNotSet: Boolean read FSkipIfArchiveBitNotSet
              write FSkipIfArchiveBitNotSet default False; { 7/4/98  2.13 }
    property ResetArchiveBitOnZip: Boolean read FResetArchiveBitOnZip
              write FResetArchiveBitOnZip default False; { Added 4-Jun-98 SPF 2.13? }
    property ExcludeList: TStrings read FExcludeList write SetExcludeList;  { 9/27/98  2.15 }
    property NoCompressList: TStrings read FNoCompressList write SetNoCompressList;  { 9/27/98  2.15 }
    property AddDirEntriesOnRecurse: Boolean read FAddDirEntries write FAddDirEntries default False;

    { Event Properties }
    property OnStartZip: TStartZipEvent read FOnStartZip write FOnStartZip;
    property OnStartZipInfo: TStartZipInfo read FOnStartZipInfo write FOnStartZipInfo;
    property OnEndZip: TEndZipFileEvent read FOnEndZip write FOnEndZip;
    property OnDisposeFile: TDisposeEvent read FOnDisposeFile write FOnDisposeFile;
    property OnDeleteEntry: TDeleteEvent read FOnDeleteEntry write FOnDeleteEntry;
    property OnNoSuchFile: TNoSuchFileEvent read FOnNoSuchFile write FOnNoSuchFile;
    property OnZipComplete: TZipComplete read FOnZipComplete write FOnZipComplete;
    property OnUpdate: TUpdateEvent read FOnUpdate write FOnUpdate;  { 7/5/99  2.18+ }
    property OnPrepareNextDisk: TPrepareNextDisk read FOnPrepareNextDisk write FOnPrepareNextDisk;
    property OnRecursingFile: TOnRecursingFile read FOnRecursingFile write FOnRecursingFile;
    property OnEncrypt: TEncryptEvent read FOnEncrypt write FOnEncrypt; { 12/8/01 2.22+ }
  end;

  {$IFNDEF FULLPACK}
  procedure Register;
  {$ENDIF}

implementation

{$I kpDFLT.PAS}

constructor TMultiZipInfo.Create;
begin
  Inherited Create;
  MultiMode := mmNone;
  FBlockSize := 1457600;
  FFirstBlockSize := 1457600;
  FSaveOnFirstDisk := 0;
  FSaveZipInfo := False;
  CheckDiskLabels := True;
  FWriteDiskLabels := True;
end;

procedure TMultiZipInfo.Assign(Source: TPersistent);
var
  Src: TMultiZipInfo;
begin
  If Source is TMultiZipInfo then
   begin
     Src := TMultiZipInfo(Source);
     FMultiMode := Src.MultiMode;
     FBlockSize := Src.BlockSize;
     FFirstBlockSize := Src.FirstBlockSize;
     FSaveOnFirstDisk := Src.SaveOnFirstDisk;
     FSaveZipInfo := Src.FSaveZipInfo;
     FCheckDiskLabels := Src.CheckDiskLabels;
     FWriteDiskLabels := Src.WriteDiskLabels;
   end
 else inherited Assign(Source);
end;

constructor TVCLZip.Create( AOwner: TComponent );
begin
  inherited Create(AOwner);
  FMultiZipInfo := TMultiZipInfo.Create;
  FPackLevel := 6;
  FRecurse := False;