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