vclunzip.pas

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

         False;
      property FlushFilesOnClose: Boolean READ FFlushFilesOnClose WRITE FFlushFilesOnClose
         DEFAULT False;
      property BlockMode: TBlockMode read FBlockMode write FBlockMode default bmStandard;
      { Event Properties }
      property OnStartUnZipInfo: TStartUnzipInfo READ FOnStartUnzipInfo
         WRITE FOnStartUnzipInfo;
      property OnFilePercentDone: TFilePercentDone READ FOnFilePercentDone
         WRITE FOnFilePercentDone;
      property OnTotalPercentDone: TTotalPercentDone READ FOnTotalPercentDone
         WRITE FOnTotalPercentDone;
      property OnStartUnZip: TStartUnZipEvent READ FOnStartUnZip WRITE FOnStartUnZip;
      property OnEndUnZip: TEndUnZipEvent READ FOnEndUnZip WRITE FOnEndUnZip;
      property OnPromptForOverwrite: TPromptForOverwrite READ FOnPromptForOverwrite
         WRITE FOnPromptForOverwrite;
      property OnSkippingFile: TSkippingFile READ FOnSkippingFile WRITE FOnSkippingFile;
      property OnBadPassword: TBadPassword READ FOnBadPassword WRITE FOnBadPassword;
      property OnBadCRC: TBadCRC READ FOnBadCRC WRITE FOnBadCRC;
      property OnInCompleteZip: TInCompleteZip READ FOnInCompleteZip WRITE FOnInCompleteZip;
      property OnGetNextDisk: TGetNextDisk READ FOnGetNextDisk WRITE FOnGetNextDisk;
      property OnUnZipComplete: TUnZipComplete READ FOnUnZipComplete WRITE FOnUnZipComplete;
      property OnGetNextBuffer: TGetNextBuffer READ FOnGetNextBuffer WRITE FOnGetNextBuffer;
      property OnDecrypt: TDecryptEvent READ FOnDecrypt WRITE FOnDecrypt;
      property OEMConvert: TOEMConvert read FOEMConvert write FOEMConvert default oemAlways;
      property OnFileNameForSplitPart: TFileNameForSplitPartEvent read FOnFileNameForSplitPart
            write FOnFileNameForSplitPart;
      property OnHandleMessage: THandleMessageEvent read FOnHandleMessage write FOnHandleMessage;


   end;

   {$IFNDEF KPSMALL}
var
   OpenZipDlg            : TOpenDialog;
   {$ENDIF}

{$IFNDEF FULLPACK}
procedure Register;
{$ENDIF}
{$IFDEF KPDEMO}
function DelphiIsRunning: Boolean;
{$ENDIF}

{$IFDEF USE_ZLIB}
type
  TZAlloc = function (opaque: Pointer; items, size: Integer): Pointer;
  TZFree  = procedure (opaque, block: Pointer);

  TZCompressionLevel = (zcNone, zcFastest, zcDefault, zcMax);

  {** TZStreamRec ***********************************************************}

  TZStreamRec = packed record
    next_in  : PChar;     // next input byte
    avail_in : Longint;   // number of bytes available at next_in
    total_in : Longint;   // total nb of input bytes read so far

    next_out : PChar;     // next output byte should be put here
    avail_out: Longint;   // remaining free space at next_out
    total_out: Longint;   // total nb of bytes output so far

    msg      : PChar;     // last error message, NULL if no error
    state    : Pointer;   // not visible by applications

    zalloc   : TZAlloc;   // used to allocate the internal state
    zfree    : TZFree;    // used to free the internal state
    opaque   : Pointer;   // private data object passed to zalloc and zfree

    data_type: Integer;   // best guess about the data type: ascii or binary
    adler    : Longint;   // adler32 value of the uncompressed data
    reserved : Longint;   // reserved for future use
  end;

type
  EZLibError = class(Exception);

  EZCompressionError = class(EZLibError);
  EZDecompressionError = class(EZLibError);

