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