Subversion Repositories autosfx

unit ExtractorMain;

{$DEFINE USE_DZIP_UNPACK} // recommended

interface

uses

  Windows, SysUtils, Classes, Controls, Forms, Dialogs, StdCtrls, ShellAPI,

  ExtCtrls, ComCtrls, ZipMstr19, ZMMsgStr19, ZMMsg19, ZMDelZip19,

  ZMCompat19, SFXBehavior, ShlObj;

type

  TOverwriteDecision = (odUndefined, odOverwriteAll, odOverwriteNothing);

  TMainForm = class(TForm)

    ProgressBar: TProgressBar;

    WaitLabel: TLabel;

    CancelBtn: TButton;

    CurrentFileLabel: TLabel;

    AutoTimer: TTimer;

    itemBar: TProgressBar;

    procedure CancelBtnClick(Sender: TObject);

    procedure FormCreate(Sender: TObject);

    procedure AutoTimerTimer(Sender: TObject);

    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);

  private

    ExtractionInProcess: boolean;

    uz: TZipMaster19;

    RenamingOldPrefix: string;

    RenamingNewPrefix: string;

    zb: TZIPBehavior;

    BaseDir: string;

    AbortUnzip: boolean;

    StopAskingPassword: boolean;

    LastTriedPassword: string;

    CachedOverwriteDecision: TOverwriteDecision;

    {$IFNDEF USE_DZIP_UNPACK}

    procedure ExtractDllFromResource(ADirectory: string);

    {$ENDIF}

    procedure ExtractZipHere(AZipfile: string);

    procedure EvExtFNChange(Sender: TObject; var FileName: TZMString; const BaseDir: TZMString; var IsChanged: Boolean);

    procedure EvProgress(Sender: TObject; details: TZMProgressDetails);

    procedure EvTick(Sender: TObject);

    procedure EvCheckTerminate(Sender: TObject; var abort: Boolean);

    procedure EvConfirmOverwrite(Sender: TObject; const ForFile: TZMString;

      IsOlder: Boolean; var DoOverwrite: Boolean; DirIndex: Integer);

    procedure EvPasswordEvent(Sender: TObject; IsZipAction: Boolean;

      var NewPassword: String; const ForFile: TZMString; var RepeatCount: Longword;

      var Action: TMsgDlgBtn);

    procedure EvSkipEvent(Sender: TObject; const ForFile: TZMString;

      SkipType: TZMSkipTypes; var ExtError: Integer);

    function StripBaseDir(const s: string): string;

  end;

var

  MainForm: TMainForm;

implementation

uses

  ExtractorPassword, ExtractorError, Functions, SFXAutoRun, ExtractorComment,

  BrowseFolder;

const

  EvPasswordTries = 15;

{$R *.dfm}

{$R zmstr1900102\DLL\ResDLL-Maker\ZMRes19_dll.res}

function IsRootFile(s: string): boolean;

var

  i: integer;

begin

  if s = '' then

  begin

    result := false;

    Exit;

  end;

  if LooksLikeDir(s) then

  begin

    s := Copy(s, 1, Length(s)-1);

  end;

  for i := 1 to Length(s) do

  begin

    if s[i] = PathDelim then

    begin

      result := false;

      Exit;

    end;

  end;

  result := true;

end;

function FEListAll(theRec: TZMDirEntry; var Data): Integer;

var

  l: TStringList absolute Data;

  s: string;

begin

  Result := 0;

  s := theRec.FileName;

  l.Add(s);

  s := ExtractFilePath(s);

  if l.IndexOf(s) = -1 then l.Add(s);

end;

procedure ListRootFiles(uz: TZipMaster19; List: TStringList);

var

  s: string;

  l: TStringList;

  i: Integer;

resourcestring

  Lng_ForeachFailed = 'Dateiiteration fehlgeschlagen!';

begin

  List.Clear;

  l := TStringList.Create;

  try

    // Fill list (inclusive Directories)

    uz.FSpecArgs.Add('*');

    if uz.ForEach(FEListAll, l) <> 0 then

    begin

      MessageDlg(Lng_ForeachFailed, mtError, [mbOk], 0);

    end;

    // Now look for root files

    for i := 0 to l.Count - 1 do

    begin

      s := l.Strings[i];

      if IsRootFile(s) then

      begin

        List.Add(s);

      end;

    end;

  finally

    l.Free;

  end;

