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