vclzip.pas

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

{$IFDEF KPDEBUG}
ErrorRpt,
{$ENDIF}
kpDiskIOs;

{$IFDEF USE_ZLIB}

function TVCLZip.kpDeflate( var totalRead: BIGINT): BIGINT;
const
  INBLKSIZ = 65535;
  OUTBLKSIZ = 65535;
var
  ucBuf: PChar;
  cBuf: PChar;
  strm: TZStreamRec;
  count: Integer;
  Param: Integer;
  Stat: Integer;
  totalbytes: BIGINT;
begin
  FillChar(strm, sizeof(strm), 0);
  strm.zalloc := zcalloc;
  strm.zfree := zcfree;
  GetMem(ucBuf, INBLKSIZ);
  GetMem(cBuf, OUTBLKSIZ);
  totalbytes := 0;
  totalRead := 0;
  try
    strm.next_in := ucBuf;
    strm.next_out := cBuf;
    strm.avail_out := OUTBLKSIZ;
    strm.avail_in := file_read(BytePtr(ucBuf), INBLKSIZ);
    Inc(totalRead,strm.avail_in);
    CCheck(deflateInit2_(strm, PackLevel, 8, -15, 8, 0, ZLIB_VERSION, sizeof(strm)));
    Param := Z_NO_FLUSH;
    repeat
      if (strm.avail_in = 0) and (Param = Z_NO_FLUSH) then
      begin
        strm.avail_in := file_read(BytePtr(ucBuf), INBLKSIZ);
        Inc(totalRead,strm.avail_in);
        if (strm.avail_in = 0) then
          Param := Z_FINISH;
        strm.next_in := ucBuf;
      end;
      Stat := deflate(strm, Param);
      CCheck(Stat);
      if (strm.avail_out = 0) or (param = Z_FINISH) then
      begin
        count := OUTBLKSIZ - strm.avail_out;
        if (count > 0) then
        begin
          zfwrite(BytePtr(cBuf), 1, count);
          Inc(totalbytes, count);
        end;
        strm.next_out := cBuf;
        strm.avail_out := OUTBLKSIZ;
      end;
    until Stat = Z_STREAM_END;
    CCheck(deflateEnd(strm));
  finally
    FreeMem(ucBuf, INBLKSIZ);
    FreeMem(cBuf, OUTBLKSIZ);
  end;
  Result := totalbytes;
end;
{$ELSE}
{$I kpDFLT.PAS}
{$ENDIF}

constructor TMultiZipInfo.Create;
begin
  inherited Create;
  MultiMode := mmNone;
  FBlockSize := 1457600;
  FFirstBlockSize := 0;
  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;
  FDispose := False;
  FStorePaths := False;
  FStoreVolumes := False;
  FZipAction := zaUpdate; {update only if newer}
  FBlockSize := 1457600;
  FRelativePaths := False;
  FStore83Names := False;
  FTempPath := '';
  Deleting := False;
  zfile := nil;
  tmpfiles := nil;
  tmpecrec := nil;
  TRInitialized := False;
  SaveNewName := '';
{$IFDEF UNDER_DEVELOPMENT}
  FOtherVCLZip := nil; { 10/24/99 2.20b3+ }
{$ENDIF}
{$IFNDEF USE_ZLIB}
  StaticInit;
{$ENDIF}
  CreatingSFX := False;
  FSkipIfArchiveBitNotSet := False; { 7/4/98 2.13 }
  FResetArchiveBitOnZip := False; { Added 4-Jun-98 SPF 2.13? }
  FExcludeList := TStringList.Create; { 9/27/98  2.15 }
  FnoCompressList := TStringList.Create; { 9/27/98  2.15 }
  FPreserveStubs := False; { 01/12/99  2.17 }
  FAddDirEntries := False; { 06/09/99 2.18+ }
  FFileOpenMode := fmShareDenyNone; { 10/17/99 2.18+ } { changed back to fmShareDenyNone }
                                                        { 05/13/00 2.20+  }
  FSearchAttribute := faAnyFile;
  IncludeHiddenFiles := False;
  IncludeSysFiles := False;
  IncludeReadOnlyFiles := True;
  IncludeArchiveFiles := True;
end;

