vclzip.pas

一个delphi中压缩的组件VCLZip

     prev := nil;
     System.Dispose(head);
     head := nil;
     System.Dispose(l_buf);
     l_buf := nil;
     System.Dispose(d_buf);
     d_buf := nil;
     System.Dispose(flag_buf);
     flag_buf := nil;
  {$ENDIF}
  end;

var
  i: Integer;
  FinishedOK: Boolean;
  SaveSortedFiles: TSortedZip;
  SaveSortMode: TZipSortMode;
  SaveKeepZipOpen: Boolean;
  SaveZipName: String;
  StopNow: Boolean;
  TotalCentralSize: LongInt;
  SaveCentralPos: LongInt;
  tIncludePaths: Integer;
  {$IFNDEF KPSMALL}
  SaveCursor: TCursor;
  {$ENDIF}

begin  {************** ProcessFiles Main Body ****************}
  Result := 0;
  CancelOperation := False;
  If FilesList = nil then
     exit;
  { Either ZipName or ArchiveStream should be set }
  if ((Trim(ZipName)='') and (ArchiveStream = nil)) then { 09/07/99 2.18+ }
     exit;
  FBusy := True;
  FinishedOK := False;
  CurrentDisk := 0;
  SaveSortedFiles := sortfiles;
  SaveSortMode := SortMode;
  SaveKeepZipOpen := KeepZipOpen;
  KeepZipOpen := True;
  sortfiles := files;
  SortMode := ByNone;

  If Dispose then
     DisposeFiles := TStringList.Create;
  If (not Deleting) and (not StreamZipping) and (not MemZipping) and (FilesList.Count > 0) then
     ExpandForWildCards;

  {  Guesstimate space needed for the Zip Configuration File that will go on first disk of
     a spanned zip file if SaveZipInfoOnFirstDisk is True }
  If (MultiZipInfo.MultiMode <> mmNone) and (MultiZipInfo.SaveZipInfoOnFirstDisk) then
   begin
     If StorePaths then
        tIncludePaths := 25 { Change this number to assume different average path length }
     Else
        tIncludePaths := 0;
     { We'll pad a little extra because comments aren't figured in and we want to make sure
       we allow for sector's being allocated on disk }
        MultiZipInfo.SaveOnFirstDisk :=
           MultiZipInfo.SaveOnFirstDisk +
           (FilesList.Count * (SizeOf(central_file_header)+12+tIncludePaths) ) +
           SizeOf(end_of_central) + ecrec.zip_comment_length + 2048; { + 2048 for some padding }
   end;

  If MultiZipInfo.MultiMode = mmSpan then
     AmountToWrite := DiskRoom - MultiZipInfo.SaveOnFirstDisk
  Else If MultiZipInfo.MultiMode = mmBlocks then
     AmountToWrite := MultiZipInfo.FirstBlockSize;

  try  { Moved up to here 4/12/98  2.11 }
  If ((ArchiveIsStream) and (Count > 0))
        or ((File_Exists(ZipName)) and (MultiZipInfo.MultiMode = mmNone)) then
   begin                          { Added Multimode check 06/11/00  2.21b3+ }
     AllocateZipArrays;
     { create new file in temporary directory }
     UsingTempFile := True;
     If not ArchiveIsStream then
      begin
        {PathSize := GetTempPath( SizeOf(tempPathPStr), @tempPathPStr[0] );}
        { Changed to TempFilename  5/5/98  2.12 }
        tmpZipName := TempFilename(TemporaryPath);
        {tmpZipName := StrPas(tempPathPStr) + ExtractFileName( ZipName );}
      end;
     CreateTempZip;
     OpenZip; { open existing zip so we can move existing files }
     MoveExistingFiles;  {Move those existing files}
   end
  Else
   begin
     AllocateZipArrays;
     If not ArchiveIsStream then
        tmpZipName := ZipName;
     UsingTempFile := False;
     CreateTempZip;
   end;

  If (not Deleting) and (FilesList.Count > 0) then
   begin
     StopNow := False;
     If Assigned(FOnStartZipInfo) then
        FOnStartZipInfo( Self, FilesList.Count, TotalUncompressedSize, tmpecrec, StopNow );
     If StopNow then
        {$IFDEF NO_RES}
         raise EUserCanceled.Create('User canceled Zip operation.');
        {$ELSE}
         raise EUserCanceled.Create(LoadStr(IDS_CANCELZIPOPERATION));
        {$ENDIF}
   end;

  If MultiZipInfo.MultiMode <> mmNone then
     TotalUncompressedSize := TotalUnCompressedSize * 2;

  { For each file in the FilesList AddFileToZip }
  If (not Deleting) and (FilesList.Count > 0) then
   begin
     For i := 0 to FilesList.Count-1 do
      begin
        tmpfile_info := CreateNewZipHeader;
        try
           If AddFileToZip(FilesList[i]) then
              AddTheNewFile(i)
           Else
            begin
              tmpfile_info.Free;
              tmpfile_info := nil;
            end;
        except
           tmpfile_info.Free;
           tmpfile_info := nil;
           raise;
        end;
      end;
   end;  { If not Deleting }
  tmpecrec.offset_central := zfile.Position;
  tmpecrec.start_central_disk := CurrentDisk;
  totalCentralSize := 0;
  saveCentralPos := tmpecrec.offset_central;
  For i := 0 to tmpfiles2.Count-1 do
   begin
     tmpfile_info := tmpfiles2.Items[i] as TZipHeaderInfo;
     If (MultiZipInfo.MultiMode <> mmNone) and (RoomLeft < tmpfile_info.CentralSize) then
      begin
        Inc(TotalCentralSize,zfile.Position - saveCentralPos);
        saveCentralPos := 0;
        NextPart;
        If i = 0 then
         begin
           tmpecrec.offset_central := 0;
           tmpecrec.start_central_disk := CurrentDisk;
         end;
      end;
     tmpfile_info.SaveCentralToStream( zfile );
     if (tmpfile_info.Cextra_field_length > 0) then
      begin  { Copy central directory's extra field }  { 04/06/02  2.22+ }
        theZipFile.Seek(tmpfile_info.central_offset+sizeOf(central_file_header)+
                                      tmpfile_info.filename_length, soFromBeginning);
        zfile.CopyFrom(theZipFile, tmpfile_info.Cextra_field_length);
      end;
   end;
  Inc(TotalCentralSize,zfile.Position - saveCentralPos);
  tmpecrec.size_central := TotalCentralSize;
  If (MultiZipInfo.MultiMode <> mmNone) and (RoomLeft < tmpecrec.EndCentralSize) then
     NextPart;
  tmpecrec.this_disk := CurrentDisk;
  tmpecrec.SaveToStream(zfile);
  If MultiZipInfo.MultiMode = mmSpan then
     LabelDisk;
  FinishedOK := True;
  finally
   DeAllocateZipArrays;
   If (not ArchiveIsStream) then
    begin
     zfile.Free;   { close the temp zip file }
     zfile := nil;
    end;
   If FinishedOK then
    begin
     If (not ArchiveIsStream) and (not CreatingSFX) then
        SaveZipName := ZipName;
     { Removed (not ArchiveIsStream) because it was keeping files from getting freed }
     { 01/20/02  2.22+ }
     If (not CreatingSFX) and ({(not ArchiveIsStream) and} (UsingTempFile)) then
        ClearZip;
     If (MultiZipInfo.MultiMode = mmBlocks) then
      begin
        If (CurrentDisk > 0) then
           ZipName := ChangeFileExt(SaveZipName,'.'+Format('%3.3d',[CurrentDisk+1]))
        Else
         begin  { No need for the multi file extention so change back to .zip }
           ZipName := SaveZipName;
           SaveZipName := ChangeFileExt(SaveZipName,'.'+Format('%3.3d',[CurrentDisk+1]));
           RenameFile(SaveZipName, ZipName);
         end;
      end
     Else If (not ArchiveIsStream) and (not CreatingSFX) then
        ZipName := SaveZipName;
     If (UsingTempFile) then
        MoveTempFile
     Else If ArchiveIsStream then
        zfile := nil;  {2/11/98}
     If (Dispose) then
        DisposeOfFiles;

     If not CreatingSFX then
      begin    { We'll point everyting to the newly created information }
        ecrec.Assign( tmpecrec );
        files := tmpfiles2;
        sortfiles := files;
        SortMode := ByNone;
      end
     Else  { We're going back to the same zip file }
      begin
        tmpfiles2.Free;
        tmpfiles2 := nil;
        sortfiles := SaveSortedFiles;
      end;

     If (not ArchiveIsStream) and (not CreatingSFX) then
        filesDate := FileDate( ZipName );
     If (SaveSortMode <> ByName) and (not CreatingSFX) then
        Sort(SaveSortMode)
     Else If (not CreatingSFX) then
      begin
        sortfiles := tmpfiles;  { already sorted by name }
        tmpfiles := nil;
      end;
     WriteNumDisks( CurrentDisk+1 );

     { Changed to call even if not spanned zip files 9/30/01 2.22+ }
     { When last file skipped OnTotalPercent wasn't being called }
     If {(MultiZipInfo.MultiMode <> mmNone) and} (Assigned(FOnTotalPercentDone)) then
        OnTotalPercentDone(self, 100);   { To be sure. 5/23/99 2.18+}

     If (MultiZipInfo.MultiMode <> mmNone) and (MultiZipInfo.SaveZipInfoOnFirstDisk)
        and (ecrec.this_disk > 0) then
     begin
        {$IFNDEF KPSMALL}
        SaveCursor := Screen.Cursor;
        {$ENDIF}
        If MultiZipInfo.MultiMode = mmSpan then
        begin
           AskForNewDisk(1);  { Ask for 1st disk }
           {$IFNDEF KPSMALL}
           Screen.Cursor := crHourGlass;
           {$ENDIF}
        end;
        SaveZipInfoToFile(ChangeFileExt(ZipName,'.zfc'));
        {$IFNDEF KPSMALL}
        If MultiZipInfo.MultiMode = mmSpan then
        Screen.Cursor := SaveCursor;
        {$ENDIF}
     end;

   end
   Else
    begin
     tmpfiles2.Free;
     tmpfiles2 := nil;
     SysUtils.DeleteFile( tmpZipName );
    end;

   SortMode := SaveSortMode;
   KeepZipOpen := SaveKeepZipOpen;
   tmpfiles.Free;
   tmpfiles := nil;
   tmpecrec.Free;
   tmpecrec := nil;
   CloseZip;
   If ArchiveIsStream then
     GetFileInfo(theZipFile);

   FBusy := False;
   FilesList.Clear;  { 6/27/99 2.18+ }
  end;
end;

procedure TVCLZip.CreateTempZip;
begin
  If MultiZipInfo.MultiMode = mmBlocks then
     tmpZipName := ChangeFileExt(tmpZipName,'.'+Format('%3.3d',[CurrentDisk+1]));
  If not ArchiveIsStream then
     zfile := TLFNFileStream.CreateFile( tmpZipName, fmCreate, FFlushFilesOnClose, BufferedStreamSize )
  Else
   begin
     If UsingTempFile then
        zfile := TMemoryStream.Create
     Else
        zfile := theZipFile;   {2/11/98}
   end;
  If CreatingSFX then
     zfile.CopyFrom( SFXStubFile, SFXStubFile.Size );
  tmpfiles := TSortedZip.Create( DupError );
  tmpfiles.SortMode := ByName;
  tmpfiles.DestroyObjects := False;
  tmpfiles2 := TSortedZip.Create( DupError );
  tmpfiles2.SortMode := ByNone;
  tmpecrec := TEndCentral.Create;
  If (UsingTempFile) or (ecrec.Modified) then
   begin
     tmpecrec.Assign( ecrec );
     If (tmpecrec.zip_comment_length > 0) and (tmpecrec.ZipComment = nil) then
        tmpecrec.ZipComment := StrToPChar(ZipComment);
     tmpecrec.num_entries := 0;
     tmpecrec.num_entries_this_disk := 0;
     tmpecrec.Modified := False;
   end;
end;

function TVCLZip.DiskRoom: BIGINT;
  var
     Disk: Byte;
  begin
     If ZipName[2] <> ':' then
        Disk := 0
     Else
      begin
        Disk := Ord(ZipName[1])-64;
        If Disk > 32 then
           Dec(Disk,32);
      end;
     Result := DiskFree(Disk);
  end;

function TVCLZip.RoomLeft: BIGINT;
begin
  Result := AmountToWrite - zfile.Size;
end;

procedure TVCLZip.LabelDisk;
var
  Disk: String;
  NewLabel: String;
  {Rslt: LongBool;}
begin
  If (MultiZipInfo.MultiMode = mmSpan) and  (MultiZipInfo.WriteDiskLabels) then
   begin
     Disk := ZipName[1];
     Disk := UpperCase(Disk);
     If (Disk = 'A') or (Disk = 'B') then  { Only label floppies }
      begin
        Disk := Disk + ':\';
        NewLabel := 'PKBACK# ' + Format('%3.3d',[CurrentDisk+1]);
   {Rslt :=} SetVolLabel(Disk, NewLabel);
      end;
   end;
end;

procedure TVCLZip.NextPart;
begin
 If MultiZipInfo.MultiMode <> mmNone then
 begin
  If MultiZipInfo.MultiMode = mmSpan then
   begin
     If Assigned(FOnGetNextDisk) then
      begin
        zfile.Free;
        zfile := nil;
        LabelDisk; { Label disk before they change it }
        OnGetNextDisk(Self, CurrentDisk+2, tmpZipName);
        If tmpZipName = '' then
           {$IFDEF NO_RES}
            raise EUserCanceled.Create('User canceled Zip operation.');
           {$ELSE}
            raise EUserCanceled.Create(LoadStr(IDS_CANCELZIPOPERATION));
           {$ENDIF}
        Inc(CurrentDisk);
        if FileExists(tmpZipName) then
           SysUtils.DeleteFile(tmpZipName);  { 10/19/99  2.20b3+ }
        if Assigned(FOnPrepareNextDisk) then
           FOnPrepareNextDisk( self, CurrentDisk+1 );
        AmountToWrite := DiskRoom;
      end
   end
  Else