end;

procedure TMainForm.ExtractZipHere(AZipfile: string);

var

  l: TStringList;

  s: string;

  ec: Integer;

  ar: TExecuteSFXAutoRunResult;

  GeneralBaseDir: string;

  ok: boolean;

const

  C_Explorer_Open_Param = '"%s"';

  C_Explorer_Select_Param = '/n,/select,"%s"';

  EXPLORER_EXE = 'explorer';

resourcestring

  Lng_Aborted = 'Der laufende Prozess wurde abgebrochen. Das extrahierten Dateien sind somit unvollständig.';

  Lng_Zip_Error = 'ZIP-Master Fehler "%s" (%d)';

  Lng_AutoRunFailed = 'SFX-AutoRun fehlgeschlagen. Die entpackten Inhalte werden nun angezeigt.';

  Lng_Unknown_Error = 'Unbekannter Fehler: Dateien sind nicht aufzufinden!';

  Lng_SelectDir = 'Bitte wählen Sie ein Verzeichnis zum Extrahieren aus. Es wird maximal 1 Datei bzw. Ordner erstellt!';

  Lng_WriteProtected = 'Das Verzeichnis ist nicht schreibbar! Bitte wählen Sie ein Anderes.';

begin

  AZipfile := ExpandUNCFileName(AZipfile);

  RenamingOldPrefix := '';

  RenamingNewPrefix := '';

  if Assigned(uz) then uz.Free; // uz ist global, damit AbortDLL aufgerufen werden kann

  uz := TZipMaster19.Create(nil);

  try

    ExtractionInProcess := true;

    {$IFNDEF USE_DZIP_UNPACK}

    uz.DLLDirectory := GetTempDirectory + DelZipDLL_Name;

    {$ENDIF}

    uz.DLL_Load := true;

    uz.ZipFileName := AZipFile;

    uz.Active := true;

    zb := ReadBehavior(uz.ZipComment);

    uz.Unattended := true;

    uz.ExtrOptions := [ExtrDirNames, ExtrOverWrite, ExtrFreshen, ExtrUpdate,

      ExtrForceDirs, ExtrNTFS];

    uz.OnExtractOverwrite := EvConfirmOverwrite;

    uz.OnProgress := EvProgress;

    uz.OnTick := EvTick;

    uz.OnCheckTerminate := EvCheckTerminate;

    uz.OnPasswordError := EvPasswordEvent;

    uz.PasswordReqCount := EvPasswordTries;

    uz.OnSkipped := EvSkipEvent;

    uz.OnSetExtName := EvExtFNChange;

    // Find out base dirtory

    GeneralBaseDir := '';

    if zb.ExtractionTarget = etExtractHere then

    begin

      GeneralBaseDir := ExtractFilePath(AZipfile); // Default

      if not IsDirectoryWritable(GeneralBaseDir) or

         IsAtFlobbyDisk(GeneralBaseDir) then

      begin

        zb.ExtractionTarget := etDesktop;

      end;

    end;

    if zb.ExtractionTarget = etDesktop then

    begin

      GeneralBaseDir := GetSpecialFolderPath(CSIDL_DESKTOP);

      if not IsDirectoryWritable(GeneralBaseDir) or

         IsAtFlobbyDisk(GeneralBaseDir) then

      begin

        zb.ExtractionTarget := etAsk;

      end;

    end;

    if zb.ExtractionTarget = etAsk then

    begin

      repeat

        GeneralBaseDir := MySelectDirectory(Lng_SelectDir);

        if GeneralBaseDir = '' then Exit;

        ok := IsDirectoryWritable(GeneralBaseDir);

        if not ok then

        begin

          MessageDlg(Lng_WriteProtected, mtWarning, [mbOk], 0);

        end;

      until ok;

    end;

    GeneralBaseDir := IncludeTrailingPathDelimiter(GeneralBaseDir);

    // Semantic scanning of ZIP to determinate the final extraction directory

    l := TStringList.Create;

    try

      // Count the root objects (files OR dirs) in the ZIP

      ListRootFiles(uz, l);

      if l.Count = 0 then

      begin

        // Empty ZIP or Extractor.exe was called without ZIP attached

        Exit;

      end

      else if l.Count = 1 then

      begin

        // 1 Object = Extract it right here!

        BaseDir := GeneralBaseDir;

        s := BaseDir + l.Strings[0];

        RenamingOldPrefix := l.Strings[0]; // = StripBaseDir(S);

        if zb.ConflictBehavior = cbAvoid then

        begin

          s := SearchNextFreeName(s, LooksLikeDir(s));

        end;

        RenamingNewPrefix := StripBaseDir(s);

      end

      else

      begin

        // 2+ Objects = Extract them in a separate folder

        s := GeneralBaseDir + ExtractFileNameWithoutExt(AZipfile) + PathDelim;

        if zb.ConflictBehavior = cbAvoid then

        begin

          s := SearchNextFreeName(s, true);

          MkDir(s);

        end

        else

        begin

          if not DirectoryExists(s) then MkDir(s);

        end;

        BaseDir := s;

      end;

      BaseDir := IncludeTrailingPathDelimiter(BaseDir);

      uz.ExtrBaseDir := BaseDir;

      // Pre-Extract-Dialog

      if zb.CommentPresentation = cpBeforeExtracting then

      begin

        if not CommentForm.ShowCommentModal(uz.ZipComment) then exit;

      end;

      // Extract

      ec := uz.Extract;

      if ec <> 0 then

      begin

        if ec = DS_Canceled then

        begin

          MessageDlg(Lng_Aborted, mtWarning, [mbOk], 0);

        end

        else

        begin

          MessageDlg(Format(Lng_Zip_Error, [uz.ErrMessage, ec]), mtError, [mbOk], 0);

        end;

      end;

      // Errors?

      if ErrorForm.ErrorsAvailable then

      begin

        Hide;

        ErrorForm.ShowModal;

      end;

      // Show After-Extracting comment?

      if zb.CommentPresentation = cpAfterExtracting then

      begin

        if not CommentForm.ShowCommentModal(uz.ZipComment) then exit;

      end;

      // Now search for an AutoRun.inf

      ar := ExecuteSFXAutoRun(BaseDir);

      if ar.AutoRunSectionAvailable and not ar.ExecutionSucceed then

      begin

        MessageDlg(Lng_AutoRunFailed, mtError, [mbOk], 0);

        ar.OpenUnzippedContent := true;

      end;

      // Now open the file for the user

      if not ar.AutoRunSectionAvailable or ar.OpenUnzippedContent then

      begin

        if DirectoryExists(s) then

        begin

          // If it is a folder, open it

          ShellExecute(0, 'open', EXPLORER_EXE,

            PChar(Format(C_Explorer_Open_Param, [s])), '', SW_NORMAL);

        end

        else if FileExists(s) then

        begin

          // If it is a file, then only select it

          // Que: Funktioniert das auch ohne "/n"?

          // Im Moment wird bei einem BESTEHENDEN Fenster

          // die Selektion nicht durchgeführt.

          ShellExecute(0, 'open', EXPLORER_EXE,

            PChar(Format(C_Explorer_Select_Param, [s])), '', SW_NORMAL);

        end

        else

        begin

          if not AbortUnzip then

          begin

            MessageDlg(Lng_Unknown_Error, mtError, [mbOk], 0);

          end;

        end;

      end;

    finally

      l.Free;

    end;

  finally

    uz.Free;

    ExtractionInProcess := false;

  end;

