]> code.delx.au - gnu-emacs/blob - lisp/arc-mode.el
* filelock.c (lock_file): Don't access freed storage.
[gnu-emacs] / lisp / arc-mode.el
1 ;;; arc-mode.el --- simple editing of archives
2
3 ;; Copyright (C) 1995, 1997-1998, 2001-2013 Free Software Foundation,
4 ;; Inc.
5
6 ;; Author: Morten Welinder <terra@gnu.org>
7 ;; Keywords: files archives msdog editing major-mode
8 ;; Favorite-brand-of-beer: None, I hate beer.
9
10 ;; This file is part of GNU Emacs.
11
12 ;; GNU Emacs is free software: you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation, either version 3 of the License, or
15 ;; (at your option) any later version.
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
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24
25 ;;; Commentary:
26
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 ;;
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
59 ;; Save changed member Y Y Y Y N Y
60 ;; Add new member N N N N N N
61 ;; Delete member Y Y Y Y N Y
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
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.
79 ;; Headers come in three flavors called level 0, 1 and 2 headers.
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
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 ;; -------------------------------------
96 ;; HOOKS: `foo' means one of the supported archive types.
97 ;;
98 ;; archive-mode-hook
99 ;; archive-foo-mode-hook
100 ;; archive-extract-hook
101
102 ;;; Code:
103
104 ;; -------------------------------------------------------------------------
105 ;;; Section: Configuration.
106
107 (defgroup archive nil
108 "Simple editing of archives."
109 :group 'data)
110
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
127 (defcustom archive-tmpdir
128 ;; make-temp-name is safe here because we use this name
129 ;; to create a directory.
130 (make-temp-name
131 (expand-file-name (if (eq system-type 'ms-dos) "ar" "archive.tmp")
132 temporary-file-directory))
133 "Directory for temporary files made by `arc-mode.el'."
134 :type 'directory
135 :group 'archive)
136
137 (defcustom archive-remote-regexp "^/[^/:]*[^/:.]:"
138 "Regexp recognizing archive files names that are not local.
139 A non-local file is one whose file name is not proper outside Emacs.
140 A local copy of the archive will be used when updating."
141 :type 'regexp
142 :group 'archive)
143
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."
148 :type 'hook
149 :group 'archive)
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.
155 (defcustom archive-arc-extract
156 '("arc" "x")
157 "Program and its options to run in order to extract an arc file member.
158 Extraction should happen to the current directory. Archive and member
159 name 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
167 '("arc" "d")
168 "Program and its options to run in order to delete arc file members.
169 Archive 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
177 '("arc" "u")
178 "Program and its options to run in order to update an arc file member.
179 Archive 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)
185 ;; ------------------------------
186 ;; Lzh archive configuration
187
188 (defcustom archive-lzh-extract
189 '("lha" "pq")
190 "Program and its options to run in order to extract an lzh file member.
191 Extraction should happen to standard output. Archive and member name will
192 be 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
200 '("lha" "d")
201 "Program and its options to run in order to delete lzh file members.
202 Archive 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
210 '("lha" "a")
211 "Program and its options to run in order to update an lzh file member.
212 Archive 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)
218 ;; ------------------------------
219 ;; Zip archive configuration
220
221 (defcustom archive-zip-extract
222 (cond ((executable-find "unzip") '("unzip" "-qq" "-c"))
223 ((executable-find "7z") '("7z" "x" "-so"))
224 ((executable-find "pkunzip") '("pkunzip" "-e" "-o-"))
225 (t '("unzip" "-qq" "-c")))
226 "Program and its options to run in order to extract a zip file member.
227 Extraction should happen to standard output. Archive and member name will
228 be added."
229 :type '(list (string :tag "Program")
230 (repeat :tag "Options"
231 :inline t
232 (string :format "%v")))
233 :group 'archive-zip)
234
235 ;; For several reasons the latter behavior is not desirable in general.
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
240 (defcustom archive-zip-expunge
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")))
245 "Program and its options to run in order to delete zip file members.
246 Archive and member names will be added."
247 :type '(list (string :tag "Program")
248 (repeat :tag "Options"
249 :inline t
250 (string :format "%v")))
251 :group 'archive-zip)
252
253 (defcustom archive-zip-update
254 (cond ((executable-find "zip") '("zip" "-q"))
255 ((executable-find "7z") '("7z" "u"))
256 ((executable-find "pkzip") '("pkzip" "-u" "-P"))
257 (t '("zip" "-q")))
258 "Program and its options to run in order to update a zip file member.
259 Options should ensure that specified directory will be put into the zip
260 file. Archive and member name will be added."
261 :type '(list (string :tag "Program")
262 (repeat :tag "Options"
263 :inline t
264 (string :format "%v")))
265 :group 'archive-zip)
266
267 (defcustom archive-zip-update-case
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")))
272 "Program and its options to run in order to update a case fiddled zip member.
273 Options should ensure that specified directory will be put into the zip file.
274 Archive and member name will be added."
275 :type '(list (string :tag "Program")
276 (repeat :tag "Options"
277 :inline t
278 (string :format "%v")))
279 :group 'archive-zip)
280
281 (defcustom archive-zip-case-fiddle t
282 "If non-nil then zip file members may be down-cased.
283 This case fiddling will only happen for members created by a system
284 that uses caseless file names."
285 :type 'boolean
286 :group 'archive-zip)
287 ;; ------------------------------
288 ;; Zoo archive configuration
289
290 (defcustom archive-zoo-extract
291 '("zoo" "xpq")
292 "Program and its options to run in order to extract a zoo file member.
293 Extraction should happen to standard output. Archive and member name will
294 be 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
302 '("zoo" "DqPP")
303 "Program and its options to run in order to delete zoo file members.
304 Archive 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
312 '("zoo" "a")
313 "Program and its options to run in order to update a zoo file member.
314 Archive 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)
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.
326 Extraction should happen to standard output. Archive and member name will
327 be added."
328 :version "24.1"
329 :type '(list (string :tag "Program")
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.
338 Archive and member names will be added."
339 :version "24.1"
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.
349 Options should ensure that specified directory will be put into the 7z
350 file. Archive and member name will be added."
351 :version "24.1"
352 :type '(list (string :tag "Program")
353 (repeat :tag "Options"
354 :inline t
355 (string :format "%v")))
356 :group 'archive-7z)
357
358 ;; -------------------------------------------------------------------------
359 ;;; Section: Variables
360
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.")
367 (defvar archive-mode-map
368 (let ((map (make-keymap)))
369 (set-keymap-parent map special-mode-map)
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)
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)
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)
396 ;; Let mouse-1 follow the link.
397 (define-key map [follow-link] 'mouse-face)
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
407 (if (featurep 'xemacs) 'button2 [mouse-2]) 'archive-extract)
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.")
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.")
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
480 (defvar archive-alternate-display nil
481 "Non-nil when alternate information is shown.")
482 (make-variable-buffer-local 'archive-alternate-display)
483 (put 'archive-alternate-display 'permanent-local t)
484
485 (defvar archive-superior-buffer nil "In archive members, points to archive.")
486 (put 'archive-superior-buffer 'permanent-local t)
487
488 (defvar archive-subfile-mode nil "Non-nil in archive member buffers.")
489 (make-variable-buffer-local 'archive-subfile-mode)
490 (put 'archive-subfile-mode 'permanent-local t)
491
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
496 (defvar archive-files nil
497 "Vector of file descriptors.
498 Each descriptor is a vector of the form
499 [EXT-FILE-NAME INT-FILE-NAME CASE-FIDDLED MODE ...]")
500 (make-variable-buffer-local 'archive-files)
501
502 ;; -------------------------------------------------------------------------
503 ;;; Section: Support functions.
504
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)))
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
517 (defsubst archive-name (suffix)
518 (intern (concat "archive-" (symbol-name archive-subtype) "-" suffix)))
519
520 (defun archive-l-e (str &optional len float)
521 "Convert little endian string/vector STR to integer.
522 Alternatively, STR may be a buffer position in the current buffer
523 in which case a second argument, length LEN, should be supplied.
524 FLOAT, if non-nil, means generate and return a float instead of an integer
525 \(use this for numbers that can overflow the Emacs integer)."
526 (if (stringp str)
527 (setq len (length str))
528 (setq str (buffer-substring str (+ str len))))
529 (setq str (string-as-unibyte str))
530 (let ((result 0)
531 (i 0))
532 (while (< i len)
533 (setq i (1+ i)
534 result (+ (if float (* result 256.0) (ash result 8))
535 (aref str (- len i)))))
536 result))
537
538 (defun archive-int-to-mode (mode)
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)))
558
559 (defun archive-calc-mode (oldmode newmode &optional error)
560 "From the integer OLDMODE and the string NEWMODE calculate a new file mode.
561 NEWMODE may be an octal number including a leading zero in which case it
562 will become the new mode.\n
563 NEWMODE may also be a relative specification like \"og-rwx\" in which case
564 OLDMODE will be modified accordingly just like chmod(2) would have done.\n
565 If optional third argument ERROR is non-nil an error will be signaled if
566 the 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))
622 (minute (logand (ash time -5) 63))
623 (second (* 2 (logand time 31)))) ; 2 seconds resolution
624 (format "%02d:%02d:%02d" hour minute second)))
625
626 (defun archive-unixdate (low high)
627 "Stringify Unix (LOW HIGH) date."
628 (let* ((time (cons high low))
629 (str (current-time-string time)))
630 (format "%s-%s-%s"
631 (substring str 8 10)
632 (substring str 4 7)
633 (format-time-string "%Y" time))))
634
635 (defun archive-unixtime (low high)
636 "Stringify Unix (LOW HIGH) time."
637 (let ((str (current-time-string (cons high low))))
638 (substring str 11 19)))
639
640 (defun archive-get-lineno ()
641 (if (>= (point) archive-file-list-start)
642 (count-lines archive-file-list-start
643 (line-beginning-position))
644 0))
645
646 (defun archive-get-descr (&optional noerror)
647 "Return the descriptor vector for file at point.
648 Does not signal an error if optional argument NOERROR is non-nil."
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 ;; -------------------------------------------------------------------------
660 ;;; Section: the mode definition
661
662 ;;;###autoload
663 (defun archive-mode (&optional force)
664 "Major mode for viewing an archive file in a dired-like way.
665 You can move around using the usual cursor motion commands.
666 Letters no longer insert themselves.
667 Type `e' to pull a file out of the archive and into its own buffer;
668 or click mouse-2 on the file's line in the archive mode buffer.
669
670 If you edit a sub-file of this archive (as with the `e' command) and
671 save it, the contents of that buffer will be saved back into the
672 archive.
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
679 (funcall (or (default-value 'major-mode) 'fundamental-mode))
680 (if (and (not force) archive-files) nil
681 (let* ((type (archive-find-type))
682 (typename (capitalize (symbol-name type))))
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)
691
692 ;; Remote archives are not written by a hook.
693 (if archive-remote nil
694 (add-hook 'write-contents-functions 'archive-write-file nil t))
695
696 (make-local-variable 'require-final-newline)
697 (setq require-final-newline nil)
698 (make-local-variable 'local-enable-local-variables)
699 (setq local-enable-local-variables nil)
700
701 ;; Prevent loss of data when saving the file.
702 (make-local-variable 'file-precious-flag)
703 (setq file-precious-flag t)
704
705 (make-local-variable 'archive-read-only)
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
711 (string-match file-name-invalid-regexp
712 (aref archive-subfile-mode 0)))))
713
714 ;; Should we use a local copy when accessing from outside Emacs?
715 (make-local-variable 'archive-local-name)
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))
722 (string-match file-name-invalid-regexp
723 (buffer-file-name)))))
724
725 (setq major-mode 'archive-mode)
726 (setq mode-name (concat typename "-Archive"))
727 ;; Run archive-foo-mode-hook and archive-mode-hook
728 (run-mode-hooks (archive-name "mode-hook") 'archive-mode-hook)
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)
735 (setq archive-file-name-coding-system
736 (or file-name-coding-system
737 default-file-name-coding-system
738 locale-coding-system))
739 (if (default-value 'enable-multibyte-characters)
740 (set-buffer-multibyte 'to))
741 (archive-summarize nil)
742 (setq buffer-read-only t))))
743
744 ;; Archive mode is suitable only for specially formatted data.
745 (put 'archive-mode 'mode-class 'special)
746
747 (let ((item1 '(archive-subfile-mode " Archive")))
748 (or (member item1 minor-mode-alist)
749 (setq minor-mode-alist (cons item1 minor-mode-alist))))
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)
757 (cond ((looking-at "\\(PK00\\)?[P]K\003\004") 'zip)
758 ((looking-at "..-l[hz][0-9ds]-") 'lzh)
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)
764 ;; This pattern modeled on the BSD/GNU+Linux `file' command.
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)
768 ((looking-at "Rar!") 'rar)
769 ((looking-at "!<arch>\n") 'ar)
770 ((and (looking-at "MZ")
771 (re-search-forward "Rar!" (+ (point) 100000) t))
772 'rar-exe)
773 ((looking-at "7z\274\257\047\034") '7z)
774 (t (error "Buffer format not recognized")))))
775 ;; -------------------------------------------------------------------------
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
785 (defun archive-summarize (&optional shut-up)
786 "Parse the contents of the archive file in the current buffer.
787 Place a dired-like listing on the front;
788 then narrow to it, so that only that listing
789 is visible (and the real data of the buffer is hidden).
790 Optional argument SHUT-UP, if non-nil, means don't print messages
791 when parsing the archive."
792 (widen)
793 (let ((buffer-file-truename nil) ; avoid changing dir mtime by lock_file
794 (inhibit-read-only t))
795 (setq archive-proper-file-start (copy-marker (point-min) t))
796 (set (make-local-variable 'change-major-mode-hook) 'archive-desummarize)
797 (or shut-up
798 (message "Parsing archive file..."))
799 (buffer-disable-undo (current-buffer))
800 (setq archive-files (funcall (archive-name "summarize")))
801 (or shut-up
802 (message "Parsing archive file...done."))
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."
812 (let ((no (archive-get-lineno)))
813 (archive-desummarize)
814 (archive-summarize t)
815 (goto-char archive-file-list-start)
816 (archive-next-line no)))
817
818 (defun archive-summarize-files (files)
819 "Insert a description of a list of files annotated with proper mouse face."
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
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))
840 files)))
841 (setq archive-file-list-end (point-marker)))
842
843 (defun archive-alternate-display ()
844 "Toggle alternative display.
845 To avoid very long lines archive mode does not show all information.
846 This function changes the set of information shown for each files."
847 (interactive)
848 (setq archive-alternate-display (not archive-alternate-display))
849 (archive-resummarize))
850 ;; -------------------------------------------------------------------------
851 ;;; Section: Local archive copy handling
852
853 (defun archive-unique-fname (fname dir)
854 "Make sure a file FNAME can be created uniquely in directory DIR.
855
856 If FNAME can be uniquely created in DIR, it is returned unaltered.
857 If FNAME is something our underlying filesystem can't grok, or if another
858 file by that name already exists in DIR, a unique new name is generated
859 using `make-temp-file', and the generated name is returned."
860 (let ((fullname (expand-file-name fname dir))
861 (alien (string-match file-name-invalid-regexp fname))
862 (tmpfile
863 (expand-file-name
864 (if (if (fboundp 'msdos-long-file-names)
865 (not (msdos-long-file-names)))
866 "am"
867 "arc-mode.")
868 dir)))
869 (if (or alien (file-exists-p fullname))
870 (progn
871 ;; Make sure all the leading directories in
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))
877 ;; Make sure all the leading directories in `fullname' exist
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)
882 fullname)))
883
884 (defun archive-maybe-copy (archive)
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)))
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)))
904
905 (defun archive-maybe-update (unchanged)
906 (if archive-remote
907 (let ((name archive-local-name)
908 (modified (buffer-modified-p))
909 (coding-system-for-read 'no-conversion)
910 (lno (archive-get-lineno))
911 (inhibit-read-only t))
912 (if unchanged nil
913 (setq archive-files nil)
914 (erase-buffer)
915 (insert-file-contents name)
916 (archive-mode t)
917 (goto-char archive-file-list-start)
918 (archive-next-line lno))
919 (archive-delete-local name)
920 (if (not unchanged)
921 (message
922 "Buffer `%s' must be saved for changes to take effect"
923 (buffer-name (current-buffer))))
924 (set-buffer-modified-p (or modified (not unchanged))))))
925
926 (defun archive-delete-local (name)
927 "Delete file NAME and its parents up to and including `archive-tmpdir'."
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 ;; -------------------------------------------------------------------------
940 ;;; Section: Member extraction
941
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
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))
971 (let ((buffer-undo-list t)
972 (coding
973 (or coding-system-for-read
974 (and set-auto-coding-function
975 (save-excursion
976 (funcall set-auto-coding-function
977 filename (- (point-max) (point-min)))))
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).
981 (let ((file-name-handler-alist
982 '(("" . archive-file-name-handler))))
983 (car (find-operation-coding-system
984 'insert-file-contents
985 (cons filename (current-buffer)) t))))))
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)
992 (setq last-coding-system-used coding))
993 (set-buffer-modified-p nil)
994 (kill-local-variable 'buffer-file-coding-system)
995 (after-insert-file-set-coding (- (point-max) (point-min))))))
996
997 (define-obsolete-function-alias 'archive-mouse-extract 'archive-extract "22.1")
998
999 (defun archive-extract (&optional other-window-p event)
1000 "In archive mode, extract this entry of the archive into its own buffer."
1001 (interactive (list nil last-input-event))
1002 (if event (posn-set-point (event-end event)))
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"))
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
1017 (string-match file-name-invalid-regexp ename)))
1018 (arcfilename (expand-file-name (concat arcname ":" iname)))
1019 (buffer (get-buffer bufname))
1020 (just-created nil)
1021 (file-name-coding archive-file-name-coding-system))
1022 (if (and buffer
1023 (string= (buffer-file-name buffer) arcfilename))
1024 nil
1025 (setq archive (archive-maybe-copy archive))
1026 (setq bufname (generate-new-buffer-name bufname))
1027 (setq buffer (get-buffer-create bufname))
1028 (setq just-created t)
1029 (with-current-buffer buffer
1030 (setq buffer-file-name arcfilename)
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)
1037 (add-hook 'write-file-functions 'archive-write-file-member nil t)
1038 (setq archive-subfile-mode descr)
1039 (setq archive-file-name-coding-system file-name-coding)
1040 (if (and
1041 (null
1042 (let (;; We may have to encode the file name argument for
1043 ;; external programs.
1044 (coding-system-for-write
1045 (and enable-multibyte-characters
1046 archive-file-name-coding-system))
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))))
1059 just-created)
1060 (progn
1061 (set-buffer-modified-p nil)
1062 (kill-buffer buffer))
1063 (archive-try-jka-compr) ;Pretty ugly hack :-(
1064 (archive-set-buffer-as-visiting-file ename)
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.
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))
1079 (run-hooks 'archive-extract-hook)
1080 (if archive-read-only
1081 (message "Note: altering this archive is not implemented."))))
1082 (archive-maybe-update t))
1083 (or (not (buffer-name buffer))
1084 (cond
1085 (view-p
1086 (view-buffer buffer (and just-created 'kill-buffer-if-not-modified)))
1087 ((eq other-window-p 'display) (display-buffer buffer))
1088 (other-window-p (switch-to-buffer-other-window buffer))
1089 (t (switch-to-buffer buffer))))))
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)
1094 default-directory))
1095 exit-status success)
1096 (make-directory (directory-file-name default-directory) t)
1097 (setq exit-status
1098 (apply 'call-process
1099 (car command)
1100 nil
1101 nil
1102 nil
1103 (append (cdr command) (list archive name))))
1104 (cond ((and (numberp exit-status) (zerop exit-status))
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))
1118
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))))
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)
1184 "Add current buffer to the archive in ARCBUF naming it NAME."
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)))
1190 (while (and bufs
1191 (not (with-current-buffer (car bufs)
1192 (derived-mode-p 'archive-mode))))
1193 (setq bufs (cdr bufs)))
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 ""))))
1202 (with-current-buffer arcbuf
1203 (or (derived-mode-p 'archive-mode)
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"))
1211 (let ((func (with-current-buffer arcbuf
1212 (archive-name "add-new-member")))
1213 (membuf (current-buffer)))
1214 (if (fboundp func)
1215 (with-current-buffer arcbuf
1216 (funcall func buffer-file-name membuf name))
1217 (error "Adding a new member is not supported for this archive type"))))
1218 ;; -------------------------------------------------------------------------
1219 ;;; Section: IO stuff
1220
1221 (defun archive-write-file-member ()
1222 (save-excursion
1223 (save-restriction
1224 (message "Updating archive...")
1225 (widen)
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)))))
1230 (if (fboundp writer)
1231 (funcall writer archive archive-subfile-mode)
1232 (archive-*-write-file-member archive
1233 archive-subfile-mode
1234 (symbol-value writer)))
1235 (set-buffer-modified-p nil)
1236 (message "Updating archive...done"))
1237 (set-buffer archive-superior-buffer)
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)
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)
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)
1257 (write-region nil nil tmpfile nil 'nomessage))
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)
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))))
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)))))
1276 (or (zerop exitcode)
1277 (error "Updating was unsuccessful (%S)" exitcode))))
1278 (archive-delete-local tmpfile))))
1279
1280 (defun archive-write-file (&optional file)
1281 (save-excursion
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))
1286 t))
1287 ;; -------------------------------------------------------------------------
1288 ;;; Section: Marking and unmarking.
1289
1290 (defun archive-flag-deleted (p &optional type)
1291 "In archive mode, mark this member to be deleted from the archive.
1292 With 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))
1298 (inhibit-read-only t))
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)))
1306 (restore-buffer-modified-p modified))
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.
1311 With a prefix argument, un-mark that many files forward."
1312 (interactive "p")
1313 (archive-flag-deleted p ?\s))
1314
1315 (defun archive-unflag-backwards (p)
1316 "In archive mode, un-mark this member if it is marked to be deleted.
1317 With a prefix argument, un-mark that many members backward."
1318 (interactive "p")
1319 (archive-flag-deleted (- p) ?\s))
1320
1321 (defun archive-unmark-all-files ()
1322 "Remove all marks."
1323 (interactive)
1324 (let ((modified (buffer-modified-p))
1325 (inhibit-read-only t))
1326 (save-excursion
1327 (goto-char archive-file-list-start)
1328 (while (< (point) archive-file-list-end)
1329 (or (= (following-char) ?\s)
1330 (progn (delete-char 1) (insert ?\s)))
1331 (forward-line 1)))
1332 (restore-buffer-modified-p modified)))
1333
1334 (defun archive-mark (p)
1335 "In archive mode, mark this member for group operations.
1336 With a prefix argument, mark that many members.
1337 Use \\[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 ;; -------------------------------------------------------------------------
1353 ;;; Section: Operate
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)
1366 "Change the protection bits associated with all marked or this member.
1367 The new protection bits can either be specified as an octal number or
1368 as a relative change like \"g+rw\" as for chmod(2)."
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)
1437 "Change the name associated with this entry in the archive file."
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
1446 (funcall func
1447 (encode-coding-string newname
1448 archive-file-name-coding-system)
1449 descr)
1450 (archive-resummarize))
1451 (error "Renaming is not supported for this archive type"))))
1452
1453 ;; Revert the buffer and recompute the dired-like listing.
1454 (defun archive-mode-revert (&optional _no-auto-save _no-confirm)
1455 (let ((no (archive-get-lineno)))
1456 (setq archive-files nil)
1457 (let ((revert-buffer-function nil)
1458 (coding-system-for-read 'no-conversion))
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.
1466 This doesn't recover lost files, it just undoes changes in the buffer itself."
1467 (interactive)
1468 (let ((inhibit-read-only t))
1469 (undo)))
1470 ;; -------------------------------------------------------------------------
1471 ;;; Section: Arc Archives
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))
1480 (= (byte-after p) ?\C-z)
1481 (> (byte-after (1+ p)) 0))
1482 (let* ((namefld (buffer-substring (+ p 2) (+ p 2 13)))
1483 (fnlen (or (string-match "\0" namefld) 13))
1484 (efnname (decode-coding-string (substring namefld 0 fnlen)
1485 archive-file-name-coding-system))
1486 ;; Convert to float to avoid overflow for very large files.
1487 (csize (archive-l-e (+ p 15) 4 'float))
1488 (moddate (archive-l-e (+ p 19) 2))
1489 (modtime (archive-l-e (+ p 21) 2))
1490 (ucsize (archive-l-e (+ p 25) 4 'float))
1491 (fiddle (string= efnname (upcase efnname)))
1492 (ifnname (if fiddle (downcase efnname) efnname))
1493 (text (format " %8.0f %-11s %-8s %s"
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)
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)))))
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
1519 (format " %8.0f %d file%s"
1520 totalsize
1521 (length files)
1522 (if (= 1 (length files)) "" "s"))
1523 "\n"))
1524 (apply 'vector (nreverse files))))
1525
1526 (defun archive-arc-rename-entry (newname descr)
1527 (if (string-match "[:\\\\/]" newname)
1528 (error "File names in arc files must not contain a directory component"))
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))))
1533 (inhibit-read-only t))
1534 (save-restriction
1535 (save-excursion
1536 (widen)
1537 (goto-char (+ archive-proper-file-start (aref descr 4) 2))
1538 (delete-char 13)
1539 (insert-unibyte name)))))
1540 ;; -------------------------------------------------------------------------
1541 ;;; Section: Lzh Archives
1542
1543 (defun archive-lzh-summarize (&optional start)
1544 (let ((p (or start 1)) ;; 1 for .lzh, something further on for .exe
1545 (totalsize 0)
1546 (maxlen 8)
1547 files
1548 visual)
1549 (while (progn (goto-char p) ;beginning of a base header.
1550 (looking-at "\\(.\\|\n\\)\\(.\\|\n\\)-l[hz][0-9ds]-"))
1551 (let* ((hsize (byte-after p)) ;size of the base header (level 0 and 1)
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),
1554 ;size of extended headers + the compressed file to follow (level 1).
1555 (ucsize (archive-l-e (+ p 11) 4 'float)) ;size of an uncompressed file.
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.)
1558 (hdrlvl (byte-after (+ p 20))) ;header level
1559 thsize ;total header size (base + extensions)
1560 fnlen efnname osid fiddle ifnname width p2
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))
1566 (setq fnlen (byte-after (+ p 21))) ;filename length
1567 (setq efnname (let ((str (buffer-substring (+ p 22) (+ p 22 fnlen)))) ;filename from offset 22
1568 (decode-coding-string
1569 str archive-file-name-coding-system)))
1570 (setq p2 (+ p 22 fnlen))) ;
1571 (if (= hdrlvl 1)
1572 (setq neh (+ p2 3)) ;specific to level 1 header
1573 (if (= hdrlvl 2)
1574 (setq neh (+ p 24)))) ;specific to level 2 header
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
1577 (etype (byte-after (+ neh 2)))) ;extension type
1578 (while (not (= ehsize 0))
1579 (cond
1580 ((= etype 1) ;file name
1581 (let ((i (+ neh 3)))
1582 (while (< i (+ neh ehsize))
1583 (setq efnname (concat efnname (char-to-string (byte-after i))))
1584 (setq i (1+ i)))))
1585 ((= etype 2) ;directory name
1586 (let ((i (+ neh 3)))
1587 (while (< i (+ neh ehsize))
1588 (setq dir (concat dir
1589 (if (= (byte-after i)
1590 255)
1591 "/"
1592 (char-to-string
1593 (char-after i)))))
1594 (setq i (1+ i)))))
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)))))
1610 )
1611 (setq neh (+ neh ehsize))
1612 (setq ehsize (archive-l-e neh 2))
1613 (setq etype (byte-after (+ neh 2))))
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))
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)))))
1634 (setq ifnname (if fiddle (downcase efnname) efnname))
1635 (setq prname (if dir (concat dir ifnname) ifnname))
1636 (setq width (if prname (string-width prname) 0))
1637 (setq modestr (if mode (archive-int-to-mode mode) "??????????"))
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)))
1644 (setq text (if archive-alternate-display
1645 (format " %8.0f %5S %5S %s"
1646 ucsize
1647 (or uid "?")
1648 (or gid "?")
1649 ifnname)
1650 (format " %10s %8.0f %-11s %-8s %s"
1651 modestr
1652 ucsize
1653 moddate
1654 modtime
1655 prname)))
1656 (setq maxlen (max maxlen width)
1657 totalsize (+ totalsize ucsize)
1658 visual (cons (vector text
1659 (- (length text) (length prname))
1660 (length text))
1661 visual)
1662 files (cons (vector prname ifnname fiddle mode (1- p))
1663 files))
1664 (cond ((= hdrlvl 1)
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))))
1670 ((or (= hdrlvl 2) (= hdrlvl 0))
1671 (setq p (+ p thsize 2 (round csize)))))
1672 ))
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
1683 " %8.0f %d file%s"
1684 " %8.0f %d file%s")))
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)
1704 sum (+ sum (byte-after p))
1705 p (1+ p)))
1706 (logand sum 255)))
1707
1708 (defun archive-lzh-rename-entry (newname descr)
1709 (save-restriction
1710 (save-excursion
1711 (widen)
1712 (let* ((p (+ archive-proper-file-start (aref descr 4)))
1713 (oldhsize (byte-after p))
1714 (oldfnlen (byte-after (+ p 21)))
1715 (newfnlen (length newname))
1716 (newhsize (+ oldhsize newfnlen (- oldfnlen)))
1717 (inhibit-read-only t))
1718 (if (> newhsize 255)
1719 (error "The file name is too long"))
1720 (goto-char (+ p 21))
1721 (delete-char (1+ oldfnlen))
1722 (insert-unibyte newfnlen newname)
1723 (goto-char p)
1724 (delete-char 2)
1725 (insert-unibyte newhsize (archive-lzh-resum p newhsize))))))
1726
1727 (defun archive-lzh-ogm (newval files errtxt ofs)
1728 (save-excursion
1729 (save-restriction
1730 (widen)
1731 (dolist (fil files)
1732 (let* ((p (+ archive-proper-file-start (aref fil 4)))
1733 (hsize (byte-after p))
1734 (fnlen (byte-after (+ p 21)))
1735 (p2 (+ p 22 fnlen))
1736 (creator (if (>= (- hsize fnlen) 24) (byte-after (+ p2 2)) 0))
1737 (inhibit-read-only t))
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)
1744 (insert-unibyte (logand newval 255) (lsh newval -8))
1745 (goto-char (1+ p))
1746 (delete-char 1)
1747 (insert-unibyte (archive-lzh-resum (1+ p) hsize)))
1748 (message "Member %s does not have %s field"
1749 (aref fil 1) errtxt)))))))
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.
1760 (lambda (old) (archive-calc-mode old newmode t))
1761 files "a unix-style mode" 8))
1762
1763 ;; -------------------------------------------------------------------------
1764 ;;; Section: Lzh Self-Extracting .exe Archives
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
1790 ;; -------------------------------------------------------------------------
1791 ;;; Section: Zip Archives
1792
1793 (defun archive-zip-summarize ()
1794 (goto-char (- (point-max) (- 22 18)))
1795 (search-backward-regexp "[P]K\005\006")
1796 (let ((p (+ (point-min) (archive-l-e (+ (point) 16) 4)))
1797 (maxlen 8)
1798 (totalsize 0)
1799 files
1800 visual)
1801 (while (string= "PK\001\002" (buffer-substring p (+ p 4)))
1802 (let* ((creator (byte-after (+ p 5)))
1803 ;; (method (archive-l-e (+ p 10) 2))
1804 (modtime (archive-l-e (+ p 12) 2))
1805 (moddate (archive-l-e (+ p 14) 2))
1806 ;; Convert to float to avoid overflow for very large files.
1807 (ucsize (archive-l-e (+ p 24) 4 'float))
1808 (fnlen (archive-l-e (+ p 28) 2))
1809 (exlen (archive-l-e (+ p 30) 2))
1810 (fclen (archive-l-e (+ p 32) 2))
1811 (lheader (archive-l-e (+ p 42) 4))
1812 (efnname (let ((str (buffer-substring (+ p 46) (+ p 46 fnlen))))
1813 (decode-coding-string
1814 str archive-file-name-coding-system)))
1815 (isdir (and (= ucsize 0)
1816 (string= (file-name-nondirectory efnname) "")))
1817 (mode (cond ((memq creator '(2 3)) ; Unix
1818 (archive-l-e (+ p 40) 2))
1819 ((memq creator '(0 5 6 7 10 11 15)) ; Dos etc.
1820 (logior ?\444
1821 (if isdir (logior 16384 ?\111) 0)
1822 (if (zerop
1823 (logand 1 (byte-after (+ p 38))))
1824 ?\222 0)))
1825 (t nil)))
1826 (modestr (if mode (archive-int-to-mode mode) "??????????"))
1827 (fiddle (and archive-zip-case-fiddle
1828 (not (not (memq creator '(0 2 4 5 9))))
1829 (string= (upcase efnname) efnname)))
1830 (ifnname (if fiddle (downcase efnname) efnname))
1831 (width (string-width ifnname))
1832 (text (format " %10s %8.0f %-11s %-8s %s"
1833 modestr
1834 ucsize
1835 (archive-dosdate moddate)
1836 (archive-dostime modtime)
1837 ifnname)))
1838 (setq maxlen (max maxlen width)
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)
1849 p (+ p 46 fnlen exlen fclen))))
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
1858 (format " %8.0f %d file%s"
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)
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
1873 (archive-extract-by-stdout
1874 archive
1875 ;; unzip expands wildcards in NAME, so we need to quote it. But
1876 ;; not on DOS/Windows, since that fails extraction on those
1877 ;; systems (unless w32-quote-process-args is nil), and file names
1878 ;; with wildcards in zip archives don't work there anyway.
1879 ;; FIXME: Does pkunzip need similar treatment?
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)))
1883 (equal (car archive-zip-extract) "unzip"))
1884 (shell-quote-argument name)
1885 name)
1886 archive-zip-extract))))
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)
1898 (dolist (fil files)
1899 (let* ((p (+ archive-proper-file-start (car (aref fil 4))))
1900 (creator (byte-after (+ p 5)))
1901 (oldmode (aref fil 3))
1902 (newval (archive-calc-mode oldmode newmode t))
1903 (inhibit-read-only t))
1904 (cond ((memq creator '(2 3)) ; Unix
1905 (goto-char (+ p 40))
1906 (delete-char 2)
1907 (insert-unibyte (logand newval 255) (lsh newval -8)))
1908 ((memq creator '(0 5 6 7 10 11 15)) ; Dos etc.
1909 (goto-char (+ p 38))
1910 (insert-unibyte (logior (logand (byte-after (point)) 254)
1911 (logand (logxor 1 (lsh newval -7)) 1)))
1912 (delete-char 1))
1913 (t (message "Don't know how to change mode for this member"))))
1914 ))))
1915 ;; -------------------------------------------------------------------------
1916 ;;; Section: Zoo Archives
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))
1929 ;; Convert to float to avoid overflow for very large files.
1930 (ucsize (archive-l-e (+ p 20) 4 'float))
1931 (namefld (buffer-substring (+ p 38) (+ p 38 13)))
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))
1935 (fnlen (or (string-match "\0" namefld) 13))
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)))))
1948 (decode-coding-string
1949 str archive-file-name-coding-system)))
1950 (fiddle (and (= lfnlen 0) (string= efnname (upcase efnname))))
1951 (ifnname (if fiddle (downcase efnname) efnname))
1952 (width (string-width ifnname))
1953 (text (format " %8.0f %-11s %-8s %s"
1954 ucsize
1955 (archive-dosdate moddate)
1956 (archive-dostime modtime)
1957 ifnname)))
1958 (setq maxlen (max maxlen width)
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
1975 (format " %8.0f %d file%s"
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))
1984
1985 ;; -------------------------------------------------------------------------
1986 ;;; Section: Rar Archives
1987
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))
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")
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.
2006 " +\\([0-9:]+\\) +[^ \n]\\{6,10\\}"
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))
2019 files))))
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")
2049 (archive-extract-by-file archive name '("unrar-free" "--extract") "All OK")))
2050
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))))
2083
2084 ;; -------------------------------------------------------------------------
2085 ;;; Section: 7z Archives
2086
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))
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")
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)
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"))
2137
2138 (defun archive-7z-write-file-member (archive descr)
2139 (archive-*-write-file-member
2140 archive
2141 descr
2142 archive-7z-update))
2143
2144 ;; -------------------------------------------------------------------------
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))
2169 extname
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))
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)))
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.
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))))))
2263
2264 ;; -------------------------------------------------------------------------
2265 ;; This line was a mistake; it is kept now for compatibility.
2266 ;; rms 15 Oct 98
2267 (provide 'archive-mode)
2268
2269 (provide 'arc-mode)
2270
2271 ;;; arc-mode.el ends here