destructor TVCLZip.Destroy;
begin
  FMultiZipInfo.Free;
  FMultiZipInfo := nil; { 4/25/98  2.11 }
  if (FExcludeList <> nil) then
    FExcludeList.Free; { 9/27/98  2.15 }
  if (FNoCompressList <> nil) then
    FNoCompressList.Free; { 9/27/98  2.15 }
  inherited Destroy;
end;

procedure TVCLZip.Loaded;
begin
  inherited Loaded;
  SetCheckDiskLabels(FMultiZipInfo.CheckDiskLabels);
  SetMultiMode(FMultiZipInfo.MultiMode);
end;

procedure TVCLZip.StaticInit;
begin
  ZeroMemory(@static_ltree, SizeOf(static_ltree));
  ZeroMemory(@static_dtree, SizeOf(static_dtree));
  ZeroMemory(@bl_count, SizeOf(bl_count));
  ZeroMemory(@base_dist, SizeOf(base_dist));
  ZeroMemory(@length_code, SizeOf(length_code));
  ZeroMemory(@dist_code, SizeOf(dist_code));
  ZeroMemory(@base_length, SizeOf(base_length));
end;

procedure TVCLZip.Assign(Source: TPersistent); { 6/27/99 2.18+ }
begin
  if source is TVCLZip then
  begin
    inherited Assign(Source);
    FPackLevel := TVCLZip(Source).PackLevel;
    FRecurse := TVCLZip(Source).Recurse;
    FDispose := TVCLZip(Source).Dispose;
    FStorePaths := TVCLZip(Source).StorePaths;
    FRelativePaths := TVCLZip(Source).RelativePaths;
    FStoreVolumes := TVCLZip(Source).StoreVolumes;
    FZipAction := TVCLZip(Source).ZipAction;
    FMultiZipInfo.Assign(TVCLZip(Source).MultiZipInfo);
    FStore83Names := TVCLZip(Source).Store83Names;
    FTempPath := TVCLZip(Source).TempPath; { 5/5/98  2.12 }
    FSkipIfArchiveBitNotSet := TVCLZip(Source).SkipIfArchiveBitNotSet; {
7/4/98  2.13 }
    FResetArchiveBitOnZip := TVCLZip(Source).ResetArchiveBitOnZip; {
Added 4-Jun-98 SPF 2.13? }
    FExcludeList.Assign(TVCLZip(Source).ExcludeList); { 9/27/98  2.15 }

    FNoCompressList.Assign(TVCLZip(Source).NoCompressList); { 9/27/98
2.15 }

    FPreserveStubs := TVCLZip(Source).PreserveStubs; { 01/12/99  2.17 }
    FAddDirEntries := TVCLZip(Source).AddDirEntriesOnRecurse; { 06/09/99 2.18+ }
    { Event Properties }
    FOnStartZip := TVCLZip(Source).OnStartZip;
    FOnStartZipInfo := TVCLZip(Source).OnStartZipInfo;
    FOnEndZip := TVCLZip(Source).OnEndZip;
    FOnDisposeFile := TVCLZip(Source).OnDisposeFile;
    FOnDeleteEntry := TVCLZip(Source).OnDeleteEntry;
    FOnNoSuchFile := TVCLZip(Source).OnNoSuchFile;
    FOnZipComplete := TVCLZip(Source).OnZipComplete;
    FOnUpdate := TVCLZip(Source).OnUpdate;
  end
  else
    inherited Assign(Source);

end;

procedure TVClZip.SetPathname(Index: Integer; Value: TZipPathname);
var
  finfo: TZipHeaderInfo;
  tmpValue: string;
