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