vclzip.pas

这是在磁疗用DELPHI编写一套安装软件的程序源码

{$ENDIF}

function TVCLZip.ZipFromBuffer(Buffer: PChar; Amount: LongInt; FName: string): Integer;
begin
  Result := 0;
  if (Trim(FName) = '') or (Amount = 0) then
    exit;
  MemBuffer := Buffer;
  CurrMem := Buffer;
  MemLen := Amount;
  MemLeft := Amount;
  MemZipping := True;
  FilesList.Clear;
  FilesList.Add(Fname);
  try
    Result := Zip;
  finally
    MemZipping := False;
    CloseZip;
  end;
end;

function TVCLZip.Zip: Integer;
var
  OldBusy: Boolean;
begin
  OldBusy := SetBusy(True);
  try
    Result := ProcessFiles;
    if Assigned(FOnZipComplete) then FOnZipComplete(self, Result);
  finally
    SetBusy(OldBusy);
  end;
end;

procedure TVCLZip.ExpandFilesList(var NumFiles: Integer; var TotalBytes: Comp);
begin
  ExpandForWildCards;
  NumFiles :=  FilesList.Count;
  TotalBytes := TotalUncompressedSize;
end;

function TVCLZip.IsInExcludeList(N: string): Boolean;
var
  i: Integer;
  M, M1, M2: string; { 11/27/98  2.16+}