begin
  if (Index > -1) and (Index < Count) then
  begin
    finfo := sortfiles.Items[Index] as TZipHeaderInfo;
    if (Length(Value) > 0) and (Value[Length(Value)] <> '\') then
      tmpValue := Value + '\'
    else
      tmpValue := Value;
    if tmpValue <> finfo.directory then
    begin
      finfo.directory := tmpValue;
      ecrec.Modified := True;
    end;
  end
  else
    raise EListError.CreateFmt(LoadStr(IDS_INDEXOUTOFRANGE), [Index]);
end;

procedure TVClZip.SetFilename(Index: Integer; Value: TZipPathname);
var
  finfo: TZipHeaderInfo;
begin
  if (Index > -1) and (Index < Count) then
  begin
    finfo := sortfiles.Items[Index] as TZipHeaderInfo;
    if Value <> finfo.filename then
    begin
      finfo.filename := Value;
      ecrec.Modified := True;
    end;
  end
  else
    raise EListError.CreateFmt(LoadStr(IDS_INDEXOUTOFRANGE), [Index]);
end;

procedure TVCLZip.SetMultiZipInfo(Value: TMultiZipInfo);
begin
  FMultiZipInfo.Assign(Value);
end;

function TVCLZip.GetMultiMode: TMultiMode;
begin
  Result := FMultiZipInfo.FMultiMode;
end;

procedure TVCLZip.SetMultiMode(Value: TMultiMode);
begin
  if FMultiZipInfo = nil then { 4/26/98  2.11 }
    exit; { to avoid illegal pointer operation error during Destroy method }
  if Value <> FMultiZipInfo.FMultiMode then
    FMultiZipInfo.FMultiMode := Value;
  FMultiMode := Value;
end;

function TVCLZip.GetCheckDiskLabels: Boolean;
begin
  Result := FMultiZipInfo.CheckDiskLabels;
end;

procedure TVCLZip.SetCheckDiskLabels(Value: Boolean);
begin
  if Value <> FMultiZipInfo.CheckDiskLabels then
    FMultiZipInfo.CheckDiskLabels := Value;
  FCheckDiskLabels := Value;
end;

procedure TVCLZip.SetStoreVolumes(Value: Boolean);
begin
  if Value <> FStoreVolumes then
  begin
    FStoreVolumes := Value;
    if Value = True then
      FStorePaths := True;
  end;
end;

procedure TVCLZip.SetStorePaths(Value: Boolean);
begin
  if Value <> FStorePaths then
  begin
    if Value = False then
    begin
      FStoreVolumes := False;
      FRelativePaths := False;
    end;
    FStorePaths := Value;
  end;
end;

procedure TVCLZip.SetRelativePaths(Value: Boolean);
begin
  if Value <> FRelativePaths then
  begin
    if Value = True then
    begin
      FStorePaths := True;
      FRecurse := True;
    end;
    FRelativePaths := Value;
  end;
end;

{ Added 4-Jun-98 SPF 2.13? }

procedure TVCLZip.ResetArchiveBit(AFileName: string);
begin
  FileSetAttr(AFileName, (FileGetAttr(AFileName) and not faArchive));
end;

function TVCLZip.ZipFromStream(theStream: TkpStream; FName: string): Integer;
begin
  Result := ZipFromStream(theStream,FName,False);
end;

function TVCLZip.ZipFromStream(theStream: TkpStream; FName: string; FreeStreamWhenDone: Boolean): Integer;
begin
  if (Trim(FName) = '') or (TheStream = nil) then
  begin
    result := 0;
    exit;
  end;
  FFreeStream := FreeStreamWhenDone;
  CancelOperation := False;
  StreamZipping := True;
  ZipStream := theStream;
  ZipStream.Position := 0;
  FilesList.Clear;
  FilesList.Add(FName);
  try
    Result := Zip;
  finally
    StreamZipping := False;
    CloseZip;
  end;
end;

{$IFNDEF INT64STREAMS}
 function TVCLZip.ZipFromStream(theStream: TStream; FName: string; FreeStreamWhenDone: Boolean): Integer;
var
   InternalStream:tKpHugeMemoryStream;
   OldBusy: Boolean;
begin
     FFreeStream := True; // Must free TkpHugeStream internal to VCLZip in this case.
     if (TheStream is TMemoryStream) and (not Assigned(OnGetNextTStream)) then
      begin
        // This saves step of copying stream so it's faster and more efficient
        result:=ZipFromBuffer(PChar(TMemoryStream(TheStream).Memory),TheStream.Size,FName);
        if (FreeStreamWhenDone) then
          theStream.Free;
      end
     else
      begin
        OldBusy := SetBusy(True);
        InternalStream := tKpHugeMemoryStream.Create;
        try
           InternalStream.Size := theStream.Size;
           TheStream.Position:=0;
           InternalStream.CopyFrom(TheStream,TheStream.Size);
           // Free here to save memory as soon as possible.
           if (FreeStreamWhenDone) then
             theStream.Free;
           InternalStream.Position:=0;
           result:=ZipFromStream(InternalStream,FName,FreeStreamWhenDone);
        finally
           SetBusy(OldBusy);