HCoop / bpt / emacs.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
* lisp/menu-bar.el (menu-bar-tools-menu): Add `browse-web'.
[bpt/emacs.git] / lisp / arc-mode.el
CommitLineData
665211a3
KH		 1;;; arc-mode.el --- simple editing of archives
2
ff4b7bd5 3;; Copyright (C) 1995, 1997-1998, 2001-2013 Free Software Foundation, Inc.
665211a3 4
6b61353c 5;; Author: Morten Welinder <terra@gnu.org>
8cb5ffe8 6;; Keywords: files archives msdog editing major-mode
c5e87d10 7;; Favorite-brand-of-beer: None, I hate beer.
665211a3 8
b578f267
EN		 9;; This file is part of GNU Emacs.
10
eb3fa2cf 11;; GNU Emacs is free software: you can redistribute it and/or modify
b578f267 12;; it under the terms of the GNU General Public License as published by
eb3fa2cf
GM		 13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
b578f267
EN		 15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
eb3fa2cf 22;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
665211a3
KH		 23
24;;; Commentary:
b578f267 25
665211a3
KH		 26;; NAMING: "arc" is short for "archive" and does not refer specifically
27;; to files whose name end in ".arc"
28;;
29;; This code does not decode any files internally, although it does
30;; understand the directory level of the archives. For this reason,
31;; you should expect this code to need more fiddling than tar-mode.el
32;; (although it at present has fewer bugs :-) In particular, I have
33;; not tested this under Ms-Dog myself.
34;; -------------------------------------
35;; INTERACTION: arc-mode.el should play together with
36;;
37;; * ange-ftp.el: Remote archives (i.e., ones that ange-ftp has brought
38;; to you) are handled by doing all updates on a local
39;; copy. When you make changes to a remote file the
40;; changes will first take effect when the archive buffer
41;; is saved. You will be warned about this.
42;;
43;; * dos-fns.el: (Part of Emacs 19). You get automatic ^M^J <--> ^J
44;; conversion.
45;;
46;; arc-mode.el does not work well with crypt++.el; for the archives as
47;; such this could be fixed (but wouldn't be useful) by declaring such
48;; archives to be "remote". For the members this is a general Emacs
49;; problem that 19.29's file formats may fix.
50;; -------------------------------------
51;; ARCHIVE TYPES: Currently only the archives below are handled, but the
52;; structure for handling just about anything is in place.
53;;
b3671a51
JL		 54;; Arc Lzh Zip Zoo Rar 7z
55;; --------------------------------------------
56;; View listing Intern Intern Intern Intern Y Y
57;; Extract member Y Y Y Y Y Y
ac89b32c 58;; Save changed member Y Y Y Y N Y
b3671a51 59;; Add new member N N N N N N
ac89b32c 60;; Delete member Y Y Y Y N Y
b3671a51
JL		 61;; Rename member Y Y N N N N
62;; Chmod - Y Y - N N
63;; Chown - Y - - N N
64;; Chgrp - Y - - N N
665211a3
KH		 65;;
66;; Special thanks to Bill Brodie <wbrodie@panix.com> for very useful tips
67;; on the first released version of this package.
68;;
69;; This code is partly based on tar-mode.el from Emacs.
70;; -------------------------------------
71;; ARCHIVE STRUCTURES:
72;; (This is mostly for myself.)
73;;
74;; ARC A series of (header,file). No interactions among members.
75;;
76;; LZH A series of (header,file). Headers are checksummed. No
77;; interaction among members.
c5e87d10 78;; Headers come in three flavors called level 0, 1 and 2 headers.
5f23d836
RS		 79;; Level 2 header is free of DOS specific restrictions and most
80;; prevalently used. Also level 1 and 2 headers consist of base
81;; and extension headers. For more details see
82;; http://homepage1.nifty.com/dangan/en/Content/Program/Java/jLHA/Notes/Notes.html
83;; http://www.osirusoft.com/joejared/lzhformat.html
665211a3
KH		 84;;
85;; ZIP A series of (lheader,fil) followed by a "central directory"
86;; which is a series of (cheader) followed by an end-of-
87;; central-dir record possibly followed by junk. The e-o-c-d
88;; links to c-d. cheaders link to lheaders which are basically
89;; cut-down versions of the cheaders.
90;;
91;; ZOO An archive header followed by a series of (header,file).
92;; Each member header points to the next. The archive is
93;; terminated by a bogus header with a zero next link.
94;; -------------------------------------
246e8695 95;; HOOKS: `foo' means one of the supported archive types.
665211a3
KH		 96;;
97;; archive-mode-hook
98;; archive-foo-mode-hook
7b1bf173 99;; archive-extract-hook
665211a3
KH		 100
101;;; Code:
102
103;; -------------------------------------------------------------------------
7e9a3fef 104;;; Section: Configuration.
665211a3 105
c38eb0a8
RS		 106(defgroup archive nil
107 "Simple editing of archives."
108 :group 'data)
665211a3 109
c38eb0a8
RS		 110(defgroup archive-arc nil
111 "ARC-specific options to archive."
112 :group 'archive)
113
114(defgroup archive-lzh nil
115 "LZH-specific options to archive."
116 :group 'archive)
117
118(defgroup archive-zip nil
119 "ZIP-specific options to archive."
120 :group 'archive)
121
122(defgroup archive-zoo nil
123 "ZOO-specific options to archive."
124 :group 'archive)
125
c38eb0a8 126(defcustom archive-tmpdir
8053add8
RS		 127 ;; make-temp-name is safe here because we use this name
128 ;; to create a directory.
380683ed
EZ		 129 (make-temp-name
130 (expand-file-name (if (eq system-type 'ms-dos) "ar" "archive.tmp")
0adf5079 131 temporary-file-directory))
0cf1ef26 132 "Directory for temporary files made by `arc-mode.el'."
c38eb0a8
RS		 133 :type 'directory
134 :group 'archive)
665211a3 135
c38eb0a8 136(defcustom archive-remote-regexp "^/[^/:]*[^/:.]:"
9201cc28 137 "Regexp recognizing archive files names that are not local.
eeba65ed 138A non-local file is one whose file name is not proper outside Emacs.
c38eb0a8
RS		 139A local copy of the archive will be used when updating."
140 :type 'regexp
141 :group 'archive)
142
d1069532
SM		 143(define-obsolete-variable-alias 'archive-extract-hooks
144 'archive-extract-hook "24.3")
145(defcustom archive-extract-hook nil
146 "Hook run when an archive member has been extracted."
c38eb0a8
RS		 147 :type 'hook
148 :group 'archive)
665211a3
KH		 149;; ------------------------------
150;; Arc archive configuration
151
152;; We always go via a local file since there seems to be no reliable way
153;; to extract to stdout without junk getting added.
c38eb0a8 154(defcustom archive-arc-extract
665211a3 155 '("arc" "x")
9201cc28 156 "Program and its options to run in order to extract an arc file member.
eeba65ed 157Extraction should happen to the current directory. Archive and member
c38eb0a8
RS		 158name will be added."
159 :type '(list (string :tag "Program")
160 (repeat :tag "Options"
161 :inline t
162 (string :format "%v")))
163 :group 'archive-arc)
164
165(defcustom archive-arc-expunge
665211a3 166 '("arc" "d")
9201cc28 167 "Program and its options to run in order to delete arc file members.
c38eb0a8
RS		 168Archive and member names will be added."
169 :type '(list (string :tag "Program")
170 (repeat :tag "Options"
171 :inline t
172 (string :format "%v")))
173 :group 'archive-arc)
174
175(defcustom archive-arc-write-file-member
665211a3 176 '("arc" "u")
9201cc28 177 "Program and its options to run in order to update an arc file member.
c38eb0a8
RS		 178Archive and member name will be added."
179 :type '(list (string :tag "Program")
180 (repeat :tag "Options"
181 :inline t
182 (string :format "%v")))
183 :group 'archive-arc)
665211a3
KH		 184;; ------------------------------
185;; Lzh archive configuration
186
c38eb0a8 187(defcustom archive-lzh-extract
665211a3 188 '("lha" "pq")
9201cc28 189 "Program and its options to run in order to extract an lzh file member.
eeba65ed 190Extraction should happen to standard output. Archive and member name will
c38eb0a8
RS		 191be added."
192 :type '(list (string :tag "Program")
193 (repeat :tag "Options"
194 :inline t
195 (string :format "%v")))
196 :group 'archive-lzh)
197
198(defcustom archive-lzh-expunge
665211a3 199 '("lha" "d")
9201cc28 200 "Program and its options to run in order to delete lzh file members.
c38eb0a8
RS		 201Archive and member names will be added."
202 :type '(list (string :tag "Program")
203 (repeat :tag "Options"
204 :inline t
205 (string :format "%v")))
206 :group 'archive-lzh)
207
208(defcustom archive-lzh-write-file-member
665211a3 209 '("lha" "a")
9201cc28 210 "Program and its options to run in order to update an lzh file member.
c38eb0a8
RS		 211Archive and member name will be added."
212 :type '(list (string :tag "Program")
213 (repeat :tag "Options"
214 :inline t
215 (string :format "%v")))
216 :group 'archive-lzh)
665211a3
KH		 217;; ------------------------------
218;; Zip archive configuration
219
816244a2
WX		 220(defvar archive-7z-program (let ((7z (or (executable-find "7z")
221 (executable-find "7za"))))
222 (when 7z
223 (file-name-nondirectory 7z))))
224
c38eb0a8 225(defcustom archive-zip-extract
cd79ce90 226 (cond ((executable-find "unzip") '("unzip" "-qq" "-c"))
816244a2 227 (archive-7z-program `(,archive-7z-program "x" "-so"))
b3671a51 228 ((executable-find "pkunzip") '("pkunzip" "-e" "-o-"))
cd79ce90 229 (t '("unzip" "-qq" "-c")))
9201cc28 230 "Program and its options to run in order to extract a zip file member.
eeba65ed 231Extraction should happen to standard output. Archive and member name will
74725d46 232be added."
c38eb0a8 233 :type '(list (string :tag "Program")
b3671a51
JL		 234 (repeat :tag "Options"
235 :inline t
236 (string :format "%v")))
c38eb0a8 237 :group 'archive-zip)
665211a3 238
fffa137c 239;; For several reasons the latter behavior is not desirable in general.
665211a3
KH		 240;; (1) It uses more disk space. (2) Error checking is worse or non-
241;; existent. (3) It tends to do funny things with other systems' file
242;; names.
243
c38eb0a8 244(defcustom archive-zip-expunge
cd79ce90 245 (cond ((executable-find "zip") '("zip" "-d" "-q"))
816244a2 246 (archive-7z-program `(,archive-7z-program "d"))
cd79ce90
JL		 247 ((executable-find "pkzip") '("pkzip" "-d"))
248 (t '("zip" "-d" "-q")))
9201cc28 249 "Program and its options to run in order to delete zip file members.
c38eb0a8
RS		 250Archive and member names will be added."
251 :type '(list (string :tag "Program")
cd79ce90
JL		 252 (repeat :tag "Options"
253 :inline t
254 (string :format "%v")))
c38eb0a8
RS		 255 :group 'archive-zip)
256
257(defcustom archive-zip-update
cd79ce90 258 (cond ((executable-find "zip") '("zip" "-q"))
816244a2 259 (archive-7z-program `(,archive-7z-program "u"))
cd79ce90
JL		 260 ((executable-find "pkzip") '("pkzip" "-u" "-P"))
261 (t '("zip" "-q")))
9201cc28 262 "Program and its options to run in order to update a zip file member.
665211a3 263Options should ensure that specified directory will be put into the zip
c38eb0a8
RS		 264file. Archive and member name will be added."
265 :type '(list (string :tag "Program")
cd79ce90
JL		 266 (repeat :tag "Options"
267 :inline t
268 (string :format "%v")))
c38eb0a8
RS		 269 :group 'archive-zip)
270
271(defcustom archive-zip-update-case
cd79ce90 272 (cond ((executable-find "zip") '("zip" "-q" "-k"))
816244a2 273 (archive-7z-program `(,archive-7z-program "u"))
cd79ce90
JL		 274 ((executable-find "pkzip") '("pkzip" "-u" "-P"))
275 (t '("zip" "-q" "-k")))
9201cc28 276 "Program and its options to run in order to update a case fiddled zip member.
eeba65ed 277Options should ensure that specified directory will be put into the zip file.
c38eb0a8
RS		 278Archive and member name will be added."
279 :type '(list (string :tag "Program")
cd79ce90
JL		 280 (repeat :tag "Options"
281 :inline t
282 (string :format "%v")))
c38eb0a8
RS		 283 :group 'archive-zip)
284
285(defcustom archive-zip-case-fiddle t
9201cc28 286 "If non-nil then zip file members may be down-cased.
380683ed
EZ		 287This case fiddling will only happen for members created by a system
288that uses caseless file names."
c38eb0a8
RS		 289 :type 'boolean
290 :group 'archive-zip)
665211a3
KH		 291;; ------------------------------
292;; Zoo archive configuration
293
c38eb0a8 294(defcustom archive-zoo-extract
665211a3 295 '("zoo" "xpq")
9201cc28 296 "Program and its options to run in order to extract a zoo file member.
eeba65ed 297Extraction should happen to standard output. Archive and member name will
c38eb0a8
RS		 298be added."
299 :type '(list (string :tag "Program")
300 (repeat :tag "Options"
301 :inline t
302 (string :format "%v")))
303 :group 'archive-zoo)
304
305(defcustom archive-zoo-expunge
665211a3 306 '("zoo" "DqPP")
9201cc28 307 "Program and its options to run in order to delete zoo file members.
c38eb0a8
RS		 308Archive and member names will be added."
309 :type '(list (string :tag "Program")
310 (repeat :tag "Options"
311 :inline t
312 (string :format "%v")))
313 :group 'archive-zoo)
314
315(defcustom archive-zoo-write-file-member
665211a3 316 '("zoo" "a")
9201cc28 317 "Program and its options to run in order to update a zoo file member.
c38eb0a8
RS		 318Archive and member name will be added."
319 :type '(list (string :tag "Program")
320 (repeat :tag "Options"
321 :inline t
322 (string :format "%v")))
323 :group 'archive-zoo)
b3671a51
JL		 324;; ------------------------------
325;; 7z archive configuration
326
327(defcustom archive-7z-extract
ff4b7bd5 328 `(,(or archive-7z-program "7z") "x" "-so")
b3671a51
JL		 329 "Program and its options to run in order to extract a 7z file member.
330Extraction should happen to standard output. Archive and member name will
331be added."
2bed3f04 332 :version "24.1"
b3671a51 333 :type '(list (string :tag "Program")
ac89b32c
JL		 334 (repeat :tag "Options"
335 :inline t
336 (string :format "%v")))
337 :group 'archive-7z)
338
339(defcustom archive-7z-expunge
ff4b7bd5 340 `(,(or archive-7z-program "7z") "d")
ac89b32c
JL		 341 "Program and its options to run in order to delete 7z file members.
342Archive and member names will be added."
2bed3f04 343 :version "24.1"
ac89b32c
JL		 344 :type '(list (string :tag "Program")
345 (repeat :tag "Options"
346 :inline t
347 (string :format "%v")))
348 :group 'archive-7z)
349
350(defcustom archive-7z-update
ff4b7bd5 351 `(,(or archive-7z-program "7z") "u")
ac89b32c
JL		 352 "Program and its options to run in order to update a 7z file member.
353Options should ensure that specified directory will be put into the 7z
354file. Archive and member name will be added."
2bed3f04 355 :version "24.1"
ac89b32c
JL		 356 :type '(list (string :tag "Program")
357 (repeat :tag "Options"
358 :inline t
359 (string :format "%v")))
b3671a51
JL		 360 :group 'archive-7z)
361
665211a3 362;; -------------------------------------------------------------------------
7e9a3fef 363;;; Section: Variables
665211a3 364
194600a8
JPW		 365(defvar archive-subtype nil "Symbol describing archive type.")
366(defvar archive-file-list-start nil "Position of first contents line.")
367(defvar archive-file-list-end nil "Position just after last contents line.")
368(defvar archive-proper-file-start nil "Position of real archive's start.")
369(defvar archive-read-only nil "Non-nil if the archive is read-only on disk.")
370(defvar archive-local-name nil "Name of local copy of remote archive.")
941f9778
SM		 371(defvar archive-mode-map
372 (let ((map (make-keymap)))
6f52d86e 373 (set-keymap-parent map special-mode-map)
941f9778
SM		 374 (define-key map " " 'archive-next-line)
375 (define-key map "a" 'archive-alternate-display)
376 ;;(define-key map "c" 'archive-copy)
377 (define-key map "d" 'archive-flag-deleted)
378 (define-key map "\C-d" 'archive-flag-deleted)
379 (define-key map "e" 'archive-extract)
380 (define-key map "f" 'archive-extract)
381 (define-key map "\C-m" 'archive-extract)
941f9778
SM		 382 (define-key map "m" 'archive-mark)
383 (define-key map "n" 'archive-next-line)
384 (define-key map "\C-n" 'archive-next-line)
385 (define-key map [down] 'archive-next-line)
386 (define-key map "o" 'archive-extract-other-window)
387 (define-key map "p" 'archive-previous-line)
941f9778
SM		 388 (define-key map "\C-p" 'archive-previous-line)
389 (define-key map [up] 'archive-previous-line)
390 (define-key map "r" 'archive-rename-entry)
391 (define-key map "u" 'archive-unflag)
392 (define-key map "\M-\C-?" 'archive-unmark-all-files)
393 (define-key map "v" 'archive-view)
394 (define-key map "x" 'archive-expunge)
395 (define-key map "\177" 'archive-unflag-backwards)
396 (define-key map "E" 'archive-extract-other-window)
397 (define-key map "M" 'archive-chmod-entry)
398 (define-key map "G" 'archive-chgrp-entry)
399 (define-key map "O" 'archive-chown-entry)
fb3aad66
SM		 400 ;; Let mouse-1 follow the link.
401 (define-key map [follow-link] 'mouse-face)
941f9778
SM		 402
403 (if (fboundp 'command-remapping)
404 (progn
405 (define-key map [remap advertised-undo] 'archive-undo)
406 (define-key map [remap undo] 'archive-undo))
407 (substitute-key-definition 'advertised-undo 'archive-undo map global-map)
408 (substitute-key-definition 'undo 'archive-undo map global-map))
409
410 (define-key map
fdaaf743 411 (if (featurep 'xemacs) 'button2 [mouse-2]) 'archive-extract)
941f9778
SM		 412
413 (if (featurep 'xemacs)
414 () ; out of luck
415
416 (define-key map [menu-bar immediate]
417 (cons "Immediate" (make-sparse-keymap "Immediate")))
418 (define-key map [menu-bar immediate alternate]
419 '(menu-item "Alternate Display" archive-alternate-display
420 :enable (boundp (archive-name "alternate-display"))
421 :help "Toggle alternate file info display"))
422 (define-key map [menu-bar immediate view]
423 '(menu-item "View This File" archive-view
424 :help "Display file at cursor in View Mode"))
425 (define-key map [menu-bar immediate display]
426 '(menu-item "Display in Other Window" archive-display-other-window
427 :help "Display file at cursor in another window"))
428 (define-key map [menu-bar immediate find-file-other-window]
429 '(menu-item "Find in Other Window" archive-extract-other-window
430 :help "Edit file at cursor in another window"))
431 (define-key map [menu-bar immediate find-file]
432 '(menu-item "Find This File" archive-extract
433 :help "Extract file at cursor and edit it"))
434
435 (define-key map [menu-bar mark]
436 (cons "Mark" (make-sparse-keymap "Mark")))
437 (define-key map [menu-bar mark unmark-all]
438 '(menu-item "Unmark All" archive-unmark-all-files
439 :help "Unmark all marked files"))
440 (define-key map [menu-bar mark deletion]
441 '(menu-item "Flag" archive-flag-deleted
442 :help "Flag file at cursor for deletion"))
443 (define-key map [menu-bar mark unmark]
444 '(menu-item "Unflag" archive-unflag
445 :help "Unmark file at cursor"))
446 (define-key map [menu-bar mark mark]
447 '(menu-item "Mark" archive-mark
448 :help "Mark file at cursor"))
449
450 (define-key map [menu-bar operate]
451 (cons "Operate" (make-sparse-keymap "Operate")))
452 (define-key map [menu-bar operate chown]
453 '(menu-item "Change Owner..." archive-chown-entry
454 :enable (fboundp (archive-name "chown-entry"))
455 :help "Change owner of marked files"))
456 (define-key map [menu-bar operate chgrp]
457 '(menu-item "Change Group..." archive-chgrp-entry
458 :enable (fboundp (archive-name "chgrp-entry"))
459 :help "Change group ownership of marked files"))
460 (define-key map [menu-bar operate chmod]
461 '(menu-item "Change Mode..." archive-chmod-entry
462 :enable (fboundp (archive-name "chmod-entry"))
463 :help "Change mode (permissions) of marked files"))
464 (define-key map [menu-bar operate rename]
465 '(menu-item "Rename to..." archive-rename-entry
466 :enable (fboundp (archive-name "rename-entry"))
467 :help "Rename marked files"))
468 ;;(define-key map [menu-bar operate copy]
469 ;; '(menu-item "Copy to..." archive-copy))
470 (define-key map [menu-bar operate expunge]
471 '(menu-item "Expunge Marked Files" archive-expunge
472 :help "Delete all flagged files from archive"))
473 map))
474 "Local keymap for archive mode listings.")
194600a8
JPW		 475(defvar archive-file-name-indent nil "Column where file names start.")
476
477(defvar archive-remote nil "Non-nil if the archive is outside file system.")
380683ed
EZ		 478(make-variable-buffer-local 'archive-remote)
479(put 'archive-remote 'permanent-local t)
480
481(defvar archive-member-coding-system nil "Coding-system of archive member.")
482(make-variable-buffer-local 'archive-member-coding-system)
483
665211a3 484(defvar archive-alternate-display nil
194600a8 485 "Non-nil when alternate information is shown.")
665211a3
KH		 486(make-variable-buffer-local 'archive-alternate-display)
487(put 'archive-alternate-display 'permanent-local t)
488
194600a8 489(defvar archive-superior-buffer nil "In archive members, points to archive.")
665211a3
KH		 490(put 'archive-superior-buffer 'permanent-local t)
491
194600a8 492(defvar archive-subfile-mode nil "Non-nil in archive member buffers.")
665211a3
KH		 493(make-variable-buffer-local 'archive-subfile-mode)
494(put 'archive-subfile-mode 'permanent-local t)
495
ad38511a
KH		 496(defvar archive-file-name-coding-system nil)
497(make-variable-buffer-local 'archive-file-name-coding-system)
498(put 'archive-file-name-coding-system 'permanent-local t)
499
c4de97b4
RS		 500(defvar archive-files nil
501 "Vector of file descriptors.
502Each descriptor is a vector of the form
503 [EXT-FILE-NAME INT-FILE-NAME CASE-FIDDLED MODE ...]")
665211a3 504(make-variable-buffer-local 'archive-files)
43f657ea 505
665211a3 506;; -------------------------------------------------------------------------
7e9a3fef 507;;; Section: Support functions.
665211a3 508
ad38511a
KH		 509(eval-when-compile
510 (defsubst byte-after (pos)
511 "Like char-after but an eight-bit char is converted to unibyte."
512 (multibyte-char-to-unibyte (char-after pos)))
ad38511a
KH		 513 (defsubst insert-unibyte (&rest args)
514 "Like insert but don't make unibyte string and eight-bit char multibyte."
515 (dolist (elt args)
516 (if (integerp elt)
517 (insert (if (< elt 128) elt (decode-char 'eight-bit elt)))
518 (insert (string-to-multibyte elt)))))
519 )
520
665211a3
KH		 521(defsubst archive-name (suffix)
522 (intern (concat "archive-" (symbol-name archive-subtype) "-" suffix)))
523
a12aece3 524(defun archive-l-e (str &optional len float)
0cf1ef26
JB		 525 "Convert little endian string/vector STR to integer.
526Alternatively, STR may be a buffer position in the current buffer
a12aece3
EZ		 527in which case a second argument, length LEN, should be supplied.
528FLOAT, if non-nil, means generate and return a float instead of an integer
529\(use this for numbers that can overflow the Emacs integer)."
665211a3
KH		 530 (if (stringp str)
531 (setq len (length str))
532 (setq str (buffer-substring str (+ str len))))
8f924df7 533 (setq str (string-as-unibyte str))
665211a3
KH		 534 (let ((result 0)
535 (i 0))
536 (while (< i len)
537 (setq i (1+ i)
a12aece3
EZ		 538 result (+ (if float (* result 256.0) (ash result 8))
539 (aref str (- len i)))))
665211a3
KH		 540 result))
541
542(defun archive-int-to-mode (mode)
ff39b9a1
SM		 543 "Turn an integer like 0700 (i.e., 448) into a mode string like -rwx------."
544 ;; FIXME: merge with tar-grind-file-mode.
545 (string
546 (if (zerop (logand 8192 mode))
547 (if (zerop (logand 16384 mode)) ?- ?d)
548 ?c) ; completeness
549 (if (zerop (logand 256 mode)) ?- ?r)
550 (if (zerop (logand 128 mode)) ?- ?w)
551 (if (zerop (logand 64 mode))
552 (if (zerop (logand 1024 mode)) ?- ?S)
553 (if (zerop (logand 1024 mode)) ?x ?s))
554 (if (zerop (logand 32 mode)) ?- ?r)
555 (if (zerop (logand 16 mode)) ?- ?w)
556 (if (zerop (logand 8 mode))
557 (if (zerop (logand 2048 mode)) ?- ?S)
558 (if (zerop (logand 2048 mode)) ?x ?s))
559 (if (zerop (logand 4 mode)) ?- ?r)
560 (if (zerop (logand 2 mode)) ?- ?w)
561 (if (zerop (logand 1 mode)) ?- ?x)))
665211a3
KH		 562
563(defun archive-calc-mode (oldmode newmode &optional error)
eeba65ed 564 "From the integer OLDMODE and the string NEWMODE calculate a new file mode.
665211a3
KH		 565NEWMODE may be an octal number including a leading zero in which case it
566will become the new mode.\n
567NEWMODE may also be a relative specification like \"og-rwx\" in which case
568OLDMODE will be modified accordingly just like chmod(2) would have done.\n
569If optional third argument ERROR is non-nil an error will be signaled if
570the mode is invalid. If ERROR is nil then nil will be returned."
571 (cond ((string-match "^0[0-7]*$" newmode)
572 (let ((result 0)
573 (len (length newmode))
574 (i 1))
575 (while (< i len)
576 (setq result (+ (lsh result 3) (aref newmode i) (- ?0))
577 i (1+ i)))
578 (logior (logand oldmode 65024) result)))
579 ((string-match "^\\([agou]+\\)\\([---+=]\\)\\([rwxst]+\\)$" newmode)
580 (let ((who 0)
581 (result oldmode)
582 (op (aref newmode (match-beginning 2)))
583 (bits 0)
584 (i (match-beginning 3)))
585 (while (< i (match-end 3))
586 (let ((rwx (aref newmode i)))
587 (setq bits (logior bits (cond ((= rwx ?r) 292)
588 ((= rwx ?w) 146)
589 ((= rwx ?x) 73)
590 ((= rwx ?s) 3072)
591 ((= rwx ?t) 512)))
592 i (1+ i))))
593 (while (< who (match-end 1))
594 (let* ((whoc (aref newmode who))
595 (whomask (cond ((= whoc ?a) 4095)
596 ((= whoc ?u) 1472)
597 ((= whoc ?g) 2104)
598 ((= whoc ?o) 7))))
599 (if (= op ?=)
600 (setq result (logand result (lognot whomask))))
601 (if (= op ?-)
602 (setq result (logand result (lognot (logand whomask bits))))
603 (setq result (logior result (logand whomask bits)))))
604 (setq who (1+ who)))
605 result))
606 (t
607 (if error
608 (error "Invalid mode specification: %s" newmode)))))
609
610(defun archive-dosdate (date)
611 "Stringify dos packed DATE record."
612 (let ((year (+ 1980 (logand (ash date -9) 127)))
613 (month (logand (ash date -5) 15))
614 (day (logand date 31)))
615 (if (or (> month 12) (< month 1))
616 ""
617 (format "%2d-%s-%d"
618 day
619 (aref ["Jan" "Feb" "Mar" "Apr" "May" "Jun"
620 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"] (1- month))
621 year))))
622
623(defun archive-dostime (time)
624 "Stringify dos packed TIME record."
625 (let ((hour (logand (ash time -11) 31))
70569550 626 (minute (logand (ash time -5) 63))
665211a3
KH		 627 (second (* 2 (logand time 31)))) ; 2 seconds resolution
628 (format "%02d:%02d:%02d" hour minute second)))
629
5f23d836 630(defun archive-unixdate (low high)
0cf1ef26 631 "Stringify Unix (LOW HIGH) date."
0bfcf5c5
PE		 632 (let* ((time (cons high low))
633 (str (current-time-string time)))
5f23d836
RS		 634 (format "%s-%s-%s"
635 (substring str 8 10)
636 (substring str 4 7)
0bfcf5c5 637 (format-time-string "%Y" time))))
665211a3 638
5f23d836 639(defun archive-unixtime (low high)
0cf1ef26 640 "Stringify Unix (LOW HIGH) time."
5f23d836
RS		 641 (let ((str (current-time-string (cons high low))))
642 (substring str 11 19)))
665211a3
KH		 643
644(defun archive-get-lineno ()
645 (if (>= (point) archive-file-list-start)
646 (count-lines archive-file-list-start
5ed619e0 647 (line-beginning-position))
665211a3
KH		 648 0))
649
650(defun archive-get-descr (&optional noerror)
eeba65ed 651 "Return the descriptor vector for file at point.
0cf1ef26 652Does not signal an error if optional argument NOERROR is non-nil."
665211a3
KH		 653 (let ((no (archive-get-lineno)))
654 (if (and (>= (point) archive-file-list-start)
655 (< no (length archive-files)))
656 (let ((item (aref archive-files no)))
657 (if (vectorp item)
658 item
659 (if (not noerror)
660 (error "Entry is not a regular member of the archive"))))
661 (if (not noerror)
662 (error "Line does not describe a member of the archive")))))
663;; -------------------------------------------------------------------------
7e9a3fef 664;;; Section: the mode definition
665211a3 665
9199a670 666;;;###autoload
665211a3 667(defun archive-mode (&optional force)
eeba65ed
RS		 668 "Major mode for viewing an archive file in a dired-like way.
669You can move around using the usual cursor motion commands.
665211a3
KH		 670Letters no longer insert themselves.
671Type `e' to pull a file out of the archive and into its own buffer;
672or click mouse-2 on the file's line in the archive mode buffer.
673
674If you edit a sub-file of this archive (as with the `e' command) and
675save it, the contents of that buffer will be saved back into the
676archive.
677
678\\{archive-mode-map}"
679 ;; This is not interactive because you shouldn't be turning this
680 ;; mode on and off. You can corrupt things that way.
681 (if (zerop (buffer-size))
682 ;; At present we cannot create archives from scratch
1e8eecea 683 (funcall (or (default-value 'major-mode) 'fundamental-mode))
665211a3 684 (if (and (not force) archive-files) nil
1b3b87df 685 (kill-all-local-variables)
665211a3 686 (let* ((type (archive-find-type))
ff39b9a1 687 (typename (capitalize (symbol-name type))))
665211a3
KH		 688 (make-local-variable 'archive-subtype)
689 (setq archive-subtype type)
690
691 ;; Buffer contains treated image of file before the file contents
692 (make-local-variable 'revert-buffer-function)
693 (setq revert-buffer-function 'archive-mode-revert)
694 (auto-save-mode 0)
665211a3 695
4a172eab 696 (add-hook 'write-contents-functions 'archive-write-file nil t)
380683ed 697
665211a3
KH		 698 (make-local-variable 'require-final-newline)
699 (setq require-final-newline nil)
28138f8c
RS		 700 (make-local-variable 'local-enable-local-variables)
701 (setq local-enable-local-variables nil)
665211a3 702
938c6472
RS		 703 ;; Prevent loss of data when saving the file.
704 (make-local-variable 'file-precious-flag)
705 (setq file-precious-flag t)
706
665211a3 707 (make-local-variable 'archive-read-only)
380683ed
EZ		 708 ;; Archives which are inside other archives and whose
709 ;; names are invalid for this OS, can't be written.
710 (setq archive-read-only
711 (or (not (file-writable-p (buffer-file-name)))
712 (and archive-subfile-mode
4dbbd6a1 713 (string-match file-name-invalid-regexp
380683ed 714 (aref archive-subfile-mode 0)))))
665211a3
KH		 715
716 ;; Should we use a local copy when accessing from outside Emacs?
717 (make-local-variable 'archive-local-name)
380683ed
EZ		 718
719 ;; An archive can contain another archive whose name is invalid
720 ;; on local filesystem. Treat such archives as remote.
721 (or archive-remote
722 (setq archive-remote
723 (or (string-match archive-remote-regexp (buffer-file-name))
4dbbd6a1 724 (string-match file-name-invalid-regexp
380683ed 725 (buffer-file-name)))))
665211a3
KH		 726
727 (setq major-mode 'archive-mode)
728 (setq mode-name (concat typename "-Archive"))
729 ;; Run archive-foo-mode-hook and archive-mode-hook
21a88c56 730 (run-mode-hooks (archive-name "mode-hook") 'archive-mode-hook)
665211a3
KH		 731 (use-local-map archive-mode-map))
732
733 (make-local-variable 'archive-proper-file-start)
734 (make-local-variable 'archive-file-list-start)
735 (make-local-variable 'archive-file-list-end)
736 (make-local-variable 'archive-file-name-indent)
ad38511a
KH		 737 (setq archive-file-name-coding-system
738 (or file-name-coding-system
739 default-file-name-coding-system
740 locale-coding-system))
597e2240 741 (if (default-value 'enable-multibyte-characters)
8f924df7 742 (set-buffer-multibyte 'to))
380683ed 743 (archive-summarize nil)
665211a3
KH		 744 (setq buffer-read-only t))))
745
746;; Archive mode is suitable only for specially formatted data.
747(put 'archive-mode 'mode-class 'special)
665211a3 748
941f9778 749(let ((item1 '(archive-subfile-mode " Archive")))
665211a3 750 (or (member item1 minor-mode-alist)
941f9778 751 (setq minor-mode-alist (cons item1 minor-mode-alist))))
665211a3
KH		 752;; -------------------------------------------------------------------------
753(defun archive-find-type ()
754 (widen)
755 (goto-char (point-min))
756 ;; The funny [] here make it unlikely that the .elc file will be treated
757 ;; as an archive by other software.
758 (let (case-fold-search)
eb1727a4 759 (cond ((looking-at "\\(PK00\\)?[P]K\003\004") 'zip)
a56636ae 760 ((looking-at "..-l[hz][0-9ds]-") 'lzh)
665211a3
KH		 761 ((looking-at "....................[\334]\247\304\375") 'zoo)
762 ((and (looking-at "\C-z") ; signature too simple, IMHO
1b3b87df 763 (string-match "\\.[aA][rR][cC]\\'"
665211a3
KH		 764 (or buffer-file-name (buffer-name))))
765 'arc)
5618fbd2 766 ;; This pattern modeled on the BSD/GNU+Linux `file' command.
fcb006c4
CY		 767 ;; Have seen capital "LHA's", and file has lower case "LHa's" too.
768 ;; Note this regexp is also in archive-exe-p.
769 ((looking-at "MZ\\(.\\|\n\\)\\{34\\}LH[aA]'s SFX ") 'lzh-exe)
7e9a3fef 770 ((looking-at "Rar!") 'rar)
239bf18b 771 ((looking-at "!<arch>\n") 'ar)
c9db111a
SM		 772 ((and (looking-at "MZ")
773 (re-search-forward "Rar!" (+ (point) 100000) t))
774 'rar-exe)
b3671a51 775 ((looking-at "7z\274\257\047\034") '7z)
1cd7adc6 776 (t (error "Buffer format not recognized")))))
665211a3 777;; -------------------------------------------------------------------------
7e9a3fef
SM		 778
779(defun archive-desummarize ()
780 (let ((inhibit-read-only t)
781 (modified (buffer-modified-p)))
782 (widen)
783 (delete-region (point-min) archive-proper-file-start)
784 (restore-buffer-modified-p modified)))
785
786
380683ed 787(defun archive-summarize (&optional shut-up)
665211a3
KH		 788 "Parse the contents of the archive file in the current buffer.
789Place a dired-like listing on the front;
790then narrow to it, so that only that listing
380683ed
EZ		 791is visible (and the real data of the buffer is hidden).
792Optional argument SHUT-UP, if non-nil, means don't print messages
793when parsing the archive."
665211a3 794 (widen)
4c478e6b
JL		 795 (let ((buffer-file-truename nil) ; avoid changing dir mtime by lock_file
796 (inhibit-read-only t))
7e9a3fef
SM		 797 (setq archive-proper-file-start (copy-marker (point-min) t))
798 (set (make-local-variable 'change-major-mode-hook) 'archive-desummarize)
380683ed
EZ		 799 (or shut-up
800 (message "Parsing archive file..."))
665211a3
KH		 801 (buffer-disable-undo (current-buffer))
802 (setq archive-files (funcall (archive-name "summarize")))
380683ed
EZ		 803 (or shut-up
804 (message "Parsing archive file...done."))
665211a3
KH		 805 (setq archive-proper-file-start (point-marker))
806 (narrow-to-region (point-min) (point))
807 (set-buffer-modified-p nil)
808 (buffer-enable-undo))
809 (goto-char archive-file-list-start)
810 (archive-next-line 0))
811
812(defun archive-resummarize ()
813 "Recreate the contents listing of an archive."
7e9a3fef
SM		 814 (let ((no (archive-get-lineno)))
815 (archive-desummarize)
380683ed 816 (archive-summarize t)
665211a3
KH		 817 (goto-char archive-file-list-start)
818 (archive-next-line no)))
819
820(defun archive-summarize-files (files)
c4de97b4 821 "Insert a description of a list of files annotated with proper mouse face."
665211a3
KH		 822 (setq archive-file-list-start (point-marker))
823 (setq archive-file-name-indent (if files (aref (car files) 1) 0))
824 ;; We don't want to do an insert for each element since that takes too
825 ;; long when the archive -- which has to be moved in memory -- is large.
826 (insert
827 (apply
828 (function concat)
829 (mapcar
fdaaf743
SM		 830 (lambda (fil)
831 ;; Using `concat' here copies the text also, so we can add
832 ;; properties without problems.
833 (let ((text (concat (aref fil 0) "\n")))
834 (if (featurep 'xemacs)
835 () ; out of luck
836 (add-text-properties
837 (aref fil 1) (aref fil 2)
838 '(mouse-face highlight
839 help-echo "mouse-2: extract this file into a buffer")
840 text))
841 text))
665211a3
KH		 842 files)))
843 (setq archive-file-list-end (point-marker)))
844
845(defun archive-alternate-display ()
eeba65ed 846 "Toggle alternative display.
0cf1ef26 847To avoid very long lines archive mode does not show all information.
eeba65ed 848This function changes the set of information shown for each files."
665211a3
KH		 849 (interactive)
850 (setq archive-alternate-display (not archive-alternate-display))
851 (archive-resummarize))
852;; -------------------------------------------------------------------------
7e9a3fef 853;;; Section: Local archive copy handling
665211a3 854
380683ed
EZ		 855(defun archive-unique-fname (fname dir)
856 "Make sure a file FNAME can be created uniquely in directory DIR.
857
858If FNAME can be uniquely created in DIR, it is returned unaltered.
859If FNAME is something our underlying filesystem can't grok, or if another
860file by that name already exists in DIR, a unique new name is generated
ff39b9a1 861using `make-temp-file', and the generated name is returned."
380683ed 862 (let ((fullname (expand-file-name fname dir))
f5fce4ec
MA		 863 (alien (string-match file-name-invalid-regexp fname))
864 (tmpfile
380683ed 865 (expand-file-name
9dacec4c
KS		 866 (if (if (fboundp 'msdos-long-file-names)
867 (not (msdos-long-file-names)))
380683ed
EZ		 868 "am"
869 "arc-mode.")
f5fce4ec
MA		 870 dir)))
871 (if (or alien (file-exists-p fullname))
872 (progn
bbd240ce 873 ;; Make sure all the leading directories in
f5fce4ec
MA		 874 ;; archive-local-name exist under archive-tmpdir, so that
875 ;; the directory structure recorded in the archive is
876 ;; reconstructed in the temporary directory.
877 (make-directory (file-name-directory tmpfile) t)
878 (make-temp-file tmpfile))
bbd240ce 879 ;; Make sure all the leading directories in `fullname' exist
f5952338
JL		 880 ;; under archive-tmpdir. This is necessary for nested archives
881 ;; (`archive-extract' sets `archive-remote' to t in case
882 ;; an archive occurs inside another archive).
883 (make-directory (file-name-directory fullname) t)
380683ed
EZ		 884 fullname)))
885
665211a3 886(defun archive-maybe-copy (archive)
380683ed
EZ		 887 (let ((coding-system-for-write 'no-conversion))
888 (if archive-remote
889 (let ((start (point-max))
890 ;; Sometimes ARCHIVE is invalid while its actual name, as
891 ;; recorded in its parent archive, is not. For example, an
892 ;; archive bar.zip inside another archive foo.zip gets a name
893 ;; "foo.zip:bar.zip", which is invalid on DOS/Windows.
894 ;; So use the actual name if available.
895 (archive-name
896 (or (and archive-subfile-mode (aref archive-subfile-mode 0))
897 archive)))
380683ed
EZ		 898 (setq archive-local-name
899 (archive-unique-fname archive-name archive-tmpdir))
900 (save-restriction
901 (widen)
902 (write-region start (point-max) archive-local-name nil 'nomessage))
903 archive-local-name)
904 (if (buffer-modified-p) (save-buffer))
905 archive)))
665211a3
KH		 906
907(defun archive-maybe-update (unchanged)
908 (if archive-remote
909 (let ((name archive-local-name)
910 (modified (buffer-modified-p))
380683ed
EZ		 911 (coding-system-for-read 'no-conversion)
912 (lno (archive-get-lineno))
e545bb99 913 (inhibit-read-only t))
665211a3 914 (if unchanged nil
380683ed 915 (setq archive-files nil)
665211a3
KH		 916 (erase-buffer)
917 (insert-file-contents name)
380683ed
EZ		 918 (archive-mode t)
919 (goto-char archive-file-list-start)
920 (archive-next-line lno))
665211a3
KH		 921 (archive-delete-local name)
922 (if (not unchanged)
380683ed
EZ		 923 (message
924 "Buffer `%s' must be saved for changes to take effect"
925 (buffer-name (current-buffer))))
665211a3
KH		 926 (set-buffer-modified-p (or modified (not unchanged))))))
927
928(defun archive-delete-local (name)
eeba65ed 929 "Delete file NAME and its parents up to and including `archive-tmpdir'."
665211a3
KH		 930 (let ((again t)
931 (top (directory-file-name (file-name-as-directory archive-tmpdir))))
932 (condition-case nil
933 (delete-file name)
934 (error nil))
935 (while again
936 (setq name (directory-file-name (file-name-directory name)))
937 (condition-case nil
938 (delete-directory name)
939 (error nil))
940 (if (string= name top) (setq again nil)))))
941;; -------------------------------------------------------------------------
7e9a3fef 942;;; Section: Member extraction
665211a3 943
fb3aad66
SM		 944(defun archive-try-jka-compr ()
945 (when (and auto-compression-mode
946 (jka-compr-get-compression-info buffer-file-name))
947 (let* ((basename (file-name-nondirectory buffer-file-name))
948 (tmpname (if (string-match ":\\([^:]+\\)\\'" basename)
949 (match-string 1 basename) basename))
950 (tmpfile (make-temp-file (file-name-sans-extension tmpname)
951 nil
952 (file-name-extension tmpname 'period))))
953 (unwind-protect
954 (progn
955 (let ((coding-system-for-write 'no-conversion)
956 ;; Don't re-compress this data just before decompressing it.
957 (jka-compr-inhibit t))
958 (write-region (point-min) (point-max) tmpfile nil 'quiet))
959 (erase-buffer)
960 (let ((coding-system-for-read 'no-conversion))
961 (insert-file-contents tmpfile)))
962 (delete-file tmpfile)))))
963
eb93d233
EZ		 964(defun archive-file-name-handler (op &rest args)
965 (or (eq op 'file-exists-p)
966 (let ((file-name-handler-alist nil))
967 (apply op args))))
968
969(defun archive-set-buffer-as-visiting-file (filename)
970 "Set the current buffer as if it were visiting FILENAME."
971 (save-excursion
972 (goto-char (point-min))
ab3050bc
JL		 973 (let ((buffer-undo-list t)
974 (coding
eb93d233
EZ		 975 (or coding-system-for-read
976 (and set-auto-coding-function
06e3b626
EZ		 977 (save-excursion
978 (funcall set-auto-coding-function
979 filename (- (point-max) (point-min)))))
e9fe3513
EZ		 980 ;; The following let-binding of file-name-handler-alist forces
981 ;; find-file-not-found-set-buffer-file-coding-system to ignore
982 ;; the file's name (see dos-w32.el).
eb93d233
EZ		 983 (let ((file-name-handler-alist
984 '(("" . archive-file-name-handler))))
e0b582b8
KH		 985 (car (find-operation-coding-system
986 'insert-file-contents
987 (cons filename (current-buffer)) t))))))
fb3aad66
SM		 988 (unless (or coding-system-for-read
989 enable-multibyte-characters)
990 (setq coding
991 (coding-system-change-text-conversion coding 'raw-text)))
992 (unless (memq coding '(nil no-conversion))
993 (decode-coding-region (point-min) (point-max) coding)
eb93d233
EZ		 994 (setq last-coding-system-used coding))
995 (set-buffer-modified-p nil)
996 (kill-local-variable 'buffer-file-coding-system)
a38ac4c2 997 (after-insert-file-set-coding (- (point-max) (point-min))))))
eb93d233 998
fdaaf743 999(define-obsolete-function-alias 'archive-mouse-extract 'archive-extract "22.1")
665211a3 1000
fdaaf743 1001(defun archive-extract (&optional other-window-p event)
665211a3 1002 "In archive mode, extract this entry of the archive into its own buffer."
fdaaf743 1003 (interactive (list nil last-input-event))
440e20fc 1004 (if event (posn-set-point (event-end event)))
665211a3
KH		 1005 (let* ((view-p (eq other-window-p 'view))
1006 (descr (archive-get-descr))
1007 (ename (aref descr 0))
1008 (iname (aref descr 1))
1009 (archive-buffer (current-buffer))
1010 (arcdir default-directory)
1011 (archive (buffer-file-name))
1012 (arcname (file-name-nondirectory archive))
1013 (bufname (concat (file-name-nondirectory iname) " (" arcname ")"))
1014 (extractor (archive-name "extract"))
380683ed
EZ		 1015 ;; Members with file names which aren't valid for the
1016 ;; underlying filesystem, are treated as read-only.
1017 (read-only-p (or archive-read-only
1018 view-p
4dbbd6a1 1019 (string-match file-name-invalid-regexp ename)))
9b1fad33 1020 (arcfilename (expand-file-name (concat arcname ":" iname)))
665211a3 1021 (buffer (get-buffer bufname))
ad38511a
KH		 1022 (just-created nil)
1023 (file-name-coding archive-file-name-coding-system))
9b1fad33
CY		 1024 (if (and buffer
1025 (string= (buffer-file-name buffer) arcfilename))
665211a3
KH		 1026 nil
1027 (setq archive (archive-maybe-copy archive))
9b1fad33 1028 (setq bufname (generate-new-buffer-name bufname))
665211a3
KH		 1029 (setq buffer (get-buffer-create bufname))
1030 (setq just-created t)
e545bb99 1031 (with-current-buffer buffer
9b1fad33 1032 (setq buffer-file-name arcfilename)
665211a3
KH		 1033 (setq buffer-file-truename
1034 (abbreviate-file-name buffer-file-name))
1035 ;; Set the default-directory to the dir of the superior buffer.
1036 (setq default-directory arcdir)
1037 (make-local-variable 'archive-superior-buffer)
1038 (setq archive-superior-buffer archive-buffer)
fdaaf743 1039 (add-hook 'write-file-functions 'archive-write-file-member nil t)
665211a3 1040 (setq archive-subfile-mode descr)
ad38511a 1041 (setq archive-file-name-coding-system file-name-coding)
b48fa570
EZ		 1042 (if (and
1043 (null
91af3942 1044 (let (;; We may have to encode the file name argument for
eb93d233 1045 ;; external programs.
7e5ad777
KH		 1046 (coding-system-for-write
1047 (and enable-multibyte-characters
ad38511a 1048 archive-file-name-coding-system))
eb93d233
EZ		 1049 ;; We read an archive member by no-conversion at
1050 ;; first, then decode appropriately by calling
1051 ;; archive-set-buffer-as-visiting-file later.
1052 (coding-system-for-read 'no-conversion))
1053 (condition-case err
1054 (if (fboundp extractor)
1055 (funcall extractor archive ename)
1056 (archive-*-extract archive ename
1057 (symbol-value extractor)))
1058 (error
1059 (ding (message "%s" (error-message-string err)))
1060 nil))))
b48fa570
EZ		 1061 just-created)
1062 (progn
1063 (set-buffer-modified-p nil)
1064 (kill-buffer buffer))
fb3aad66 1065 (archive-try-jka-compr) ;Pretty ugly hack :-(
eb93d233 1066 (archive-set-buffer-as-visiting-file ename)
b48fa570
EZ		 1067 (goto-char (point-min))
1068 (rename-buffer bufname)
1069 (setq buffer-read-only read-only-p)
1070 (setq buffer-undo-list nil)
1071 (set-buffer-modified-p nil)
1072 (setq buffer-saved-size (buffer-size))
1073 (normal-mode)
1074 ;; Just in case an archive occurs inside another archive.
fdaaf743
SM		 1075 (when (derived-mode-p 'archive-mode)
1076 (setq archive-remote t)
1077 (if read-only-p (setq archive-read-only t))
1078 ;; We will write out the archive ourselves if it is
1079 ;; part of another archive.
1080 (remove-hook 'write-contents-functions 'archive-write-file t))
d1069532 1081 (run-hooks 'archive-extract-hook)
380683ed
EZ		 1082 (if archive-read-only
1083 (message "Note: altering this archive is not implemented."))))
1084 (archive-maybe-update t))
b48fa570 1085 (or (not (buffer-name buffer))
fdaaf743 1086 (cond
fd5c9dfa
JL		 1087 (view-p
1088 (view-buffer buffer (and just-created 'kill-buffer-if-not-modified)))
fdaaf743
SM		 1089 ((eq other-window-p 'display) (display-buffer buffer))
1090 (other-window-p (switch-to-buffer-other-window buffer))
c3313451 1091 (t (switch-to-buffer buffer))))))
665211a3
KH		 1092
1093(defun archive-*-extract (archive name command)
1094 (let* ((default-directory (file-name-as-directory archive-tmpdir))
1095 (tmpfile (expand-file-name (file-name-nondirectory name)
b48fa570
EZ		 1096 default-directory))
1097 exit-status success)
665211a3 1098 (make-directory (directory-file-name default-directory) t)
b48fa570
EZ		 1099 (setq exit-status
1100 (apply 'call-process
1101 (car command)
1102 nil
1103 nil
1104 nil
1105 (append (cdr command) (list archive name))))
3516a018 1106 (cond ((and (numberp exit-status) (zerop exit-status))
b48fa570
EZ		 1107 (if (not (file-exists-p tmpfile))
1108 (ding (message "`%s': no such file or directory" tmpfile))
1109 (insert-file-contents tmpfile)
1110 (setq success t)))
1111 ((numberp exit-status)
1112 (ding
1113 (message "`%s' exited with status %d" (car command) exit-status)))
1114 ((stringp exit-status)
1115 (ding (message "`%s' aborted: %s" (car command) exit-status)))
1116 (t
1117 (ding (message "`%s' failed" (car command)))))
1118 (archive-delete-local tmpfile)
1119 success))
665211a3 1120
53baf48a
JL		 1121(defun archive-extract-by-stdout (archive name command &optional stderr-test)
1122 (let ((stderr-file (make-temp-file "arc-stderr")))
1123 (unwind-protect
1124 (prog1
1125 (apply 'call-process
1126 (car command)
1127 nil
1128 (if stderr-file (list t stderr-file) t)
1129 nil
1130 (append (cdr command) (list archive name)))
1131 (with-temp-buffer
1132 (insert-file-contents stderr-file)
1133 (goto-char (point-min))
1134 (when (if (stringp stderr-test)
1135 (not (re-search-forward stderr-test nil t))
1136 (> (buffer-size) 0))
1137 (message "%s" (buffer-string)))))
1138 (if (file-exists-p stderr-file)
1139 (delete-file stderr-file)))))
1140
1141(defun archive-extract-by-file (archive name command &optional stdout-test)
1142 (let ((dest (make-temp-file "arc-dir" 'dir))
1143 (stdout-file (make-temp-file "arc-stdout")))
1144 (unwind-protect
1145 (prog1
1146 (apply 'call-process
1147 (car command)
1148 nil
1149 `(:file ,stdout-file)
1150 nil
1151 (append (cdr command) (list archive name dest)))
1152 (with-temp-buffer
1153 (insert-file-contents stdout-file)
1154 (goto-char (point-min))
1155 (when (if (stringp stdout-test)
1156 (not (re-search-forward stdout-test nil t))
1157 (> (buffer-size) 0))
1158 (message "%s" (buffer-string))))
1159 (if (file-exists-p (expand-file-name name dest))
1160 (insert-file-contents-literally (expand-file-name name dest))))
1161 (if (file-exists-p stdout-file)
1162 (delete-file stdout-file))
1163 (if (file-exists-p (expand-file-name name dest))
1164 (delete-file (expand-file-name name dest)))
1165 (while (file-name-directory name)
1166 (setq name (directory-file-name (file-name-directory name)))
1167 (delete-directory (expand-file-name name dest)))
1168 (delete-directory dest))))
665211a3
KH		 1169
1170(defun archive-extract-other-window ()
1171 "In archive mode, find this member in another window."
1172 (interactive)
1173 (archive-extract t))
1174
1175(defun archive-display-other-window ()
1176 "In archive mode, display this member in another window."
1177 (interactive)
1178 (archive-extract 'display))
1179
1180(defun archive-view ()
1181 "In archive mode, view the member on this line."
1182 (interactive)
1183 (archive-extract 'view))
1184
1185(defun archive-add-new-member (arcbuf name)
eeba65ed 1186 "Add current buffer to the archive in ARCBUF naming it NAME."
665211a3
KH		 1187 (interactive
1188 (list (get-buffer
1189 (read-buffer "Buffer containing archive: "
1190 ;; Find first archive buffer and suggest that
1191 (let ((bufs (buffer-list)))
e545bb99
SM		 1192 (while (and bufs
1193 (not (with-current-buffer (car bufs)
1194 (derived-mode-p 'archive-mode))))
1195 (setq bufs (cdr bufs)))
665211a3
KH		 1196 (if bufs
1197 (car bufs)
1198 (error "There are no archive buffers")))
1199 t))
1200 (read-string "File name in archive: "
1201 (if buffer-file-name
1202 (file-name-nondirectory buffer-file-name)
1203 ""))))
e545bb99 1204 (with-current-buffer arcbuf
3516a018 1205 (or (derived-mode-p 'archive-mode)
665211a3
KH		 1206 (error "Buffer is not an archive buffer"))
1207 (if archive-read-only
1208 (error "Archive is read-only")))
1209 (if (eq arcbuf (current-buffer))
1210 (error "An archive buffer cannot be added to itself"))
1211 (if (string= name "")
1212 (error "Archive members may not be given empty names"))
e545bb99
SM		 1213 (let ((func (with-current-buffer arcbuf
1214 (archive-name "add-new-member")))
665211a3
KH		 1215 (membuf (current-buffer)))
1216 (if (fboundp func)
e545bb99 1217 (with-current-buffer arcbuf
665211a3
KH		 1218 (funcall func buffer-file-name membuf name))
1219 (error "Adding a new member is not supported for this archive type"))))
1220;; -------------------------------------------------------------------------
7e9a3fef 1221;;; Section: IO stuff
665211a3 1222
665211a3 1223(defun archive-write-file-member ()
b48fa570
EZ		 1224 (save-excursion
1225 (save-restriction
1226 (message "Updating archive...")
1227 (widen)
e545bb99
SM		 1228 (let ((writer (with-current-buffer archive-superior-buffer
1229 (archive-name "write-file-member")))
1230 (archive (with-current-buffer archive-superior-buffer
1231 (archive-maybe-copy (buffer-file-name)))))
b48fa570
EZ		 1232 (if (fboundp writer)
1233 (funcall writer archive archive-subfile-mode)
1234 (archive-*-write-file-member archive
1235 archive-subfile-mode
380683ed
EZ		 1236 (symbol-value writer)))
1237 (set-buffer-modified-p nil)
1238 (message "Updating archive...done"))
b48fa570 1239 (set-buffer archive-superior-buffer)
380683ed
EZ		 1240 (if (not archive-remote) (revert-buffer) (archive-maybe-update nil))))
1241 ;; Restore the value of last-coding-system-used, so that basic-save-buffer
1242 ;; won't reset the coding-system of this archive member.
1243 (if (local-variable-p 'archive-member-coding-system)
1244 (setq last-coding-system-used archive-member-coding-system))
1245 t)
665211a3
KH		 1246
1247(defun archive-*-write-file-member (archive descr command)
1248 (let* ((ename (aref descr 0))
1249 (tmpfile (expand-file-name ename archive-tmpdir))
1250 (top (directory-file-name (file-name-as-directory archive-tmpdir)))
1251 (default-directory (file-name-as-directory top)))
1252 (unwind-protect
1253 (progn
1254 (make-directory (file-name-directory tmpfile) t)
380683ed
EZ		 1255 ;; If the member is itself an archive, write it without
1256 ;; the dired-like listing we created.
1257 (if (eq major-mode 'archive-mode)
1258 (archive-write-file tmpfile)
ab1d3835 1259 (write-region nil nil tmpfile nil 'nomessage))
380683ed
EZ		 1260 ;; basic-save-buffer needs last-coding-system-used to have
1261 ;; the value used to write the file, so save it before any
1262 ;; further processing clobbers it (we restore it in
1263 ;; archive-write-file-member, above).
1264 (setq archive-member-coding-system last-coding-system-used)
665211a3
KH		 1265 (if (aref descr 3)
1266 ;; Set the file modes, but make sure we can read it.
1267 (set-file-modes tmpfile (logior ?\400 (aref descr 3))))
ad38511a
KH		 1268 (setq ename
1269 (encode-coding-string ename archive-file-name-coding-system))
1270 (let* ((coding-system-for-write 'no-conversion)
1271 (exitcode (apply 'call-process
1272 (car command)
1273 nil
1274 nil
1275 nil
1276 (append (cdr command)
1277 (list archive ename)))))
3516a018
JPW		 1278 (or (zerop exitcode)
1279 (error "Updating was unsuccessful (%S)" exitcode))))
665211a3
KH		 1280 (archive-delete-local tmpfile))))
1281
380683ed 1282(defun archive-write-file (&optional file)
665211a3 1283 (save-excursion
380683ed
EZ		 1284 (let ((coding-system-for-write 'no-conversion))
1285 (write-region archive-proper-file-start (point-max)
1286 (or file buffer-file-name) nil t)
1287 (set-buffer-modified-p nil))
665211a3
KH		 1288 t))
1289;; -------------------------------------------------------------------------
7e9a3fef 1290;;; Section: Marking and unmarking.
665211a3
KH		 1291
1292(defun archive-flag-deleted (p &optional type)
1293 "In archive mode, mark this member to be deleted from the archive.
1294With a prefix argument, mark that many files."
1295 (interactive "p")
1296 (or type (setq type ?D))
1297 (beginning-of-line)
1298 (let ((sign (if (>= p 0) +1 -1))
1299 (modified (buffer-modified-p))
e545bb99 1300 (inhibit-read-only t))
665211a3
KH		 1301 (while (not (zerop p))
1302 (if (archive-get-descr t)
1303 (progn
1304 (delete-char 1)
1305 (insert type)))
1306 (forward-line sign)
1307 (setq p (- p sign)))
e545bb99 1308 (restore-buffer-modified-p modified))
665211a3
KH		 1309 (archive-next-line 0))
1310
1311(defun archive-unflag (p)
1312 "In archive mode, un-mark this member if it is marked to be deleted.
1313With a prefix argument, un-mark that many files forward."
1314 (interactive "p")
0cf1ef26 1315 (archive-flag-deleted p ?\s))
665211a3
KH		 1316
1317(defun archive-unflag-backwards (p)
1318 "In archive mode, un-mark this member if it is marked to be deleted.
1319With a prefix argument, un-mark that many members backward."
1320 (interactive "p")
0cf1ef26 1321 (archive-flag-deleted (- p) ?\s))
665211a3
KH		 1322
1323(defun archive-unmark-all-files ()
1324 "Remove all marks."
1325 (interactive)
1326 (let ((modified (buffer-modified-p))
e545bb99 1327 (inhibit-read-only t))
665211a3
KH		 1328 (save-excursion
1329 (goto-char archive-file-list-start)
1330 (while (< (point) archive-file-list-end)
0cf1ef26
JB		 1331 (or (= (following-char) ?\s)
1332 (progn (delete-char 1) (insert ?\s)))
665211a3 1333 (forward-line 1)))
e545bb99 1334 (restore-buffer-modified-p modified)))
665211a3
KH		 1335
1336(defun archive-mark (p)
1337 "In archive mode, mark this member for group operations.
1338With a prefix argument, mark that many members.
1339Use \\[archive-unmark-all-files] to remove all marks."
1340 (interactive "p")
1341 (archive-flag-deleted p ?*))
1342
1343(defun archive-get-marked (mark &optional default)
1344 (let (files)
1345 (save-excursion
1346 (goto-char archive-file-list-start)
1347 (while (< (point) archive-file-list-end)
1348 (if (= (following-char) mark)
1349 (setq files (cons (archive-get-descr) files)))
1350 (forward-line 1)))
1351 (or (nreverse files)
1352 (and default
1353 (list (archive-get-descr))))))
1354;; -------------------------------------------------------------------------
7e9a3fef 1355;;; Section: Operate
665211a3
KH		 1356
1357(defun archive-next-line (p)
1358 (interactive "p")
1359 (forward-line p)
1360 (or (eobp)
1361 (forward-char archive-file-name-indent)))
1362
1363(defun archive-previous-line (p)
1364 (interactive "p")
1365 (archive-next-line (- p)))
1366
1367(defun archive-chmod-entry (new-mode)
eeba65ed 1368 "Change the protection bits associated with all marked or this member.
665211a3 1369The new protection bits can either be specified as an octal number or
0cf1ef26 1370as a relative change like \"g+rw\" as for chmod(2)."
665211a3
KH		 1371 (interactive "sNew mode (octal or relative): ")
1372 (if archive-read-only (error "Archive is read-only"))
1373 (let ((func (archive-name "chmod-entry")))
1374 (if (fboundp func)
1375 (progn
1376 (funcall func new-mode (archive-get-marked ?* t))
1377 (archive-resummarize))
1378 (error "Setting mode bits is not supported for this archive type"))))
1379
1380(defun archive-chown-entry (new-uid)
1381 "Change the owner of all marked or this member."
1382 (interactive "nNew uid: ")
1383 (if archive-read-only (error "Archive is read-only"))
1384 (let ((func (archive-name "chown-entry")))
1385 (if (fboundp func)
1386 (progn
1387 (funcall func new-uid (archive-get-marked ?* t))
1388 (archive-resummarize))
1389 (error "Setting owner is not supported for this archive type"))))
1390
1391(defun archive-chgrp-entry (new-gid)
1392 "Change the group of all marked or this member."
1393 (interactive "nNew gid: ")
1394 (if archive-read-only (error "Archive is read-only"))
1395 (let ((func (archive-name "chgrp-entry")))
1396 (if (fboundp func)
1397 (progn
1398 (funcall func new-gid (archive-get-marked ?* t))
1399 (archive-resummarize))
1400 (error "Setting group is not supported for this archive type"))))
1401
1402(defun archive-expunge ()
1403 "Do the flagged deletions."
1404 (interactive)
1405 (let (files)
1406 (save-excursion
1407 (goto-char archive-file-list-start)
1408 (while (< (point) archive-file-list-end)
1409 (if (= (following-char) ?D)
1410 (setq files (cons (aref (archive-get-descr) 0) files)))
1411 (forward-line 1)))
1412 (setq files (nreverse files))
1413 (and files
1414 (or (not archive-read-only)
1415 (error "Archive is read-only"))
1416 (or (yes-or-no-p (format "Really delete %d member%s? "
1417 (length files)
1418 (if (null (cdr files)) "" "s")))
1419 (error "Operation aborted"))
1420 (let ((archive (archive-maybe-copy (buffer-file-name)))
1421 (expunger (archive-name "expunge")))
1422 (if (fboundp expunger)
1423 (funcall expunger archive files)
1424 (archive-*-expunge archive files (symbol-value expunger)))
1425 (archive-maybe-update nil)
1426 (if archive-remote
1427 (archive-resummarize)
1428 (revert-buffer))))))
1429
1430(defun archive-*-expunge (archive files command)
1431 (apply 'call-process
1432 (car command)
1433 nil
1434 nil
1435 nil
1436 (append (cdr command) (cons archive files))))
1437
1438(defun archive-rename-entry (newname)
fdaaf743 1439 "Change the name associated with this entry in the archive file."
665211a3
KH		 1440 (interactive "sNew name: ")
1441 (if archive-read-only (error "Archive is read-only"))
1442 (if (string= newname "")
1443 (error "Archive members may not be given empty names"))
1444 (let ((func (archive-name "rename-entry"))
1445 (descr (archive-get-descr)))
1446 (if (fboundp func)
1447 (progn
fdaaf743 1448 (funcall func
ad38511a
KH		 1449 (encode-coding-string newname
1450 archive-file-name-coding-system)
eb93d233 1451 descr)
665211a3
KH		 1452 (archive-resummarize))
1453 (error "Renaming is not supported for this archive type"))))
1454
1455;; Revert the buffer and recompute the dired-like listing.
06b60517 1456(defun archive-mode-revert (&optional _no-auto-save _no-confirm)
665211a3
KH		 1457 (let ((no (archive-get-lineno)))
1458 (setq archive-files nil)
380683ed
EZ		 1459 (let ((revert-buffer-function nil)
1460 (coding-system-for-read 'no-conversion))
665211a3
KH		 1461 (revert-buffer t t))
1462 (archive-mode)
1463 (goto-char archive-file-list-start)
1464 (archive-next-line no)))
1465
1466(defun archive-undo ()
1467 "Undo in an archive buffer.
1468This doesn't recover lost files, it just undoes changes in the buffer itself."
1469 (interactive)
e545bb99 1470 (let ((inhibit-read-only t))
665211a3
KH		 1471 (undo)))
1472;; -------------------------------------------------------------------------
7e9a3fef 1473;;; Section: Arc Archives
665211a3
KH		 1474
1475(defun archive-arc-summarize ()
1476 (let ((p 1)
1477 (totalsize 0)
1478 (maxlen 8)
1479 files
1480 visual)
1481 (while (and (< (+ p 29) (point-max))
ad38511a
KH		 1482 (= (byte-after p) ?\C-z)
1483 (> (byte-after (1+ p)) 0))
665211a3
KH		 1484 (let* ((namefld (buffer-substring (+ p 2) (+ p 2 13)))
1485 (fnlen (or (string-match "\0" namefld) 13))
ad38511a
KH		 1486 (efnname (decode-coding-string (substring namefld 0 fnlen)
1487 archive-file-name-coding-system))
a12aece3
EZ		 1488 ;; Convert to float to avoid overflow for very large files.
1489 (csize (archive-l-e (+ p 15) 4 'float))
665211a3
KH		 1490 (moddate (archive-l-e (+ p 19) 2))
1491 (modtime (archive-l-e (+ p 21) 2))
a12aece3 1492 (ucsize (archive-l-e (+ p 25) 4 'float))
665211a3
KH		 1493 (fiddle (string= efnname (upcase efnname)))
1494 (ifnname (if fiddle (downcase efnname) efnname))
a12aece3 1495 (text (format " %8.0f %-11s %-8s %s"
665211a3
KH		 1496 ucsize
1497 (archive-dosdate moddate)
1498 (archive-dostime modtime)
1499 ifnname)))
1500 (setq maxlen (max maxlen fnlen)
1501 totalsize (+ totalsize ucsize)
1502 visual (cons (vector text
1503 (- (length text) (length ifnname))
1504 (length text))
1505 visual)
1506 files (cons (vector efnname ifnname fiddle nil (1- p))
1507 files)
7893e589
EZ		 1508 ;; p needs to stay an integer, since we use it in char-after
1509 ;; above. Passing through `round' limits the compressed size
1510 ;; to most-positive-fixnum, but if the compressed size exceeds
1511 ;; that, we cannot visit the archive anyway.
1512 p (+ p 29 (round csize)))))
665211a3
KH		 1513 (goto-char (point-min))
1514 (let ((dash (concat "- -------- ----------- -------- "
1515 (make-string maxlen ?-)
1516 "\n")))
1517 (insert "M Length Date Time File\n"
1518 dash)
1519 (archive-summarize-files (nreverse visual))
1520 (insert dash
a12aece3 1521 (format " %8.0f %d file%s"
665211a3
KH		 1522 totalsize
1523 (length files)
1524 (if (= 1 (length files)) "" "s"))
1525 "\n"))
1526 (apply 'vector (nreverse files))))
1527
fdaaf743 1528(defun archive-arc-rename-entry (newname descr)
665211a3 1529 (if (string-match "[:\\\\/]" newname)
9dacec4c 1530 (error "File names in arc files must not contain a directory component"))
665211a3
KH		 1531 (if (> (length newname) 12)
1532 (error "File names in arc files are limited to 12 characters"))
1533 (let ((name (concat newname (substring "\0\0\0\0\0\0\0\0\0\0\0\0\0"
1534 (length newname))))
e545bb99 1535 (inhibit-read-only t))
665211a3
KH		 1536 (save-restriction
1537 (save-excursion
1538 (widen)
1539 (goto-char (+ archive-proper-file-start (aref descr 4) 2))
1540 (delete-char 13)
ad38511a 1541 (insert-unibyte name)))))
665211a3 1542;; -------------------------------------------------------------------------
7e9a3fef 1543;;; Section: Lzh Archives
665211a3 1544
fcb006c4
CY		 1545(defun archive-lzh-summarize (&optional start)
1546 (let ((p (or start 1)) ;; 1 for .lzh, something further on for .exe
665211a3
KH		 1547 (totalsize 0)
1548 (maxlen 8)
1549 files
1550 visual)
5f23d836 1551 (while (progn (goto-char p) ;beginning of a base header.
a56636ae 1552 (looking-at "\\(.\\|\n\\)\\(.\\|\n\\)-l[hz][0-9ds]-"))
8f924df7 1553 (let* ((hsize (byte-after p)) ;size of the base header (level 0 and 1)
a12aece3
EZ		 1554 ;; Convert to float to avoid overflow for very large files.
1555 (csize (archive-l-e (+ p 7) 4 'float)) ;size of a compressed file to follow (level 0 and 2),
a28fe04b 1556 ;size of extended headers + the compressed file to follow (level 1).
a12aece3 1557 (ucsize (archive-l-e (+ p 11) 4 'float)) ;size of an uncompressed file.
5f23d836
RS		 1558 (time1 (archive-l-e (+ p 15) 2)) ;date/time (MSDOS format in level 0, 1 headers
1559 (time2 (archive-l-e (+ p 17) 2)) ;and UNIX format in level 2 header.)
8f924df7 1560 (hdrlvl (byte-after (+ p 20))) ;header level
5f23d836 1561 thsize ;total header size (base + extensions)
bdbfe3bf 1562 fnlen efnname osid fiddle ifnname width p2
5f23d836
RS		 1563 neh ;beginning of next extension header (level 1 and 2)
1564 mode modestr uid gid text dir prname
1565 gname uname modtime moddate)
1566 (if (= hdrlvl 3) (error "can't handle lzh level 3 header type"))
1567 (when (or (= hdrlvl 0) (= hdrlvl 1))
8f924df7 1568 (setq fnlen (byte-after (+ p 21))) ;filename length
5f23d836 1569 (setq efnname (let ((str (buffer-substring (+ p 22) (+ p 22 fnlen)))) ;filename from offset 22
ad38511a
KH		 1570 (decode-coding-string
1571 str archive-file-name-coding-system)))
5f23d836
RS		 1572 (setq p2 (+ p 22 fnlen))) ;
1573 (if (= hdrlvl 1)
fdaaf743 1574 (setq neh (+ p2 3)) ;specific to level 1 header
5f23d836 1575 (if (= hdrlvl 2)
fdaaf743 1576 (setq neh (+ p 24)))) ;specific to level 2 header
5f23d836
RS		 1577 (if neh ;if level 1 or 2 we expect extension headers to follow
1578 (let* ((ehsize (archive-l-e neh 2)) ;size of the extension header
8f924df7 1579 (etype (byte-after (+ neh 2)))) ;extension type
5f23d836 1580 (while (not (= ehsize 0))
a56636ae 1581 (cond
5f23d836
RS		 1582 ((= etype 1) ;file name
1583 (let ((i (+ neh 3)))
1584 (while (< i (+ neh ehsize))
8f924df7 1585 (setq efnname (concat efnname (char-to-string (byte-after i))))
5f23d836
RS		 1586 (setq i (1+ i)))))
1587 ((= etype 2) ;directory name
1588 (let ((i (+ neh 3)))
1589 (while (< i (+ neh ehsize))
9dacec4c 1590 (setq dir (concat dir
ad38511a 1591 (if (= (byte-after i)
a56636ae
RS		 1592 255)
1593 "/"
1594 (char-to-string
1595 (char-after i)))))
1596 (setq i (1+ i)))))
5f23d836
RS		 1597 ((= etype 80) ;Unix file permission
1598 (setq mode (archive-l-e (+ neh 3) 2)))
1599 ((= etype 81) ;UNIX file group/user ID
1600 (progn (setq uid (archive-l-e (+ neh 3) 2))
1601 (setq gid (archive-l-e (+ neh 5) 2))))
1602 ((= etype 82) ;UNIX file group name
1603 (let ((i (+ neh 3)))
1604 (while (< i (+ neh ehsize))
1605 (setq gname (concat gname (char-to-string (char-after i))))
1606 (setq i (1+ i)))))
1607 ((= etype 83) ;UNIX file user name
1608 (let ((i (+ neh 3)))
1609 (while (< i (+ neh ehsize))
1610 (setq uname (concat uname (char-to-string (char-after i))))
1611 (setq i (1+ i)))))
a56636ae 1612 )
5f23d836
RS		 1613 (setq neh (+ neh ehsize))
1614 (setq ehsize (archive-l-e neh 2))
8f924df7 1615 (setq etype (byte-after (+ neh 2))))
5f23d836
RS		 1616 ;;get total header size for level 1 and 2 headers
1617 (setq thsize (- neh p))))
1618 (if (= hdrlvl 0) ;total header size
1619 (setq thsize hsize))
bdbfe3bf
CY		 1620 ;; OS ID field not present in level 0 header, use code 0 "generic"
1621 ;; in that case as per lha program header.c get_header()
1622 (setq osid (cond ((= hdrlvl 0) 0)
1623 ((= hdrlvl 1) (char-after (+ p 22 fnlen 2)))
1624 ((= hdrlvl 2) (char-after (+ p 23)))))
1625 ;; Filename fiddling must follow the lha program, otherwise the name
1626 ;; passed to "lha pq" etc won't match (which for an extract silently
1627 ;; results in no output). As of version 1.14i it goes from the OS ID,
1628 ;; - For 'M' MSDOS: msdos_to_unix_filename() downcases always, and
1629 ;; converts "\" to "/".
1630 ;; - For 0 generic: generic_to_unix_filename() downcases if there's
1631 ;; no lower case already present, and converts "\" to "/".
1632 ;; - For 'm' MacOS: macos_to_unix_filename() changes "/" to ":" and
1633 ;; ":" to "/"
1634 (setq fiddle (cond ((= ?M osid) t)
1635 ((= 0 osid) (string= efnname (upcase efnname)))))
5f23d836 1636 (setq ifnname (if fiddle (downcase efnname) efnname))
9dacec4c 1637 (setq prname (if dir (concat dir ifnname) ifnname))
d2c6d975 1638 (setq width (if prname (string-width prname) 0))
a56636ae 1639 (setq modestr (if mode (archive-int-to-mode mode) "??????????"))
5f23d836
RS		 1640 (setq moddate (if (= hdrlvl 2)
1641 (archive-unixdate time1 time2) ;level 2 header in UNIX format
1642 (archive-dosdate time2))) ;level 0 and 1 header in DOS format
1643 (setq modtime (if (= hdrlvl 2)
1644 (archive-unixtime time1 time2)
1645 (archive-dostime time1)))
a56636ae 1646 (setq text (if archive-alternate-display
a12aece3 1647 (format " %8.0f %5S %5S %s"
665211a3
KH		 1648 ucsize
1649 (or uid "?")
1650 (or gid "?")
1651 ifnname)
a12aece3 1652 (format " %10s %8.0f %-11s %-8s %s"
665211a3
KH		 1653 modestr
1654 ucsize
5f23d836
RS		 1655 moddate
1656 modtime
1657 prname)))
eb93d233 1658 (setq maxlen (max maxlen width)
665211a3
KH		 1659 totalsize (+ totalsize ucsize)
1660 visual (cons (vector text
5f23d836 1661 (- (length text) (length prname))
665211a3
KH		 1662 (length text))
1663 visual)
a56636ae 1664 files (cons (vector prname ifnname fiddle mode (1- p))
a28fe04b
RS		 1665 files))
1666 (cond ((= hdrlvl 1)
7893e589
EZ		 1667 ;; p needs to stay an integer, since we use it in goto-char
1668 ;; above. Passing through `round' limits the compressed size
1669 ;; to most-positive-fixnum, but if the compressed size exceeds
1670 ;; that, we cannot visit the archive anyway.
1671 (setq p (+ p hsize 2 (round csize))))
a28fe04b 1672 ((or (= hdrlvl 2) (= hdrlvl 0))
7893e589 1673 (setq p (+ p thsize 2 (round csize)))))
a28fe04b 1674 ))
665211a3
KH		 1675 (goto-char (point-min))
1676 (let ((dash (concat (if archive-alternate-display
1677 "- -------- ----- ----- "
1678 "- ---------- -------- ----------- -------- ")
1679 (make-string maxlen ?-)
1680 "\n"))
1681 (header (if archive-alternate-display
1682 "M Length Uid Gid File\n"
1683 "M Filemode Length Date Time File\n"))
1684 (sumline (if archive-alternate-display
a12aece3
EZ		 1685 " %8.0f %d file%s"
1686 " %8.0f %d file%s")))
665211a3
KH		 1687 (insert header dash)
1688 (archive-summarize-files (nreverse visual))
1689 (insert dash
1690 (format sumline
1691 totalsize
1692 (length files)
1693 (if (= 1 (length files)) "" "s"))
1694 "\n"))
1695 (apply 'vector (nreverse files))))
1696
1697(defconst archive-lzh-alternate-display t)
1698
1699(defun archive-lzh-extract (archive name)
1700 (archive-extract-by-stdout archive name archive-lzh-extract))
1701
1702(defun archive-lzh-resum (p count)
1703 (let ((sum 0))
1704 (while (> count 0)
1705 (setq count (1- count)
ad38511a 1706 sum (+ sum (byte-after p))
665211a3
KH		 1707 p (1+ p)))
1708 (logand sum 255)))
1709
fdaaf743 1710(defun archive-lzh-rename-entry (newname descr)
665211a3
KH		 1711 (save-restriction
1712 (save-excursion
1713 (widen)
1714 (let* ((p (+ archive-proper-file-start (aref descr 4)))
ad38511a
KH		 1715 (oldhsize (byte-after p))
1716 (oldfnlen (byte-after (+ p 21)))
665211a3
KH		 1717 (newfnlen (length newname))
1718 (newhsize (+ oldhsize newfnlen (- oldfnlen)))
e545bb99 1719 (inhibit-read-only t))
665211a3
KH		 1720 (if (> newhsize 255)
1721 (error "The file name is too long"))
1722 (goto-char (+ p 21))
1723 (delete-char (1+ oldfnlen))
ad38511a 1724 (insert-unibyte newfnlen newname)
665211a3
KH		 1725 (goto-char p)
1726 (delete-char 2)
ad38511a 1727 (insert-unibyte newhsize (archive-lzh-resum p newhsize))))))
665211a3
KH		 1728
1729(defun archive-lzh-ogm (newval files errtxt ofs)
f2cd8aca
SM		 1730 (save-excursion
1731 (save-restriction
665211a3 1732 (widen)
e545bb99
SM		 1733 (dolist (fil files)
1734 (let* ((p (+ archive-proper-file-start (aref fil 4)))
ad38511a
KH		 1735 (hsize (byte-after p))
1736 (fnlen (byte-after (+ p 21)))
665211a3 1737 (p2 (+ p 22 fnlen))
ad38511a 1738 (creator (if (>= (- hsize fnlen) 24) (byte-after (+ p2 2)) 0))
e545bb99 1739 (inhibit-read-only t))
665211a3
KH		 1740 (if (= creator ?U)
1741 (progn
1742 (or (numberp newval)
1743 (setq newval (funcall newval (archive-l-e (+ p2 ofs) 2))))
1744 (goto-char (+ p2 ofs))
1745 (delete-char 2)
ad38511a 1746 (insert-unibyte (logand newval 255) (lsh newval -8))
665211a3
KH		 1747 (goto-char (1+ p))
1748 (delete-char 1)
ad38511a 1749 (insert-unibyte (archive-lzh-resum (1+ p) hsize)))
665211a3 1750 (message "Member %s does not have %s field"
e545bb99 1751 (aref fil 1) errtxt)))))))
665211a3
KH		 1752
1753(defun archive-lzh-chown-entry (newuid files)
1754 (archive-lzh-ogm newuid files "an uid" 10))
1755
1756(defun archive-lzh-chgrp-entry (newgid files)
1757 (archive-lzh-ogm newgid files "a gid" 12))
1758
1759(defun archive-lzh-chmod-entry (newmode files)
1760 (archive-lzh-ogm
1761 ;; This should work even though newmode will be dynamically accessed.
fdaaf743 1762 (lambda (old) (archive-calc-mode old newmode t))
665211a3 1763 files "a unix-style mode" 8))
fcb006c4
CY		 1764
1765;; -------------------------------------------------------------------------
7e9a3fef 1766;;; Section: Lzh Self-Extracting .exe Archives
fcb006c4
CY		 1767;;
1768;; No support for modifying these files. It looks like the lha for unix
1769;; program (as of version 1.14i) can't create or retain the DOS exe part.
1770;; If you do an "lha a" on a .exe for instance it renames and writes to a
1771;; plain .lzh.
1772
1773(defun archive-lzh-exe-summarize ()
1774 "Summarize the contents of an LZH self-extracting exe, for `archive-mode'."
1775
1776 ;; Skip the initial executable code part and apply archive-lzh-summarize
1777 ;; to the archive part proper. The "-lh5-" etc regexp here for the start
1778 ;; is the same as in archive-find-type.
1779 ;;
1780 ;; The lha program (version 1.14i) does this in skip_msdos_sfx1_code() by
1781 ;; a similar scan. It looks for "..-l..-" plus for level 0 or 1 a test of
1782 ;; the header checksum, or level 2 a test of the "attribute" and size.
1783 ;;
1784 (re-search-forward "..-l[hz][0-9ds]-" nil)
1785 (archive-lzh-summarize (match-beginning 0)))
1786
1787;; `archive-lzh-extract' runs "lha pq", and that works for .exe as well as
1788;; .lzh files
1789(defalias 'archive-lzh-exe-extract 'archive-lzh-extract
1790 "Extract a member from an LZH self-extracting exe, for `archive-mode'.")
1791
665211a3 1792;; -------------------------------------------------------------------------
7e9a3fef 1793;;; Section: Zip Archives
665211a3
KH		 1794
1795(defun archive-zip-summarize ()
1796 (goto-char (- (point-max) (- 22 18)))
1797 (search-backward-regexp "[P]K\005\006")
8627813e 1798 (let ((p (+ (point-min) (archive-l-e (+ (point) 16) 4)))
665211a3
KH		 1799 (maxlen 8)
1800 (totalsize 0)
1801 files
1802 visual)
1803 (while (string= "PK\001\002" (buffer-substring p (+ p 4)))
ad38511a 1804 (let* ((creator (byte-after (+ p 5)))
fdaaf743 1805 ;; (method (archive-l-e (+ p 10) 2))
665211a3
KH		 1806 (modtime (archive-l-e (+ p 12) 2))
1807 (moddate (archive-l-e (+ p 14) 2))
a12aece3
EZ		 1808 ;; Convert to float to avoid overflow for very large files.
1809 (ucsize (archive-l-e (+ p 24) 4 'float))
665211a3
KH		 1810 (fnlen (archive-l-e (+ p 28) 2))
1811 (exlen (archive-l-e (+ p 30) 2))
845720b9 1812 (fclen (archive-l-e (+ p 32) 2))
665211a3 1813 (lheader (archive-l-e (+ p 42) 4))
eb93d233 1814 (efnname (let ((str (buffer-substring (+ p 46) (+ p 46 fnlen))))
ad38511a
KH		 1815 (decode-coding-string
1816 str archive-file-name-coding-system)))
665211a3
KH		 1817 (isdir (and (= ucsize 0)
1818 (string= (file-name-nondirectory efnname) "")))
7c2fb837 1819 (mode (cond ((memq creator '(2 3)) ; Unix
665211a3 1820 (archive-l-e (+ p 40) 2))
380683ed 1821 ((memq creator '(0 5 6 7 10 11 15)) ; Dos etc.
665211a3
KH		 1822 (logior ?\444
1823 (if isdir (logior 16384 ?\111) 0)
1824 (if (zerop
ad38511a 1825 (logand 1 (byte-after (+ p 38))))
665211a3
KH		 1826 ?\222 0)))
1827 (t nil)))
1828 (modestr (if mode (archive-int-to-mode mode) "??????????"))
1829 (fiddle (and archive-zip-case-fiddle
380683ed
EZ		 1830 (not (not (memq creator '(0 2 4 5 9))))
1831 (string= (upcase efnname) efnname)))
665211a3 1832 (ifnname (if fiddle (downcase efnname) efnname))
eb93d233 1833 (width (string-width ifnname))
a12aece3 1834 (text (format " %10s %8.0f %-11s %-8s %s"
665211a3
KH		 1835 modestr
1836 ucsize
1837 (archive-dosdate moddate)
1838 (archive-dostime modtime)
1839 ifnname)))
eb93d233 1840 (setq maxlen (max maxlen width)
665211a3
KH		 1841 totalsize (+ totalsize ucsize)
1842 visual (cons (vector text
1843 (- (length text) (length ifnname))
1844 (length text))
1845 visual)
1846 files (cons (if isdir
1847 nil
1848 (vector efnname ifnname fiddle mode
1849 (list (1- p) lheader)))
1850 files)
845720b9 1851 p (+ p 46 fnlen exlen fclen))))
665211a3
KH		 1852 (goto-char (point-min))
1853 (let ((dash (concat "- ---------- -------- ----------- -------- "
1854 (make-string maxlen ?-)
1855 "\n")))
1856 (insert "M Filemode Length Date Time File\n"
1857 dash)
1858 (archive-summarize-files (nreverse visual))
1859 (insert dash
a12aece3 1860 (format " %8.0f %d file%s"
665211a3
KH		 1861 totalsize
1862 (length files)
1863 (if (= 1 (length files)) "" "s"))
1864 "\n"))
1865 (apply 'vector (nreverse files))))
1866
1867(defun archive-zip-extract (archive name)
b3671a51
JL		 1868 (cond
1869 ((member-ignore-case (car archive-zip-extract) '("pkunzip" "pkzip"))
1870 (archive-*-extract archive name archive-zip-extract))
816244a2 1871 ((equal (car archive-zip-extract) archive-7z-program)
b3671a51
JL		 1872 (let ((archive-7z-extract archive-zip-extract))
1873 (archive-7z-extract archive name)))
1874 (t
6ba973c1
JL		 1875 (archive-extract-by-stdout
1876 archive
aca54191
EZ		 1877 ;; unzip expands wildcards in NAME, so we need to quote it. But
1878 ;; not on DOS/Windows, since that fails extraction on those
72a44673
EZ		 1879 ;; systems (unless w32-quote-process-args is nil), and file names
1880 ;; with wildcards in zip archives don't work there anyway.
6ba973c1 1881 ;; FIXME: Does pkunzip need similar treatment?
72a44673
EZ		 1882 (if (and (or (not (memq system-type '(windows-nt ms-dos)))
1883 (and (boundp 'w32-quote-process-args)
1884 (null w32-quote-process-args)))
aca54191 1885 (equal (car archive-zip-extract) "unzip"))
6ba973c1
JL		 1886 (shell-quote-argument name)
1887 name)
b3671a51 1888 archive-zip-extract))))
665211a3
KH		 1889
1890(defun archive-zip-write-file-member (archive descr)
1891 (archive-*-write-file-member
1892 archive
1893 descr
1894 (if (aref descr 2) archive-zip-update-case archive-zip-update)))
1895
1896(defun archive-zip-chmod-entry (newmode files)
1897 (save-restriction
1898 (save-excursion
1899 (widen)
e545bb99
SM		 1900 (dolist (fil files)
1901 (let* ((p (+ archive-proper-file-start (car (aref fil 4))))
ad38511a 1902 (creator (byte-after (+ p 5)))
665211a3
KH		 1903 (oldmode (aref fil 3))
1904 (newval (archive-calc-mode oldmode newmode t))
e545bb99 1905 (inhibit-read-only t))
7c2fb837 1906 (cond ((memq creator '(2 3)) ; Unix
665211a3
KH		 1907 (goto-char (+ p 40))
1908 (delete-char 2)
ad38511a 1909 (insert-unibyte (logand newval 255) (lsh newval -8)))
380683ed 1910 ((memq creator '(0 5 6 7 10 11 15)) ; Dos etc.
665211a3 1911 (goto-char (+ p 38))
ad38511a
KH		 1912 (insert-unibyte (logior (logand (byte-after (point)) 254)
1913 (logand (logxor 1 (lsh newval -7)) 1)))
665211a3
KH		 1914 (delete-char 1))
1915 (t (message "Don't know how to change mode for this member"))))
e545bb99 1916 ))))
665211a3 1917;; -------------------------------------------------------------------------
7e9a3fef 1918;;; Section: Zoo Archives
665211a3
KH		 1919
1920(defun archive-zoo-summarize ()
1921 (let ((p (1+ (archive-l-e 25 4)))
1922 (maxlen 8)
1923 (totalsize 0)
1924 files
1925 visual)
1926 (while (and (string= "\334\247\304\375" (buffer-substring p (+ p 4)))
1927 (> (archive-l-e (+ p 6) 4) 0))
1928 (let* ((next (1+ (archive-l-e (+ p 6) 4)))
1929 (moddate (archive-l-e (+ p 14) 2))
1930 (modtime (archive-l-e (+ p 16) 2))
a12aece3
EZ		 1931 ;; Convert to float to avoid overflow for very large files.
1932 (ucsize (archive-l-e (+ p 20) 4 'float))
665211a3 1933 (namefld (buffer-substring (+ p 38) (+ p 38 13)))
ad38511a
KH		 1934 (dirtype (byte-after (+ p 4)))
1935 (lfnlen (if (= dirtype 2) (byte-after (+ p 56)) 0))
1936 (ldirlen (if (= dirtype 2) (byte-after (+ p 57)) 0))
9913653a 1937 (fnlen (or (string-match "\0" namefld) 13))
eb93d233
EZ		 1938 (efnname (let ((str
1939 (concat
1940 (if (> ldirlen 0)
1941 (concat (buffer-substring
1942 (+ p 58 lfnlen)
1943 (+ p 58 lfnlen ldirlen -1))
1944 "/")
1945 "")
1946 (if (> lfnlen 0)
1947 (buffer-substring (+ p 58)
1948 (+ p 58 lfnlen -1))
1949 (substring namefld 0 fnlen)))))
ad38511a
KH		 1950 (decode-coding-string
1951 str archive-file-name-coding-system)))
83c4abcb 1952 (fiddle (and (= lfnlen 0) (string= efnname (upcase efnname))))
665211a3 1953 (ifnname (if fiddle (downcase efnname) efnname))
eb93d233 1954 (width (string-width ifnname))
a12aece3 1955 (text (format " %8.0f %-11s %-8s %s"
665211a3
KH		 1956 ucsize
1957 (archive-dosdate moddate)
1958 (archive-dostime modtime)
1959 ifnname)))
0233a189 1960 (setq maxlen (max maxlen width)
665211a3
KH		 1961 totalsize (+ totalsize ucsize)
1962 visual (cons (vector text
1963 (- (length text) (length ifnname))
1964 (length text))
1965 visual)
1966 files (cons (vector efnname ifnname fiddle nil (1- p))
1967 files)
1968 p next)))
1969 (goto-char (point-min))
1970 (let ((dash (concat "- -------- ----------- -------- "
1971 (make-string maxlen ?-)
1972 "\n")))
1973 (insert "M Length Date Time File\n"
1974 dash)
1975 (archive-summarize-files (nreverse visual))
1976 (insert dash
a12aece3 1977 (format " %8.0f %d file%s"
665211a3
KH		 1978 totalsize
1979 (length files)
1980 (if (= 1 (length files)) "" "s"))
1981 "\n"))
1982 (apply 'vector (nreverse files))))
1983
1984(defun archive-zoo-extract (archive name)
1985 (archive-extract-by-stdout archive name archive-zoo-extract))
7e9a3fef
SM		 1986
1987;; -------------------------------------------------------------------------
1988;;; Section: Rar Archives
1989
c9db111a
SM		 1990(defun archive-rar-summarize (&optional file)
1991 ;; File is used internally for `archive-rar-exe-summarize'.
1992 (unless file (setq file buffer-file-name))
1993 (let* ((copy (file-local-copy file))
7e9a3fef
SM		 1994 (maxname 10)
1995 (maxsize 5)
1996 (files ()))
1997 (with-temp-buffer
1998 (call-process "unrar-free" nil t nil "--list" (or file copy))
1999 (if copy (delete-file copy))
2000 (goto-char (point-min))
2001 (re-search-forward "^-+\n")
7e9a3fef
SM		 2002 (while (looking-at (concat " \\(.*\\)\n" ;Name.
2003 ;; Size ; Packed.
2004 " +\\([0-9]+\\) +[0-9]+"
2005 ;; Ratio ; Date'
2006 " +\\([0-9%]+\\) +\\([-0-9]+\\)"
2007 ;; Time ; Attr.
097d86f9 2008 " +\\([0-9:]+\\) +[^ \n]\\{6,10\\}"
7e9a3fef
SM		 2009 ;; CRC; Meth ; Var.
2010 " +[0-9A-F]+ +[^ \n]+ +[0-9.]+\n"))
2011 (goto-char (match-end 0))
2012 (let ((name (match-string 1))
2013 (size (match-string 2)))
2014 (if (> (length name) maxname) (setq maxname (length name)))
2015 (if (> (length size) maxsize) (setq maxsize (length size)))
2016 (push (vector name name nil nil
2017 ;; Size, Ratio.
2018 size (match-string 3)
2019 ;; Date, Time.
2020 (match-string 4) (match-string 5))
c9db111a 2021 files))))
7e9a3fef
SM		 2022 (setq files (nreverse files))
2023 (goto-char (point-min))
2024 (let* ((format (format " %%s %%s %%%ds %%5s %%s" maxsize))
2025 (sep (format format "--------" "-----" (make-string maxsize ?-)
2026 "-----" ""))
2027 (column (length sep)))
2028 (insert (format format " Date " "Time " "Size " "Ratio" " Filename") "\n")
2029 (insert sep (make-string maxname ?-) "\n")
2030 (archive-summarize-files (mapcar (lambda (desc)
2031 (let ((text
2032 (format format
2033 (aref desc 6)
2034 (aref desc 7)
2035 (aref desc 4)
2036 (aref desc 5)
2037 (aref desc 1))))
2038 (vector text
2039 column
2040 (length text))))
2041 files))
2042 (insert sep (make-string maxname ?-) "\n")
2043 (apply 'vector files))))
2044
2045(defun archive-rar-extract (archive name)
2046 ;; unrar-free seems to have no way to extract to stdout or even to a file.
2047 (if (file-name-absolute-p name)
2048 ;; The code below assumes the name is relative and may do undesirable
2049 ;; things otherwise.
2050 (error "Can't extract files with non-relative names")
53baf48a 2051 (archive-extract-by-file archive name '("unrar-free" "--extract") "All OK")))
7e9a3fef 2052
c9db111a
SM		 2053;;; Section: Rar self-extracting .exe archives.
2054
2055(defun archive-rar-exe-summarize ()
2056 (let ((tmpfile (make-temp-file "rarexe")))
2057 (unwind-protect
2058 (progn
2059 (goto-char (point-min))
2060 (re-search-forward "Rar!")
2061 (write-region (match-beginning 0) (point-max) tmpfile)
2062 (archive-rar-summarize tmpfile))
2063 (delete-file tmpfile))))
2064
2065(defun archive-rar-exe-extract (archive name)
2066 (let* ((tmpfile (make-temp-file "rarexe"))
2067 (buf (find-buffer-visiting archive))
2068 (tmpbuf (unless buf (generate-new-buffer " *rar-exe*"))))
2069 (unwind-protect
2070 (progn
2071 (with-current-buffer (or buf tmpbuf)
2072 (save-excursion
2073 (save-restriction
2074 (if buf
2075 ;; point-max unwidened is assumed to be the end of the
2076 ;; summary text and the beginning of the actual file data.
2077 (progn (goto-char (point-max)) (widen))
2078 (insert-file-contents-literally archive)
2079 (goto-char (point-min)))
2080 (re-search-forward "Rar!")
2081 (write-region (match-beginning 0) (point-max) tmpfile))))
2082 (archive-rar-extract tmpfile name))
2083 (if tmpbuf (kill-buffer tmpbuf))
2084 (delete-file tmpfile))))
687422df 2085
b3671a51
JL		 2086;; -------------------------------------------------------------------------
2087;;; Section: 7z Archives
c9db111a 2088
b3671a51
JL		 2089(defun archive-7z-summarize ()
2090 (let ((maxname 10)
2091 (maxsize 5)
2092 (file buffer-file-name)
2093 (files ()))
2094 (with-temp-buffer
816244a2 2095 (call-process archive-7z-program nil t nil "l" "-slt" file)
b3671a51 2096 (goto-char (point-min))
ac89b32c
JL		 2097 ;; Four dashes start the meta info section that should be skipped.
2098 ;; Archive members start with more than four dashes.
2099 (re-search-forward "^-----+\n")
b3671a51
JL		 2100 (while (re-search-forward "^Path = \\(.*\\)\n" nil t)
2101 (goto-char (match-end 0))
2102 (let ((name (match-string 1))
2103 (size (save-excursion
2104 (and (re-search-forward "^Size = \\(.*\\)\n")
2105 (match-string 1))))
2106 (time (save-excursion
2107 (and (re-search-forward "^Modified = \\(.*\\)\n")
2108 (match-string 1)))))
2109 (if (> (length name) maxname) (setq maxname (length name)))
2110 (if (> (length size) maxsize) (setq maxsize (length size)))
2111 (push (vector name name nil nil time nil nil size)
2112 files))))
2113 (setq files (nreverse files))
2114 (goto-char (point-min))
2115 (let* ((format (format " %%%ds %%s %%s" maxsize))
2116 (sep (format format (make-string maxsize ?-) "-------------------" ""))
2117 (column (length sep)))
2118 (insert (format format "Size " "Date Time " " Filename") "\n")
2119 (insert sep (make-string maxname ?-) "\n")
2120 (archive-summarize-files (mapcar (lambda (desc)
2121 (let ((text
2122 (format format
2123 (aref desc 7)
2124 (aref desc 4)
2125 (aref desc 1))))
2126 (vector text
2127 column
2128 (length text))))
2129 files))
2130 (insert sep (make-string maxname ?-) "\n")
2131 (apply 'vector files))))
2132
2133(defun archive-7z-extract (archive name)
53baf48a
JL		 2134 ;; 7z doesn't provide a `quiet' option to suppress non-essential
2135 ;; stderr messages. So redirect stderr to a temp file and display it
2136 ;; in the echo area when it contains no message indicating success.
2137 (archive-extract-by-stdout
2138 archive name archive-7z-extract "Everything is Ok"))
b3671a51 2139
ac89b32c
JL		 2140(defun archive-7z-write-file-member (archive descr)
2141 (archive-*-write-file-member
2142 archive
2143 descr
2144 archive-7z-update))
2145
b3671a51 2146;; -------------------------------------------------------------------------
239bf18b
SM		 2147;;; Section `ar' archives.
2148
2149;; TODO: we currently only handle the basic format of ar archives,
2150;; not the GNU nor the BSD extensions. As it turns out, this is sufficient
2151;; for .deb packages.
2152
2153(autoload 'tar-grind-file-mode "tar-mode")
2154
2155(defconst archive-ar-file-header-re
2156 "\\(.\\{16\\}\\)\\([ 0-9]\\{12\\}\\)\\([ 0-9]\\{6\\}\\)\\([ 0-9]\\{6\\}\\)\\([ 0-7]\\{8\\}\\)\\([ 0-9]\\{10\\}\\)`\n")
2157
2158(defun archive-ar-summarize ()
2159 ;; File is used internally for `archive-rar-exe-summarize'.
2160 (let* ((maxname 10)
2161 (maxtime 16)
2162 (maxuser 5)
2163 (maxgroup 5)
2164 (maxmode 8)
2165 (maxsize 5)
2166 (files ()))
2167 (goto-char (point-min))
2168 (search-forward "!<arch>\n")
2169 (while (looking-at archive-ar-file-header-re)
2170 (let ((name (match-string 1))
3835d0d0 2171 extname
239bf18b
SM		 2172 ;; Emacs will automatically use float here because those
2173 ;; timestamps don't fit in our ints.
2174 (time (string-to-number (match-string 2)))
2175 (user (match-string 3))
2176 (group (match-string 4))
2177 (mode (string-to-number (match-string 5) 8))
2178 (size (string-to-number (match-string 6))))
2179 ;; Move to the beginning of the data.
2180 (goto-char (match-end 0))
3835d0d0
SM		 2181 (setq time
2182 (format-time-string
2183 "%Y-%m-%d %H:%M"
2184 (let ((high (truncate (/ time 65536))))
2185 (list high (truncate (- time (* 65536.0 high)))))))
2186 (setq extname
2187 (cond ((equal name "// ")
2188 (propertize ".<ExtNamesTable>." 'face 'italic))
2189 ((equal name "/ ")
2190 (propertize ".<LookupTable>." 'face 'italic))
2191 ((string-match "/? *\\'" name)
2192 (substring name 0 (match-beginning 0)))))
2193 (setq user (substring user 0 (string-match " +\\'" user)))
2194 (setq group (substring group 0 (string-match " +\\'" group)))
2195 (setq mode (tar-grind-file-mode mode))
2196 ;; Move to the end of the data.
2197 (forward-char size) (if (eq ?\n (char-after)) (forward-char 1))
2198 (setq size (number-to-string size))
2199 (if (> (length name) maxname) (setq maxname (length name)))
2200 (if (> (length time) maxtime) (setq maxtime (length time)))
2201 (if (> (length user) maxuser) (setq maxuser (length user)))
2202 (if (> (length group) maxgroup) (setq maxgroup (length group)))
2203 (if (> (length mode) maxmode) (setq maxmode (length mode)))
2204 (if (> (length size) maxsize) (setq maxsize (length size)))
2205 (push (vector name extname nil mode
2206 time user group size)
2207 files)))
239bf18b
SM		 2208 (setq files (nreverse files))
2209 (goto-char (point-min))
2210 (let* ((format (format "%%%ds %%%ds/%%-%ds %%%ds %%%ds %%s"
2211 maxmode maxuser maxgroup maxsize maxtime))
2212 (sep (format format (make-string maxmode ?-)
2213 (make-string maxuser ?-)
2214 (make-string maxgroup ?-)
2215 (make-string maxsize ?-)
2216 (make-string maxtime ?-) ""))
2217 (column (length sep)))
2218 (insert (format format " Mode " "User" "Group" " Size "
2219 " Date " "Filename")
2220 "\n")
2221 (insert sep (make-string maxname ?-) "\n")
2222 (archive-summarize-files (mapcar (lambda (desc)
2223 (let ((text
2224 (format format
2225 (aref desc 3)
2226 (aref desc 5)
2227 (aref desc 6)
2228 (aref desc 7)
2229 (aref desc 4)
2230 (aref desc 1))))
2231 (vector text
2232 column
2233 (length text))))
2234 files))
2235 (insert sep (make-string maxname ?-) "\n")
2236 (apply 'vector files))))
2237
2238(defun archive-ar-extract (archive name)
2239 (let ((destbuf (current-buffer))
2240 (archivebuf (find-file-noselect archive))
2241 (from nil) size)
2242 (with-current-buffer archivebuf
2243 (save-restriction
2244 ;; We may be in archive-mode or not, so either with or without
2245 ;; narrowing and with or without a prepended summary.
3835d0d0
SM		 2246 (save-excursion
2247 (widen)
2248 (search-forward "!<arch>\n")
2249 (while (and (not from) (looking-at archive-ar-file-header-re))
2250 (let ((this (match-string 1)))
2251 (setq size (string-to-number (match-string 6)))
2252 (goto-char (match-end 0))
2253 (if (equal name this)
2254 (setq from (point))
2255 ;; Move to the end of the data.
2256 (forward-char size) (if (eq ?\n (char-after)) (forward-char 1)))))
2257 (when from
2258 (set-buffer-multibyte nil)
2259 (with-current-buffer destbuf
2260 ;; Do it within the `widen'.
2261 (insert-buffer-substring archivebuf from (+ from size)))
2262 (set-buffer-multibyte 'to)
2263 ;; Inform the caller that the call succeeded.
2264 t))))))
239bf18b 2265
665211a3 2266;; -------------------------------------------------------------------------
0d0587b9
RS		 2267;; This line was a mistake; it is kept now for compatibility.
2268;; rms 15 Oct 98
665211a3
KH		 2269(provide 'archive-mode)
2270
0d0587b9
RS		 2271(provide 'arc-mode)
2272
1cd7adc6 2273;;; arc-mode.el ends here
Unnamed repository; edit this file 'description' to name the repository.