Rev 2 | Go to most recent revision | Details | Last modification | View Log | RSS feed
Rev | Author | Line No. | Line |
---|---|---|---|
1 | daniel-mar | 1 | unit ExtractorMain; |
2 | |||
3 | {$DEFINE DEBUG_MODE} |
||
4 | |||
5 | {$DEFINE USE_DZIP_UNPACK} |
||
6 | |||
7 | // TODO: Implement ExtractionTarget switch |
||
8 | |||
9 | interface |
||
10 | |||
11 | uses |
||
12 | Windows, SysUtils, Classes, Controls, Forms, Dialogs, StdCtrls, ShellAPI, |
||
13 | ExtCtrls, ComCtrls, ZipMstr19, ZMMsgStr19, ZMMsg19, ZMDelZip19, |
||
14 | ZMCompat19, SFXBehavior; |
||
15 | |||
16 | type |
||
17 | TOverwriteDecision = (odUndefined, odOverwriteAll, odOverwriteNothing); |
||
18 | |||
19 | TMainForm = class(TForm) |
||
20 | ProgressBar: TProgressBar; |
||
21 | WaitLabel: TLabel; |
||
22 | CancelBtn: TButton; |
||
23 | CurrentFileLabel: TLabel; |
||
24 | AutoTimer: TTimer; |
||
25 | itemBar: TProgressBar; |
||
26 | procedure CancelBtnClick(Sender: TObject); |
||
27 | procedure FormCreate(Sender: TObject); |
||
28 | procedure AutoTimerTimer(Sender: TObject); |
||
29 | procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); |
||
30 | private |
||
31 | RenamingOldPrefix: string; |
||
32 | RenamingNewPrefix: string; |
||
33 | zb: TZIPBehavior; |
||
34 | BaseDir: string; |
||
35 | AbortUnzip: boolean; |
||
36 | StopAskingPassword: boolean; |
||
37 | LastTriedPassword: string; |
||
38 | OverwriteDecision: TOverwriteDecision; |
||
39 | {$IFNDEF USE_DZIP_UNPACK} |
||
40 | procedure ExtractDllFromResource(ADirectory: string); |
||
41 | {$ENDIF} |
||
42 | procedure ExtractZipHere(AZipfile: string); |
||
43 | procedure ArcExtFNChange(Sender: TObject; var FileName: TZMString; const BaseDir: TZMString; var IsChanged: Boolean); |
||
44 | procedure ArcProzess(Sender: TObject; details: TZMProgressDetails); |
||
45 | procedure ArcTick(Sender: TObject); |
||
46 | procedure ArcCheckTerminate(Sender: TObject; var abort: Boolean); |
||
47 | procedure ConfirmOverwrite(Sender: TObject; const ForFile: TZMString; |
||
48 | IsOlder: Boolean; var DoOverwrite: Boolean; DirIndex: Integer); |
||
49 | procedure ArcPassword(Sender: TObject; IsZipAction: Boolean; |
||
50 | var NewPassword: String; const ForFile: TZMString; var RepeatCount: Longword; |
||
51 | var Action: TMsgDlgBtn); |
||
52 | procedure SkipEvent(Sender: TObject; const ForFile: TZMString; |
||
53 | SkipType: TZMSkipTypes; var ExtError: Integer); |
||
54 | function StripBaseDir(const s: string): string; |
||
55 | end; |
||
56 | |||
57 | var |
||
58 | MainForm: TMainForm; |
||
59 | |||
60 | implementation |
||
61 | |||
62 | uses |
||
63 | ExtractorPassword, ExtractorError, Functions, SFXAutoRun, ExtractorComment; |
||
64 | |||
65 | const |
||
66 | MaxTries = 15; |
||
67 | |||
68 | {$R *.dfm} |
||
69 | |||
70 | {$R zmstr1900102\DLL\ResDLL-Maker\ZMRes19_dll.res} |
||
71 | |||
72 | function IsRootFile(s: string): boolean; |
||
73 | var |
||
74 | i: integer; |
||
75 | begin |
||
76 | if s = '' then |
||
77 | begin |
||
78 | result := false; |
||
79 | Exit; |
||
80 | end; |
||
81 | if LooksLikeDir(s) then |
||
82 | begin |
||
83 | s := Copy(s, 1, Length(s)-1); |
||
84 | end; |
||
85 | for i := 1 to Length(s) do |
||
86 | begin |
||
87 | if s[i] = PathDelim then |
||
88 | begin |
||
89 | result := false; |
||
90 | Exit; |
||
91 | end; |
||
92 | end; |
||
93 | result := true; |
||
94 | end; |
||
95 | |||
96 | function FEListAll(theRec: TZMDirEntry; var Data): Integer; |
||
97 | var |
||
98 | l: TStringList absolute Data; |
||
99 | s: string; |
||
100 | begin |
||
101 | Result := 0; |
||
102 | |||
103 | s := theRec.FileName; |
||
104 | l.Add(s); |
||
105 | |||
106 | s := ExtractFilePath(s); |
||
107 | if l.IndexOf(s) = -1 then l.Add(s); |
||
108 | end; |
||
109 | |||
110 | procedure ListRootFiles(uz: TZipMaster19; List: TStringList); |
||
111 | var |
||
112 | s: string; |
||
113 | l: TStringList; |
||
114 | i: Integer; |
||
115 | resourcestring |
||
116 | Lng_ForeachFailed = 'Dateiiteration fehlgeschlagen!'; |
||
117 | begin |
||
118 | List.Clear; |
||
119 | |||
120 | l := TStringList.Create; |
||
121 | try |
||
122 | // Fill list (inclusive Directories) |
||
123 | |||
124 | uz.FSpecArgs.Add('*'); |
||
125 | if uz.ForEach(FEListAll, l) <> 0 then |
||
126 | begin |
||
127 | MessageDlg(Lng_ForeachFailed, mtError, [mbOk], 0); |
||
128 | end; |
||
129 | |||
130 | // Now look for root files |
||
131 | |||
132 | for i := 0 to l.Count - 1 do |
||
133 | begin |
||
134 | s := l.Strings[i]; |
||
135 | |||
136 | if IsRootFile(s) then |
||
137 | begin |
||
138 | List.Add(s); |
||
139 | end; |
||
140 | end; |
||
141 | finally |
||
142 | l.Free; |
||
143 | end; |
||
144 | end; |
||
145 | |||
146 | procedure TMainForm.ExtractZipHere(AZipfile: string); |
||
147 | var |
||
148 | uz: TZipMaster19; |
||
149 | l: TStringList; |
||
150 | s: string; |
||
151 | ec: Integer; |
||
152 | ar: TExecuteSFXAutoRunResult; |
||
153 | resourcestring |
||
154 | Lng_Aborted = 'Der laufende Prozess wurde abgebrochen. Das extrahierten Dateien sind somit unvollständig.'; |
||
155 | Lng_Zip_Error = 'ZIP-Master Fehler "%s" (%d)'; |
||
156 | Lng_AutoRunFailed = 'SFX-AutoRun fehlgeschlagen. Die entpackten Inhalte werden nun angezeigt.'; |
||
157 | Lng_Unknown_Error = 'Unbekannter Fehler: Dateien sind nicht aufzufinden!'; |
||
158 | begin |
||
159 | AZipfile := ExpandUNCFileName(AZipfile); |
||
160 | RenamingOldPrefix := ''; |
||
161 | RenamingNewPrefix := ''; |
||
162 | |||
163 | uz := TZipMaster19.Create(nil); |
||
164 | try |
||
165 | {$IFNDEF USE_DZIP_UNPACK} |
||
166 | uz.DLLDirectory := GetTempDirectory + DelZipDLL_Name; |
||
167 | {$ENDIF} |
||
168 | uz.DLL_Load := true; |
||
169 | |||
170 | uz.ZipFileName := AZipFile; |
||
171 | uz.Active := true; |
||
172 | zb := ReadBehavior(uz.ZipComment); |
||
173 | |||
174 | uz.Unattended := true; |
||
175 | uz.ExtrOptions := [ExtrDirNames, ExtrOverWrite, ExtrFreshen, ExtrUpdate, |
||
176 | ExtrForceDirs, ExtrNTFS]; |
||
177 | |||
178 | if zb.ConflictBehavior <> cbAvoid then |
||
179 | begin |
||
180 | uz.OnExtractOverwrite := ConfirmOverwrite; |
||
181 | end; |
||
182 | uz.OnProgress := ArcProzess; |
||
183 | uz.OnTick := ArcTick; |
||
184 | uz.OnCheckTerminate := ArcCheckTerminate; |
||
185 | uz.OnPasswordError := ArcPassword; |
||
186 | uz.PasswordReqCount := MaxTries; |
||
187 | // TODO: Mehr events? |
||
188 | uz.OnSkipped := SkipEvent; |
||
189 | uz.OnSetExtName := ArcExtFNChange; |
||
190 | |||
191 | l := TStringList.Create; |
||
192 | try |
||
193 | // Count the root objects (files OR dirs) in the ZIP |
||
194 | |||
195 | ListRootFiles(uz, l); |
||
196 | |||
197 | if l.Count = 0 then |
||
198 | begin |
||
199 | // Empty ZIP or Extractor.exe was called without ZIP attached |
||
200 | Exit; |
||
201 | end |
||
202 | else if l.Count = 1 then |
||
203 | begin |
||
204 | // 1 Object = Extract it right here! |
||
205 | s := ExtractFilePath(AZipfile) + l.Strings[0]; |
||
206 | BaseDir := ExtractFilePath(AZipfile); |
||
207 | RenamingOldPrefix := StripBaseDir(S); |
||
208 | if zb.ConflictBehavior = cbAvoid then |
||
209 | begin |
||
210 | s := SearchNextFreeName(s); |
||
211 | end; |
||
212 | // TODO: helloworld.exe schlägt fehl! |
||
213 | RenamingNewPrefix := StripBaseDir(S); // We need to change the name! |
||
214 | end |
||
215 | else |
||
216 | begin |
||
217 | // 2+ Objects = Extract them in a separate folder |
||
218 | s := ChangeFileExt(AZipfile, ''); |
||
219 | if zb.ConflictBehavior = cbAvoid then |
||
220 | begin |
||
221 | s := SearchNextFreeName(s); |
||
222 | MkDir(s); |
||
223 | end |
||
224 | else |
||
225 | begin |
||
226 | if not DirectoryExists(s) then MkDir(s); |
||
227 | end; |
||
228 | BaseDir := s; |
||
229 | end; |
||
230 | BaseDir := IncludeTrailingPathDelimiter(BaseDir); |
||
231 | |||
232 | uz.ExtrBaseDir := BaseDir; // TODO: andere ordner erlauben |
||
233 | |||
234 | // Pre-Extract-Dialog |
||
235 | |||
236 | if zb.CommentPresentation = cpBeforeExtracting then |
||
237 | begin |
||
238 | if not CommentForm.ShowCommentModal(uz.ZipComment) then exit; |
||
239 | end; |
||
240 | |||
241 | // Extract |
||
242 | |||
243 | ec := uz.Extract; |
||
244 | |||
245 | if ec <> 0 then |
||
246 | begin |
||
247 | if ec = DS_Canceled then |
||
248 | begin |
||
249 | MessageDlg(Lng_Aborted, mtWarning, [mbOk], 0); |
||
250 | end |
||
251 | else |
||
252 | begin |
||
253 | MessageDlg(Format(Lng_Zip_Error, [uz.ErrMessage, ec]), mtError, [mbOk], 0); |
||
254 | end; |
||
255 | end; |
||
256 | |||
257 | // Errors? |
||
258 | |||
259 | if ErrorForm.ErrorsAvailable then |
||
260 | begin |
||
261 | ErrorForm.ShowModal; |
||
262 | end; |
||
263 | |||
264 | // Show After-Extracting comment? |
||
265 | |||
266 | if zb.CommentPresentation = cpAfterExtracting then |
||
267 | begin |
||
268 | if not CommentForm.ShowCommentModal(uz.ZipComment) then exit; |
||
269 | end; |
||
270 | |||
271 | // Now search for an AutoRun.inf |
||
272 | |||
273 | ar := ExecuteSFXAutoRun(BaseDir); |
||
274 | |||
275 | if ar.AutoRunSectionAvailable and not ar.ExecutionSucceed then |
||
276 | begin |
||
277 | MessageDlg(Lng_AutoRunFailed, mtError, [mbOk], 0); |
||
278 | ar.OpenUnzippedContent := true; |
||
279 | end; |
||
280 | |||
281 | // Now open the file for the user |
||
282 | |||
283 | if not ar.AutoRunSectionAvailable or ar.OpenUnzippedContent then |
||
284 | begin |
||
285 | if DirectoryExists(s) then |
||
286 | begin |
||
287 | // If it is a folder, open it |
||
288 | ShellExecute(0, 'open', 'explorer', |
||
289 | PChar('"'+s+'"'), '', SW_NORMAL); |
||
290 | end |
||
291 | else if FileExists(s) then |
||
292 | begin |
||
293 | // If it is a file, then only select it |
||
294 | |||
295 | // Que: Funktioniert das auch ohne "/n"? |
||
296 | // Im Moment wird bei einem BESTEHENDEN Fenster |
||
297 | // die Selektion nicht durchgeführt. |
||
298 | |||
299 | ShellExecute(0, 'open', 'explorer', |
||
300 | PChar('/n,/select,"'+s+'"'), '', SW_NORMAL); |
||
301 | end |
||
302 | else |
||
303 | begin |
||
304 | MessageDlg(Lng_Unknown_Error, mtError, [mbOk], 0); |
||
305 | end; |
||
306 | end; |
||
307 | finally |
||
308 | l.Free; |
||
309 | end; |
||
310 | finally |
||
311 | uz.Free; |
||
312 | end; |
||
313 | end; |
||
314 | |||
315 | procedure TMainForm.ArcProzess(Sender: TObject; details: TZMProgressDetails); |
||
316 | begin |
||
317 | CurrentFileLabel.Caption := details.ItemName; |
||
318 | |||
319 | progressBar.Position := details.TotalPosition; |
||
320 | progressBar.Max := details.TotalSize; |
||
321 | |||
322 | itemBar.Position := details.ItemPosition; |
||
323 | itemBar.Max := details.ItemSize; |
||
324 | |||
325 | Application.ProcessMessages; |
||
326 | end; |
||
327 | |||
328 | procedure TMainForm.ArcExtFNChange(Sender: TObject; |
||
329 | var FileName: TZMString; const BaseDir: TZMString; |
||
330 | var IsChanged: Boolean); |
||
331 | begin |
||
332 | if RenamingOldPrefix = RenamingOldPrefix then Exit; |
||
333 | |||
334 | FileName := RenamingNewPrefix + Copy(FileName, 1+Length(RenamingOldPrefix), Length(FileName)-Length(RenamingOldPrefix)); |
||
335 | IsChanged := true; |
||
336 | end; |
||
337 | |||
338 | procedure TMainForm.ArcTick(Sender: TObject); |
||
339 | begin |
||
340 | Application.ProcessMessages; |
||
341 | end; |
||
342 | |||
343 | procedure TMainForm.ArcCheckTerminate(Sender: TObject; var abort: Boolean); |
||
344 | begin |
||
345 | abort := AbortUnzip; |
||
346 | end; |
||
347 | |||
348 | procedure TMainForm.ConfirmOverwrite(Sender: TObject; const ForFile: TZMString; |
||
349 | IsOlder: Boolean; var DoOverwrite: Boolean; DirIndex: Integer); |
||
350 | resourcestring |
||
351 | Lng_Overwrite = 'Bestehende Datei "%s" überschreiben?'; |
||
352 | var |
||
353 | res: Integer; |
||
354 | begin |
||
355 | if zb.ConflictBehavior = cbOverwrite then |
||
356 | begin |
||
357 | DoOverwrite := true; |
||
358 | Exit; |
||
359 | end |
||
360 | else if zb.ConflictBehavior = cbNewer then |
||
361 | begin |
||
362 | DoOverwrite := IsOlder; // If file on DISK is older, then overwrite. |
||
363 | Exit; |
||
364 | end |
||
365 | else if zb.ConflictBehavior = cbAsk then |
||
366 | begin |
||
367 | // Workaround: Verzeichnisse brauchen das nicht, |
||
368 | // denn es wird bei den Dateien nochmal nachgefragt |
||
369 | if LooksLikeDir(ForFile) then |
||
370 | begin |
||
371 | DoOverwrite := true; |
||
372 | Exit; |
||
373 | end; |
||
374 | |||
375 | if OverwriteDecision = odUndefined then |
||
376 | begin |
||
377 | res := MessageDlg(Format(Lng_Overwrite, [ForFile]), mtConfirmation, [mbYes, mbNo, mbYesToAll, mbNoToAll], 0); |
||
378 | DoOverwrite := (res = mrYes) or (res = mrYesToAll); |
||
379 | if res = mrNoToAll then OverwriteDecision := odOverwriteNothing; |
||
380 | if res = mrYesToAll then OverwriteDecision := odOverwriteAll; |
||
381 | end |
||
382 | else |
||
383 | begin |
||
384 | DoOverwrite := OverwriteDecision = odOverwriteAll; |
||
385 | end; |
||
386 | end; |
||
387 | end; |
||
388 | |||
389 | procedure TMainForm.ArcPassword(Sender: TObject; IsZipAction: Boolean; |
||
390 | var NewPassword: String; const ForFile: TZMString; var RepeatCount: Longword; |
||
391 | var Action: TMsgDlgBtn); |
||
392 | var |
||
393 | repc: integer; |
||
394 | begin |
||
395 | repc := MaxTries - RepeatCount + 1; |
||
396 | |||
397 | // Eine Passworteingabe wurde abgebrochen. Frage nicht mehr nach. |
||
398 | if StopAskingPassword then Exit; |
||
399 | |||
400 | // Wurde schonmal ein Passwort eingegeben? |
||
401 | if LastTriedPassword <> '' then |
||
402 | begin |
||
403 | // Schauen, ob das letzte Passwort auch mit dieser Datei geht. |
||
404 | if repc = 1 then |
||
405 | begin |
||
406 | // Ja, geht |
||
407 | NewPassword := LastTriedPassword; |
||
408 | Exit; |
||
409 | end |
||
410 | else |
||
411 | begin |
||
412 | // Leider nein |
||
413 | LastTriedPassword := ''; |
||
414 | end; |
||
415 | end; |
||
416 | |||
417 | if PasswordDlg.ShowModal(StripBaseDir(ForFile), repc, MaxTries) = mrOk then |
||
418 | begin |
||
419 | NewPassword := PasswordDlg.Password.Text; |
||
420 | if NewPassword = '' then NewPassword := ' '; // Neue Eingabe erzwingen. |
||
421 | LastTriedPassword := NewPassword; |
||
422 | end |
||
423 | else |
||
424 | begin |
||
425 | StopAskingPassword := true; |
||
426 | Action := mbCancel; |
||
427 | end; |
||
428 | end; |
||
429 | |||
430 | procedure TMainForm.CancelBtnClick(Sender: TObject); |
||
431 | resourcestring |
||
432 | Lng_AbortExtract = 'Extrahieren abbrechen?'; |
||
433 | begin |
||
434 | if MessageDlg(Lng_AbortExtract, mtConfirmation, mbYesNoCancel, 0) = mrYes then |
||
435 | begin |
||
436 | CancelBtn.Enabled := false; |
||
437 | AbortUnzip := true; |
||
438 | end; |
||
439 | end; |
||
440 | |||
441 | procedure TMainForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean); |
||
442 | begin |
||
443 | if not AbortUnzip then |
||
444 | begin |
||
445 | CancelBtn.Click; |
||
446 | CanClose := false; |
||
447 | end; |
||
448 | end; |
||
449 | |||
450 | procedure TMainForm.FormCreate(Sender: TObject); |
||
451 | resourcestring |
||
452 | Lng_Extracting = 'Extrahiere Dateien. Bitte warten...'; |
||
453 | begin |
||
454 | {$IFDEF DEBUG_MODE} |
||
455 | Caption := Caption + ' (Debug)'; |
||
456 | {$ENDIF} |
||
457 | WaitLabel.Caption := Lng_Extracting; |
||
458 | WaitLabel.Left := progressBar.Width div 2 - WaitLabel.Width div 2; |
||
459 | CurrentFileLabel.Caption := ''; |
||
460 | end; |
||
461 | |||
462 | {$IFNDEF USE_DZIP_UNPACK} |
||
463 | procedure TMainForm.ExtractDllFromResource(ADirectory: string); |
||
464 | var |
||
465 | s: TResourceStream; |
||
466 | o: TFileStream; |
||
467 | AOutFile: string; |
||
468 | begin |
||
469 | AOutFile := IncludeTrailingPathDelimiter(ADirectory) + DelZipDLL_Name; |
||
470 | s := TResourceStream.Create(0, DZRES_Dll, RT_RCDATA); |
||
471 | try |
||
472 | try |
||
473 | s.Seek(SizeOf(Integer), soFromBeginning); // Ref: ZMDllLoad19.pas:427 |
||
474 | if FileExists(AOutFile) then |
||
475 | o := TFileStream.Create(AOutFile, fmOpenWrite or fmShareDenyNone) |
||
476 | else |
||
477 | o := TFileStream.Create(AOutFile, fmCreate or fmShareDenyNone); |
||
478 | try |
||
479 | o.CopyFrom(s, s.Size-s.Position); |
||
480 | finally |
||
481 | o.Free; |
||
482 | end; |
||
483 | except |
||
484 | if FileExists(AOutFile) then |
||
485 | begin |
||
486 | // Probably the file is write-locked (maybe some other Extractor is |
||
487 | // using it right now? Even if we run into danger that the target DLL |
||
488 | // is a write-protected old/incompatible version of DelZip190.dll, |
||
489 | // we do count this as success, since the file exists. |
||
490 | end |
||
491 | else |
||
492 | begin |
||
493 | raise; |
||
494 | end; |
||
495 | end; |
||
496 | finally |
||
497 | s.Free; |
||
498 | end; |
||
499 | end; |
||
500 | {$ENDIF} |
||
501 | |||
502 | procedure TMainForm.AutoTimerTimer(Sender: TObject); |
||
503 | begin |
||
504 | AutoTimer.Enabled := false; |
||
505 | |||
506 | {$IFNDEF USE_DZIP_UNPACK} |
||
507 | ExtractDllFromResource(GetTempDirectory); |
||
508 | {$ENDIF} |
||
509 | |||
510 | try |
||
511 | {$IFDEF DEBUG_MODE} |
||
512 | if FileExists(ParamStr(1)) then |
||
513 | begin |
||
514 | ExtractZipHere(ParamStr(1)); |
||
515 | end |
||
516 | else |
||
517 | begin |
||
518 | {$ENDIF} |
||
519 | |||
520 | ExtractZipHere(ParamStr(0)); |
||
521 | |||
522 | {$IFDEF DEBUG_MODE} |
||
523 | end; |
||
524 | {$ENDIF} |
||
525 | finally |
||
526 | AbortUnzip := true; // Damit es zu keiner Abfrage kommt |
||
527 | Close; |
||
528 | end; |
||
529 | end; |
||
530 | |||
531 | function TMainForm.StripBaseDir(const s: string): string; |
||
532 | begin |
||
533 | // Warnung: Es wird nicht überprüft, ob der String auch |
||
534 | // wirklich mit dem BaseDir beginnt! |
||
535 | result := Copy(s, Length(BaseDir)+1, Length(s)-Length(BaseDir)); |
||
536 | end; |
||
537 | |||
538 | procedure TMainForm.SkipEvent(Sender: TObject; const ForFile: TZMString; |
||
539 | SkipType: TZMSkipTypes; var ExtError: Integer); |
||
540 | resourcestring |
||
541 | Lng_PasswordWrong = 'Das Passwort wurde zu oft falsch eingegeben. Die Datei "%s" wird nicht extrahiert.'; |
||
542 | begin |
||
543 | if (SkipType = stBadPassword) and not StopAskingPassword then |
||
544 | begin |
||
545 | MessageDlg(Format(Lng_PasswordWrong, [ForFile]), mtError, [mbOk], 0); |
||
546 | LastTriedPassword := ''; |
||
547 | end; |
||
548 | ErrorForm.NewError(StripBaseDir(ForFile)); |
||
549 | end; |
||
550 | |||
551 | end. |