{** link zlib code **********************************************************}
{$IFDEF ZLIB114}          // MUST DEFINE ZLIB114 to get the older version
{$L deflate.obj}
{$L inflate.obj}
{$L infblock.obj}
{$L inftrees.obj}
{$L infcodes.obj}
{$L infutil.obj}
{$L inffast.obj}
{$L trees.obj}
{$L adler32.obj}
{$ELSE}                   // ZLIB_VERSION 1.2.2 is now the default
{$L ..\zlib122\adler32.obj}
{$L ..\zlib122\compress.obj}
{$L ..\zlib122\crc32.obj}
{$L ..\zlib122\deflate.obj}
{$L ..\zlib122\infback.obj}
{$L ..\zlib122\inffast.obj}
{$L ..\zlib122\inflate.obj}
{$L ..\zlib122\inftrees.obj}
{$L ..\zlib122\trees.obj}
procedure adler32; external;
procedure compressBound; external;
procedure crc32; external;
{$ENDIF}
{*****************************************************************************
*  note: do not reorder the above -- doing so will result in external        *
*  functions being undefined                                                 *
*****************************************************************************}


const

  {** flush constants *******************************************************}

  Z_NO_FLUSH      = 0;
  Z_PARTIAL_FLUSH = 1;
  Z_SYNC_FLUSH    = 2;
  Z_FULL_FLUSH    = 3;
  Z_FINISH        = 4;

  {** return codes **********************************************************}

  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);

  {** compression levels ****************************************************}

  Z_NO_COMPRESSION       =   0;
  Z_BEST_SPEED           =   1;
  Z_BEST_COMPRESSION     =   9;
  Z_DEFAULT_COMPRESSION  = (-1);

  {** compression strategies ************************************************}

  Z_FILTERED            = 1;
  Z_HUFFMAN_ONLY        = 2;
  Z_DEFAULT_STRATEGY    = 0;

  {** data types ************************************************************}

  Z_BINARY   = 0;
  Z_ASCII    = 1;
  Z_UNKNOWN  = 2;

  {** compression methods ***************************************************}

  Z_DEFLATED = 8;

  {** return code messages **************************************************}

  _z_errmsg: array[0..9] of PChar = (
    'need dictionary',      // Z_NEED_DICT      (2)
    'stream end',           // Z_STREAM_END     (1)
    '',                     // Z_OK             (0)
    'file error',           // Z_ERRNO          (-1)
    'stream error',         // Z_STREAM_ERROR   (-2)
    'data error',           // Z_DATA_ERROR     (-3)
    'insufficient memory',  // Z_MEM_ERROR      (-4)
    'buffer error',         // Z_BUF_ERROR      (-5)
    'incompatible version', // Z_VERSION_ERROR  (-6)
    ''
  );

  ZLevels: array [TZCompressionLevel] of Shortint = (
    Z_NO_COMPRESSION,
    Z_BEST_SPEED,
    Z_DEFAULT_COMPRESSION,
    Z_BEST_COMPRESSION
  );

  SZInvalid = 'Invalid ZStream operation!';

{** deflate routines ********************************************************}

function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar;
  recsize: Integer): Integer; external;

function deflateInit2_(var strm: TZStreamRec; level: Integer; method: Integer;
    windowBits: Integer; memLevel: Integer; strategy: Integer; version: PChar;
  recsize: Integer): Integer; external;

function deflate(var strm: TZStreamRec; flush: Integer): Integer;
  external;

function deflateEnd(var strm: TZStreamRec): Integer; external;

{** inflate routines ********************************************************}

function inflateInit2_(var strm: TZStreamRec; WindowBits: Integer; version: PChar;
  recsize: Integer): 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;

{** custom zlib routines ****************************************************}

function DeflateInit(var stream: TZStreamRec; level: Integer): Integer;
function DeflateInit2(var stream: TZStreamRec; level, method, windowBits,
  memLevel, strategy: Integer): Integer;
function InflateInit(var stream: TZStreamRec): Integer;
function InflateInit2(var stream: TZStreamRec; windowBits: Integer): Integer;
function zcalloc(opaque: Pointer; items, size: Integer): Pointer;
procedure zcfree(opaque, block: Pointer);
function CCheck(code: Integer): Integer;
function DCheck(code: Integer): Integer;
procedure MoveI32(const Source; var Dest; Count: Integer); register;

{$ENDIF}

implementation


{$IFDEF USE_ZLIB}

{** custom zlib routines ****************************************************}

function DeflateInit(var stream: TZStreamRec; level: Integer): Integer;
begin
  result := DeflateInit_(stream, level, ZLIB_VERSION, SizeOf(TZStreamRec));
end;

function DeflateInit2(var stream: TZStreamRec; level, method, windowBits,
  memLevel, strategy: Integer): Integer;
begin
  result := DeflateInit2_(stream, level, method, windowBits, memLevel, strategy, ZLIB_VERSION, SizeOf(TZStreamRec));
end;

