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