end;

procedure TMainForm.EvProgress(Sender: TObject; details: TZMProgressDetails);

begin

  CurrentFileLabel.Caption := details.ItemName;

  progressBar.Position := details.TotalPosition;

  progressBar.Max := details.TotalSize;

  itemBar.Position := details.ItemPosition;

  itemBar.Max := details.ItemSize;

  Application.ProcessMessages;

end;

procedure TMainForm.EvExtFNChange(Sender: TObject;

  var FileName: TZMString; const BaseDir: TZMString;

  var IsChanged: Boolean);

begin

  if RenamingOldPrefix = RenamingNewPrefix then Exit;

  FileName := RenamingNewPrefix + Copy(FileName, 1+Length(RenamingOldPrefix), Length(FileName)-Length(RenamingOldPrefix));

  IsChanged := true;

end;

procedure TMainForm.EvTick(Sender: TObject);

begin

  Application.ProcessMessages;

end;

procedure TMainForm.EvCheckTerminate(Sender: TObject; var abort: Boolean);

begin

  abort := AbortUnzip;

end;

procedure TMainForm.EvConfirmOverwrite(Sender: TObject; const ForFile: TZMString;

  IsOlder: Boolean; var DoOverwrite: Boolean; DirIndex: Integer);

resourcestring

  Lng_Overwrite = 'Bestehende Datei "%s" überschreiben?';

