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