function InflateInit(var stream: TZStreamRec): Integer;
begin
  result := InflateInit_(stream, ZLIB_VERSION, SizeOf(TZStreamRec));
end;

function InflateInit2(var stream: TZStreamRec; windowBits: Integer): Integer;
begin
  result := InflateInit2_(stream, windowBits, ZLIB_VERSION, SizeOf(TZStreamRec));
end;

function zcalloc(opaque: Pointer; items, size: Integer): Pointer;
begin
  GetMem(result,items * size);
end;

procedure zcfree(opaque, block: Pointer);
begin
  FreeMem(block);
end;

  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 _malloc(Size: Integer): Pointer; cdecl;
begin
  Result := AllocMem(Size);
end;

procedure _free(Block: Pointer); cdecl;
begin
  FreeMem(Block);
end;

function CCheck(code: Integer): Integer;
begin
  Result := code;
  if code < 0 then
    raise EZCompressionError.Create('error'); //!!
end;

function DCheck(code: Integer): Integer;
begin
  Result := code;
  if code < 0 then
    raise EZDecompressionError.Create('error');  //!!
end;

procedure MoveI32(const Source; var Dest; Count: Integer); register;
asm
        cmp   ECX,0
        Je    @JustQuit
        push  ESI
        push  EDI
        mov   ESI, EAX
        mov   EDI, EDX
    @Loop:
	Mov   AL, [ESI]
        Inc   ESI
        mov   [EDI], AL
        Inc   EDI
        Dec   ECX
        Jnz   @Loop
        pop   EDI
        pop   ESI
    @JustQuit:
end;

{$ENDIF}


{$I kpUnzipp.Pas}

{******************************************************************}

constructor TVCLUnZip.Create(AOwner: TComponent);
{$IFDEF KPDEMO}
var
   tmpMstr2              : string;
   {$ENDIF}
begin
   inherited Create(AOwner);
   FSortMode := ByNone;
   FDoAll := False;
   RecreateDirs := False;
   FFilesList := TStringList.Create;
   FRelativePathList := TStringList.Create;
   file_info := CreateNewZipHeader;        { 4/22/02  2.23+ }
   { file_info := TZipHeaderInfo.Create;}  { Moved to Loaded  2/17/02 2.22+ }
   Password := '';
   ZipIsBad := False;
   theZipFile := nil;
   files := nil;
   sortfiles := nil;
   FIncompleteZipMode := izAssumeMulti;
   ecrec := TEndCentral.Create;
   CancelOperation := False;
   PauseOperation := False;
   FKeepZipOpen := False;
   FDoProcessMessages := True;
   FCheckDiskLabels := True;
   StreamZipping := False;
   MemZipping := False;
   MemBuffer := nil;
   MemLen := 0;
   ArchiveIsStream := False;
   Fixing := False;
   FNumDisks := 1;
   CurrentDisk := 0;
   FRetainAttributes := True;
   FBusy := False;
   FTestMode := False;
   FThisVersion := kpThisVersion;
   FThisBuild := kpThisBuild;
   FReplaceReadOnly := False;                           { 03/09/99  2.17+ }
   FNumSelected := 0;
   FBufferLength := 0;
   FImproperZip := False;
   FBufferedStreamSize := DEF_BUFSTREAMSIZE;
   FEncryptBeforeCompress := False;
   FOEMConvert := oemAlways;                                 { 2/17/02 2.22+ }
   FBlockMode := bmStandard;
   {$IFDEF KPDEMO}
   if not (csDesigning in ComponentState) then
   begin
      DR := DelphiIsRunning;
      if not DelphiIsRunning then
      begin
         tmpMStr := LoadStr(IDS_NOTREGISTERED);
         tmpMStr2 := LoadStr(IDS_WARNING);
         //MessageBox(0, StringAsPChar(tmpMStr), StringAsPChar(tmpMStr2), mb_OK);
         DoHandleMessage(IDS_NOTREGISTERED,StringAsPChar(tmpMStr), StringAsPChar(tmpMStr2), mb_OK);
         Abort;
      end;
   end;
   {$ENDIF}
end;

destructor TVCLUnZip.Destroy;
begin
   ClearZip;
   if (file_info <> nil) then
      file_info.Free;
   if (ecrec <> nil) then
      ecrec.Free;
   { Moved folowing down two lines 7/10/98  2.13 }
   { Due to a user's reporting that it stopped him from getting "Invalid Pointer Operation"
   { errors.  I was unable to duplicate the problem but the move is safe enough  }
   if (FFilesList <> nil) then