var

  res: Integer;

begin

  if zb.ConflictBehavior = cbOverwrite then

  begin

    DoOverwrite := true;

    Exit;

  end

  else if zb.ConflictBehavior = cbNewer then

  begin

    DoOverwrite := IsOlder; // If file on DISK is older, then overwrite.

    Exit;

  end

  else if zb.ConflictBehavior = cbAsk then

  begin

    // Workaround: Verzeichnisse brauchen das nicht,

    // denn es wird bei den Dateien nochmal nachgefragt

    if LooksLikeDir(ForFile) then

    begin

      DoOverwrite := true;

      Exit;

    end;

    if CachedOverwriteDecision = odUndefined then

    begin

      res := MessageDlg(Format(Lng_Overwrite, [ForFile]), mtConfirmation, [mbYes, mbNo, mbYesToAll, mbNoToAll], 0);

      DoOverwrite := (res = mrYes) or (res = mrYesToAll);

      if res = mrNoToAll then CachedOverwriteDecision := odOverwriteNothing;

      if res = mrYesToAll then CachedOverwriteDecision := odOverwriteAll;

    end

    else

    begin

      DoOverwrite := CachedOverwriteDecision = odOverwriteAll;

    end;

  end

  else if zb.ConflictBehavior = cbAvoid then

  begin

    // Nothing to do

  end;

end;

procedure TMainForm.EvPasswordEvent(Sender: TObject; IsZipAction: Boolean;

  var NewPassword: String; const ForFile: TZMString; var RepeatCount: Longword;

  var Action: TMsgDlgBtn);

var

  repc: integer;

begin

  repc := EvPasswordTries - RepeatCount + 1;

  // Eine Passworteingabe wurde abgebrochen. Frage nicht mehr nach.

  if StopAskingPassword then Exit;

  // Wurde schonmal ein Passwort eingegeben?

  if LastTriedPassword <> '' then

  begin

    // Schauen, ob das letzte Passwort auch mit dieser Datei geht.

    if repc = 1 then

    begin

      // Ja, geht

      NewPassword := LastTriedPassword;

      Exit;

    end

    else

    begin

      // Leider nein

      LastTriedPassword := '';

    end;

  end;

  if PasswordDlg.ShowModal(StripBaseDir(ForFile), repc, EvPasswordTries) = mrOk then

  begin

    NewPassword := PasswordDlg.Password.Text;

    if NewPassword = '' then NewPassword := ' '; // Neue Eingabe erzwingen.

    LastTriedPassword := NewPassword;

  end

  else

  begin

    StopAskingPassword := true;

    Action := mbCancel;

  end;

end;

procedure TMainForm.CancelBtnClick(Sender: TObject);

resourcestring

  Lng_AbortExtract = 'Extrahieren abbrechen?';

begin

  if not ExtractionInProcess then

  begin

    Close;

    Exit;

  end;

  if MessageDlg(Lng_AbortExtract, mtConfirmation, mbYesNoCancel, 0) = mrYes then

  begin

    CancelBtn.Enabled := false;

    uz.AbortDLL;

    AbortUnzip := true;

    // Close wird durch den Timer durchgeführt

    Exit;

  end;

end;

procedure TMainForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);

begin

  if not ExtractionInProcess then

  begin

    CanClose := true;

    Exit;

  end;

  if not AbortUnzip then

  begin

    CanClose := false;

    CancelBtn.Click;

  end;

end;

procedure TMainForm.FormCreate(Sender: TObject);

