vclzip.pas

delphi实现 webservice的例子.有服务端和客户段 利用xml交互.

{ ********************************************************************************** }
{                                                                                    }
{   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
  Windows,
  SysUtils, Messages, Classes,
  kpSmall,
{$IFNDEF INT64STREAMS}
  kphstrms,
{$ENDIF}
{$IFNDEF KPSMALL}
  Dialogs, Forms, Controls,
{$ENDIF}
  KpLib, VCLUnZip, kpZipObj, kpMatch, kpzcnst;

{$IFOPT C+}
{$DEFINE ASSERTS}
{$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+}
  TOnStartSpanCopy = procedure(Sender: TObject; FName: string; FileSize: BIGINT) of object;
  TOnGetNextStreamEvent = procedure(Sender: TObject; var stream: TKPStream; var NextFileName: String) of object;
  {$IFNDEF INT64STREAMS}
  TOnGetNextTStreamEvent = procedure(Sender: TObject; var stream: TStream; var NextFileName: String) of object;
  {$ENDIF}
  TMultiZipInfo = class(TPersistent)
  private
    FBlockSize: Int64;
    FFirstBlockSize: Int64;
    FSaveOnFirstDisk: Int64; { 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: Int64 read FBlockSize write FBlockSize default 1457600;
    property FirstBlockSize: Int64 read FFirstBlockSize write FFirstBlockSize default 0;
    property SaveOnFirstDisk: Int64 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: Int64;
    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+ }
    FOnStartSpanCopy: TOnStartSpanCopy;
    FOnGetNextStream: TOnGetNextStreamEvent;
    {$IFNDEF INT64STREAMS}
    FOnGetNextTStream: TOnGetNextTStreamEvent;
    {$ENDIF}

    AmountWritten: BIGINT;
    AmountToWrite: BIGINT;
    FilenameSize: BIGINT;
    UsingTempFile: Boolean;
    CreatingSFX: Boolean;
    SFXStubFile: TLFNFileStream;
    FPreserveStubs: Boolean;
    FAddDirEntries: Boolean;
    FFileOpenMode: Word;
    FSearchAttribute: Integer;
    FFreeStream: Boolean;

  protected
    { Protected declarations }
    zfile: TkpStream; { output compression file }
    IFile: TkpStream; { input file to compress }
    mfile: TkpStream; { 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: BIGINT;
    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: Integer): LongInt;
    procedure CreateTempZip;
    function kpDeflate( var totalRead: BIGINT ): BIGINT;
    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 }

    function GetsaHidden: Boolean;
    procedure SetsaHidden(value: Boolean);
    function GetsaSysFile: Boolean;
    procedure SetsaSysFile(value: Boolean);
    function GetsaReadOnly: Boolean;
    procedure SetsaReadOnly(value: Boolean);
    function GetsaArchive: Boolean;
    procedure SetsaArchive(value: Boolean);

    procedure ExpandForWildCards;    { 8/24/03  3.02+ }
    function ComparePath(P: string): string;


    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;
    procedure ExpandFilesList(var NumFiles: Integer; var TotalBytes: Comp);
    function DeleteEntries: Integer;
    procedure SaveModifiedZipFile;
    function ZipFromStream(theStream: TkpStream; FName: string): Integer; overload;
    function ZipFromStream(theStream: TkpStream; FName: string; FreeStreamWhenDone: Boolean): Integer; overload;
    {$IFNDEF INT64STREAMS}
     function ZipFromStream(theStream: TStream; FName: string; FreeStreamWhenDone: Boolean): Integer; overload;
    {$ENDIF}
    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+ }

    procedure ZLibCompressStream(inStream, outStream: TStream; HttpCompression: Boolean = False);
    procedure ZLibCompressBuffer(const inBuffer: Pointer; inSize: Integer;
                              out outBuffer: Pointer; out outSize: Integer; HttpCompression: Boolean = False);
    function ZLibCompressStr(const s: string; HttpCompression: Boolean = False): string;
    function ZLibCompressString(const s: string; HttpCompression: Boolean = False): string;


{$IFDEF UNDER_DEVELOPMENT}
    { 10/24/99 2.20b3+ }
    procedure GetRawCompressedFile(Index: Integer; var Header: TZipHeaderInfo; ZippedStream: TkpStream);
    procedure InsertRawCompressedFile(Header: TZipHeaderInfo; ZippedStream: TkpStream);
{$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;
    property IncludeHiddenFiles: Boolean read GetsaHidden write SetsaHidden default False;
    property IncludeSysFiles: Boolean read GetsaSysFile write SetsaSysFile default False;
    property IncludeReadOnlyFiles: Boolean read GetsaReadOnly write SetsaReadOnly default True;
    property IncludeArchiveFiles: Boolean read GetsaArchive write SetsaArchive default True;

    { 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+ }
    property OnStartSpanCopy: TOnStartSpanCopy read FOnStartSpanCopy write FOnStartSpanCopy;
    property OnGetNextStream: TOnGetNextStreamEvent read FOnGetNextStream write FOnGetNextStream;
    {$IFNDEF INT64STREAMS}
    property OnGetNextTStream: TOnGetNextTStreamEvent read FOnGetNextTStream write FOnGetNextTStream;
    {$ENDIF}
  end;

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

implementation

uses