begin
  Result := False;
  i := 0;
  M1 := LowerCase(ExtractFilename(N)); { 10/23/98  2.16+ }
  M2 := LowerCase(N);
  while i < FExcludeList.Count do
  begin
     {If this exclude list item doesn't include path info then ignore
      path info for the file being tested too}
    if (Pos('\', FExcludeList[i]) = 0) then { 11/27/98  2.16+}
      M := M1
    else
      M := M2;
    if IsMatch(LowerCase(FExcludeList[i]), M) then
    begin
      Result := True;
      break;
    end;
    Inc(i);
  end;
end;

function TVCLZip.IsInNoCompressList(N: string): Boolean;
var
  i: Integer;
  M, M1, M2: string;
begin
  Result := False;
  i := 0;
  M1 := LowerCase(ExtractFilename(N)); { 10/23/98  2.16+ }
  M2 := LowerCase(N);
  while i < FNoCompressList.Count do
  begin
     {If this exclude list item doesn't include path info then ignore
      path info for the file being tested too}
    if (Pos('\', FNoCompressList[i]) = 0) then { 11/27/98  2.16+}
      M := M1
    else
      M := M2;
    if IsMatch(LowerCase(FNoCompressList[i]), M) then
    begin
      Result := True;
      break;
    end;
    Inc(i);
  end;
end;

  function TVCLZip.ComparePath(P: string): string;
  { This function expects P and RootDir to include full path information
    including disk information.  Also it is assumed that if RelativePaths
    is True then the path information for P contains RootDir. }
  begin
    if StorePaths then
    begin
      Result := ExtractFilePath(P);
      if FRelativePaths then
        Delete(Result, 1, Length(FRootDir))
      else
      begin
        { modified the following to handle UNC paths  3/26/98  2.1 }
        if (not FStoreVolumes) and (ExtractFileDrive(Result) <> '') {(Result[2] = ':')} then
          Result := RightStr(Result, Length(Result) - (Length(ExtractFileDrive(Result)) + 1));
           {Result := RightStr(Result,Length(Result)-3);}
      end;
    end
    else
      Result := '';
  end;

  procedure TVCLZip.ExpandForWildCards;
  var
    i: Integer;
    WildFiles: TStrings;
    DirSearch: TDirSearch;
    theFile, StartDir: string;
    SearchRec: TSearchRec;
    tmpsearchinfo: TZipHeaderInfo;
    tmpWildCard: string;
    Idx: Integer;
    IsAnEntry: Boolean;
    doRecurse: Boolean;
    tmpWildFile: string;
    tmpName: string;
    Retry: Boolean;
  begin
    WildFiles := TStringList.Create;
    TotalUncompressedSize := 0;
    TotalBytesDone := 0;
    i := 0;
    FilenameSize := 0;
    // Dummy call
    DirExists('');
    if ZipAction = zaFreshen then
      Sort(ByName); { so we can check FilesList agains whats there already }
    while (FilesList.Count > 0) and (i < FilesList.Count) do
    begin
      if (FilesList[i][Length(FilesList[i])] = '\') then
      begin
        if (MultiZipInfo.MultiMode <> mmNone) and (MultiZipInfo.SaveZipInfoOnFirstDisk) and (StorePaths) then
          FilenameSize := FileNameSize + Length(FilesList[i]) - 2;
        Inc(i);
        continue; { To explicitly add a plain directory entry  6/9/99 2.18+ }
      end;
      if IsWildcard(FilesList[i]) then
      begin
        WildFiles.Add(FilesList[i]);
        FilesList.Delete(i);
      end
      else
      begin { See if file exists }
        if ExtractFilePath(FilesList[i]) = '' then
          FilesList[i] := FRootDir + FilesList[i];
        if IsInExcludeList(FilesList[i]) then { 9/28/98  2.15 }
        begin
          if (Assigned(FOnSkippingFile)) then
            FOnSkippingFile(Self, srExcludeList, FilesList[i], -1, Retry);
          FilesList.Delete(i);
          Continue;
        end;
        if FindFirst(FilesList[i], FSearchAttribute, SearchRec) = 0 then
        begin
          if ((FSkipIfArchiveBitNotSet) and ((FileGetAttr(FilesList[i]) and faArchive) = 0)) then
          begin
            if (Assigned(FOnSkippingFile)) then
              FOnSkippingFile(Self, srArchiveBitNotSet, FilesList[i], -1, Retry);
            FilesList.Delete(i);
            FindClose(SearchRec);
            Continue; { Skip if only zipping files with archive bit set }
          end;
          if ZipAction = zaFreshen then
          begin
                { Ignore it if it's not already in the zip }
            tmpName := FilesList[i];
            if (OEMConvert = oemAlways) then
              OemFilter(tmpName);
            tmpsearchinfo := CreateNewZipHeader;
            tmpsearchinfo.filename := ExtractFilename(tmpName);
            tmpsearchinfo.directory := ComparePath(tmpName);
            IsAnEntry := sortfiles.Search(Pointer(tmpsearchinfo), Idx);
            tmpsearchinfo.Free;
            if not IsAnEntry then { Delete this entry from fileslist }
            begin
              if (Assigned(FOnSkippingFile)) then
                FOnSkippingFile(Self, srNoFileToFreshen, FilesList[i], -1, Retry);
              FilesList.Delete(i);
              FindClose(SearchRec);
              Continue; { Skip if freshening and file's not in zip already }
            end;
          end;
          TotalUncompressedSize := TotalUncompressedSize + GetFileSize(SearchRec);
          if (MultiZipInfo.MultiMode <> mmNone) and (MultiZipInfo.SaveZipInfoOnFirstDisk) and (StorePaths) then
            FilenameSize := FileNameSize + Length(FilesList[i]) - 2;
          Inc(i);
          FindClose(SearchRec); {1/28/98 moved inside here so wouldn't be called if}
        end {FindFirst didn't find anything    v2.00+}
        else
        begin
          if Assigned(FOnNoSuchFile) then
            OnNoSuchFile(Self, FilesList[i]);
              { Moved following line down 1 to fix 'List out of bounds' error. 5/5/98 2.12 }
          FilesList.Delete(i); { No such file to zip }
        end;
      end;
    end;

    if WildFiles.Count > 0 then
      for i := 0 to WildFiles.Count - 1 do
      begin
        { Added recursion override feature 7/22/98  2.14 }
        if (WildFiles[i][1] = WILDCARD_NORECURSE) then { No recursing }
        begin
          doRecurse := False;
          tmpWildFile := WildFiles[i];
          Delete(tmpWildFile, 1, 1);
          WildFiles[i] := tmpWildFile;
        end
        else if (WildFiles[i][1] = WILDCARD_RECURSE) then { Recurse }
        begin
          doRecurse := True;
          tmpWildFile := WildFiles[i];
          Delete(tmpWildFile, 1, 1);
          WildFiles[i] := tmpWildFile;
        end
        else doRecurse := FRecurse;

        StartDir := ExtractFileDir(WildFiles[i]);
        if StartDir = '' then
          StartDir := FRootDir;
        { Added check for not IsWildCard because it was stopping the use
          of wildcards in paths.   8/22/01  2.22+  }
        if (not IsWildCard(StartDir)) and (not DirExists(StartDir)) then { 10/23/98  2.16+ }
        begin
          if Assigned(FOnNoSuchFile) then
            OnNoSuchFile(Self, WildFiles[i]);
          continue;
        end;
        tmpWildCard := ExtractFilename(WildFiles[i]);
        { Convert *.* to * so that it will get all files in
          TDirSearch }
        if (tmpWildCard = '*.*') then { 7/9/01  2.21+ }
          tmpWildCard := '*';
        DirSearch := TDirSearch.Create(StartDir, tmpWildCard, doRecurse, FSearchAttribute);
        theFile := DirSearch.NextFile(SearchRec);
        while (theFile <> '') do
        begin
          if (Assigned(FOnRecursingFile)) then
            FOnRecursingFile(Self, theFile);
          if (theFile[Length(theFile)] = '\') then
          begin
            if (doRecurse) and (FAddDirEntries) then
            begin
              if (MultiZipInfo.MultiMode <> mmNone) and (MultiZipInfo.SaveZipInfoOnFirstDisk) and (StorePaths) then
                FilenameSize := FileNameSize + Length(theFile) - 2;
              FilesList.Add(theFile);
            end;
            theFile := DirSearch.NextFile(SearchRec);
            Continue;
          end;
          if IsInExcludeList(theFile) then { 9/28/98  2.15 }
          begin
            if (Assigned(FOnSkippingFile)) then
              FOnSkippingFile(Self, srExcludeList, theFile, -1, Retry);
            theFile := DirSearch.NextFile(SearchRec);
            Continue;
          end;
          if (DoProcessMessages) then
          begin
            YieldProcess;
            if CancelOperation then
            begin
              CancelOperation := False;
              raise EUserCanceled.Create(LoadStr(IDS_CANCELOPERATION));
            end;
            if PauseOperation then
              DoPause;
          end;
           {Don't archive the archive we are creating right now}
          if (ArchiveIsStream) or (AnsiCompareText(theFile, ZipName) <> 0) then
          begin
            if ((FSkipIfArchiveBitNotSet) and ((FileGetAttr(theFile) and faArchive) = 0)) then
            begin
              if (Assigned(FOnSkippingFile)) then
                FOnSkippingFile(Self, srArchiveBitNotSet, theFile, -1, Retry);
              theFile := DirSearch.NextFile(SearchRec);
              Continue; { Skip if only zipping files with archive bit set }
            end;
            if ZipAction = zaFreshen then { skip if its not already in zip file }
            begin
                 { Ignore it if it's not already in the zip }
              tmpName := theFile;
              if (OEMConvert = oemAlways) then
                OemFilter(tmpName);
              tmpsearchinfo := CreateNewZipHeader;
              tmpsearchinfo.filename := ExtractFilename(tmpName);
              tmpsearchinfo.directory := ComparePath(tmpName);
              IsAnEntry := sortfiles.Search(Pointer(tmpsearchinfo), Idx);
              tmpsearchinfo.Free;
              if not IsAnEntry then
              begin
                if (Assigned(FOnSkippingFile)) then
                  FOnSkippingFile(Self, srNoFileToFreshen, theFile, -1, Retry);
                theFile := DirSearch.NextFile(SearchRec);
                Continue; { Skip if freshening and file's not in zip already }
              end;
            end;
            if (MultiZipInfo.MultiMode <> mmNone) and (MultiZipInfo.SaveZipInfoOnFirstDisk) and (StorePaths) then
              FilenameSize := FileNameSize + Length(theFile) - 2;
            FilesList.Add(theFile);
            TotalUncompressedSize := TotalUncompressedSize + GetFileSize(SearchRec);
          end;
          theFile := DirSearch.NextFile(SearchRec);
        end;
        DirSearch.Free;
      end;

    WildFiles.Free;
    if (FilesList.Count > 0) and (FilenameSize > 0) and (MultiZipInfo.MultiMode <> mmNone)
          and (MultiZipInfo.SaveZipInfoOnFirstDisk) and (StorePaths) then
      FilenameSize := FileNameSize div FilesList.Count;
    if ZipAction = zaFreshen then
      Sort(ByNone); { Set back }
  end;


function TVCLZip.ProcessFiles: Integer;
var
  DisposeFiles: TStrings;
const
  SPANNED_SIG = $08074b50;
  SPANNED_NOT_SIG = $30304b50;

  procedure AddTheNewFile(i: Integer);

  {$IFDEF KPDEBUG}
    procedure ShowError(reason: string; e: Exception);
    var
      err: TErrorReport;
    begin
      err := TErrorReport.Create(self);
      err.ErrorMemo.Lines.Add(e.Message + ' - ' + reason);
      err.ErrorMemo.Lines.Add('  file = ' + tmpfile_info.directory + tmpfile_info.filename);
      err.ErrorMemo.Lines.Add('  relative_offset = ' + IntToStr(tmpfile_info.relative_offset));
      err.ErrorMemo.Lines.Add('  file position = ' + IntToStr(zfile.Position));
      err.ErrorMemo.Lines.Add('   file size = ' + IntToStr(zfile.Size));
      err.ErrorMemo.Lines.Add('  disk_number_start = ' + IntToStr(tmpfile_info.disk_number_start));
      err.ErrorMemo.Lines.Add('  uncompressed size = ' + IntToStr(tmpfile_info.uncompressed_size));
      err.ErrorMemo.Lines.Add('  compressed size = ' + IntToStr(tmpfile_info.compressed_size));
      err.ErrorMemo.Lines.Add('  number of entries = ' + IntToStr(tmpecrec.num_entries));
      err.ErrorMemo.Lines.Add('  current disk = ' + IntToStr(CurrentDisk));
      err.ErrorMemo.Lines.Add('  ');
      err.ErrorMemo.Lines.Add('  CLOSE WINDOW TO CONTINUE...');
      err.ShowModal;
      err.Free;
    end;
  {$ENDIF}

  begin
    try
      tmpfiles.AddObject(tmpfile_info);
    except
      on e: Exception do
      begin
        {$IFDEF KPDEBUG}
        ShowError('ByName', e);
        exit;
        {$ELSE}
        raise;
        {$ENDIF}
      end;
    end;
    try
      tmpfiles2.AddObject(tmpfile_info);
    except
      on e: Exception do