resourcestring

  Lng_Extracting = 'Extrahiere Dateien. Bitte warten...';

begin

  WaitLabel.Caption := Lng_Extracting;

  WaitLabel.Left := progressBar.Width div 2 - WaitLabel.Width div 2;

  CurrentFileLabel.Caption := '';

end;

{$IFNDEF USE_DZIP_UNPACK}

procedure TMainForm.ExtractDllFromResource(ADirectory: string);

var

  s: TResourceStream;

  o: TFileStream;

  AOutFile: string;

begin

  AOutFile := IncludeTrailingPathDelimiter(ADirectory) + DelZipDLL_Name;

  s := TResourceStream.Create(0, DZRES_Dll, RT_RCDATA);

  try

    try

      s.Seek(SizeOf(Integer), soFromBeginning); // Ref: ZMDllLoad19.pas:427

      if FileExists(AOutFile) then

        o := TFileStream.Create(AOutFile, fmOpenWrite or fmShareDenyNone)

      else

        o := TFileStream.Create(AOutFile, fmCreate or fmShareDenyNone);

      try

        o.CopyFrom(s, s.Size-s.Position);

      finally

        o.Free;

      end;

    except

      if FileExists(AOutFile) then

      begin

        // Probably the file is write-locked (maybe some other Extractor is

        // using it right now? Even if we run into danger that the target DLL

        // is a write-protected old/incompatible version of DelZip190.dll,

        // we do count this as success, since the file exists.

      end

      else

      begin

        raise;

      end;

    end;

  finally

    s.Free;

  end;

end;

{$ENDIF}

procedure TMainForm.AutoTimerTimer(Sender: TObject);

resourcestring

  Lng_NakedSFX = 'Das selbstentpackende Archiv (SFX) beschädigt oder ungültig. Wenn Sie diese Datei aus dem Internet bezogen haben, laden Sie sie bitte erneut herunter.';

  Lng_FileNotFound = 'Die durch Parameter angegebene Datei "%s" kann nicht gefunden werden!';

  Lng_TooManyArguments = 'Zu viele Argumente!';

begin

  AutoTimer.Enabled := false;

  {$IFNDEF USE_DZIP_UNPACK}

  ExtractDllFromResource(GetTempDirectory);

  {$ENDIF}

  try

    if IsExtractable(ParamStr(0)) then

    begin

      ExtractZipHere(ParamStr(0));

    end

    else

    begin

      // Der Extractor ist "nackt" oder das SFX beschädigt

      if ParamCount = 0 then

      begin

        MessageDlg(Lng_NakedSFX, mtError, [mbOk], 0);

      end

      else if ParamCount = 1 then

      begin

        // In diesem Zustand erlauben wir, fremde SFX zu entpacken (auch für Debugging-Zwecke)

        if FileExists(ParamStr(1)) then

        begin

          ExtractZipHere(ParamStr(1));

        end

        else

        begin

          MessageDlg(Lng_FileNotFound, mtError, [mbOk], 0);

        end;

      end

      else if ParamCount = 2 then

      begin

        // Future: Mehr als nur 1 Parameter erlauben?

        MessageDlg(Lng_TooManyArguments, mtError, [mbOk], 0);

      end;

    end;

  finally

    Close;

  end;

end;

function TMainForm.StripBaseDir(const s: string): string;

begin

  // Warnung: Es wird nicht überprüft, ob der String auch

  // wirklich mit dem BaseDir beginnt!

  result := Copy(s, Length(BaseDir)+1, Length(s)-Length(BaseDir));

end;

procedure TMainForm.EvSkipEvent(Sender: TObject; const ForFile: TZMString;

  SkipType: TZMSkipTypes; var ExtError: Integer);

resourcestring

  Lng_PasswordWrong = 'Das Passwort wurde zu oft falsch eingegeben. Die Datei "%s" wird nicht extrahiert.';

begin

  if (SkipType = stBadPassword) and not StopAskingPassword then

  begin

    MessageDlg(Format(Lng_PasswordWrong, [ForFile]), mtError, [mbOk], 0);

    LastTriedPassword := '';

  end;

  ErrorForm.NewError(ForFile, SkipType);

end;

end.