Mercurial > emacs
annotate lisp/arc-mode.el @ 24419:30e478cd167e
(shell-command-default-error-buffer): Renamed from
shell-command-on-region-default-error-buffer.
(shell-command-on-region): Mention in echo area when there
is some error output. Mention success or failure, too.
Accumulate multiple error outputs
going forward, with formfeed in between. Display the error buffer
when we have put something in it.
(shell-command): Add the ERROR-BUFFER argument feature.
author | Karl Heuer <kwzh@gnu.org> |
---|---|
date | Mon, 01 Mar 1999 03:19:32 +0000 |
parents | b3c0f3ad64d8 |
children | 0a8d7e789bca |
rev | line source |
---|---|
11880 | 1 ;;; arc-mode.el --- simple editing of archives |
2 | |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
3 ;; Copyright (C) 1995, 1997, 1998 Free Software Foundation, Inc. |
11880 | 4 |
17977 | 5 ;; Author: Morten Welinder <terra@diku.dk> |
11880 | 6 ;; Keywords: archives msdog editing major-mode |
7 ;; Favourite-brand-of-beer: None, I hate beer. | |
8 | |
14169 | 9 ;; This file is part of GNU Emacs. |
10 | |
11 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
12 ;; it under the terms of the GNU General Public License as published by | |
13 ;; the Free Software Foundation; either version 2, or (at your option) | |
14 ;; any later version. | |
15 | |
16 ;; GNU Emacs is distributed in the hope that it will be useful, | |
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 ;; GNU General Public License for more details. | |
20 | |
21 ;; You should have received a copy of the GNU General Public License | |
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
24 ;; Boston, MA 02111-1307, USA. | |
11880 | 25 |
26 ;;; Commentary: | |
14169 | 27 |
11880 | 28 ;; NAMING: "arc" is short for "archive" and does not refer specifically |
29 ;; to files whose name end in ".arc" | |
30 ;; | |
31 ;; This code does not decode any files internally, although it does | |
32 ;; understand the directory level of the archives. For this reason, | |
33 ;; you should expect this code to need more fiddling than tar-mode.el | |
34 ;; (although it at present has fewer bugs :-) In particular, I have | |
35 ;; not tested this under Ms-Dog myself. | |
36 ;; ------------------------------------- | |
37 ;; INTERACTION: arc-mode.el should play together with | |
38 ;; | |
39 ;; * ange-ftp.el: Remote archives (i.e., ones that ange-ftp has brought | |
40 ;; to you) are handled by doing all updates on a local | |
41 ;; copy. When you make changes to a remote file the | |
42 ;; changes will first take effect when the archive buffer | |
43 ;; is saved. You will be warned about this. | |
44 ;; | |
45 ;; * dos-fns.el: (Part of Emacs 19). You get automatic ^M^J <--> ^J | |
46 ;; conversion. | |
47 ;; | |
48 ;; arc-mode.el does not work well with crypt++.el; for the archives as | |
49 ;; such this could be fixed (but wouldn't be useful) by declaring such | |
50 ;; archives to be "remote". For the members this is a general Emacs | |
51 ;; problem that 19.29's file formats may fix. | |
52 ;; ------------------------------------- | |
53 ;; ARCHIVE TYPES: Currently only the archives below are handled, but the | |
54 ;; structure for handling just about anything is in place. | |
55 ;; | |
56 ;; Arc Lzh Zip Zoo | |
57 ;; -------------------------------- | |
58 ;; View listing Intern Intern Intern Intern | |
59 ;; Extract member Y Y Y Y | |
60 ;; Save changed member Y Y Y Y | |
61 ;; Add new member N N N N | |
62 ;; Delete member Y Y Y Y | |
63 ;; Rename member Y Y N N | |
64 ;; Chmod - Y Y - | |
65 ;; Chown - Y - - | |
66 ;; Chgrp - Y - - | |
67 ;; | |
68 ;; Special thanks to Bill Brodie <wbrodie@panix.com> for very useful tips | |
69 ;; on the first released version of this package. | |
70 ;; | |
71 ;; This code is partly based on tar-mode.el from Emacs. | |
72 ;; ------------------------------------- | |
73 ;; ARCHIVE STRUCTURES: | |
74 ;; (This is mostly for myself.) | |
75 ;; | |
76 ;; ARC A series of (header,file). No interactions among members. | |
77 ;; | |
78 ;; LZH A series of (header,file). Headers are checksummed. No | |
79 ;; interaction among members. | |
80 ;; | |
81 ;; ZIP A series of (lheader,fil) followed by a "central directory" | |
82 ;; which is a series of (cheader) followed by an end-of- | |
83 ;; central-dir record possibly followed by junk. The e-o-c-d | |
84 ;; links to c-d. cheaders link to lheaders which are basically | |
85 ;; cut-down versions of the cheaders. | |
86 ;; | |
87 ;; ZOO An archive header followed by a series of (header,file). | |
88 ;; Each member header points to the next. The archive is | |
89 ;; terminated by a bogus header with a zero next link. | |
90 ;; ------------------------------------- | |
91 ;; HOOKS: `foo' means one the the supported archive types. | |
92 ;; | |
93 ;; archive-mode-hook | |
94 ;; archive-foo-mode-hook | |
95 ;; archive-extract-hooks | |
96 | |
97 ;;; Code: | |
98 | |
99 ;; ------------------------------------------------------------------------- | |
100 ;; Section: Configuration. | |
101 | |
19926 | 102 (defgroup archive nil |
103 "Simple editing of archives." | |
104 :group 'data) | |
105 | |
106 (defgroup archive-arc nil | |
107 "ARC-specific options to archive." | |
108 :group 'archive) | |
109 | |
110 (defgroup archive-lzh nil | |
111 "LZH-specific options to archive." | |
112 :group 'archive) | |
11880 | 113 |
19926 | 114 (defgroup archive-zip nil |
115 "ZIP-specific options to archive." | |
116 :group 'archive) | |
117 | |
118 (defgroup archive-zoo nil | |
119 "ZOO-specific options to archive." | |
120 :group 'archive) | |
121 | |
122 (defcustom archive-tmpdir | |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
123 (make-temp-name |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
124 (expand-file-name (if (eq system-type 'ms-dos) "ar" "archive.tmp") |
22096
2f9cb89376a6
(archive-tmpdir): Use temporary-file-directory.
Richard M. Stallman <rms@gnu.org>
parents:
22086
diff
changeset
|
125 temporary-file-directory)) |
19926 | 126 "*Directory for temporary files made by arc-mode.el" |
127 :type 'directory | |
128 :group 'archive) | |
11880 | 129 |
19926 | 130 (defcustom archive-remote-regexp "^/[^/:]*[^/:.]:" |
12791
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
131 "*Regexp recognizing archive files names that are not local. |
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
132 A non-local file is one whose file name is not proper outside Emacs. |
19926 | 133 A local copy of the archive will be used when updating." |
134 :type 'regexp | |
135 :group 'archive) | |
11880 | 136 |
19926 | 137 (defcustom archive-extract-hooks nil |
138 "*Hooks to run when an archive member has been extracted." | |
139 :type 'hook | |
140 :group 'archive) | |
11880 | 141 ;; ------------------------------ |
142 ;; Arc archive configuration | |
143 | |
144 ;; We always go via a local file since there seems to be no reliable way | |
145 ;; to extract to stdout without junk getting added. | |
19926 | 146 (defcustom archive-arc-extract |
11880 | 147 '("arc" "x") |
12791
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
148 "*Program and its options to run in order to extract an arc file member. |
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
149 Extraction should happen to the current directory. Archive and member |
19926 | 150 name will be added." |
151 :type '(list (string :tag "Program") | |
152 (repeat :tag "Options" | |
153 :inline t | |
154 (string :format "%v"))) | |
155 :group 'archive-arc) | |
11880 | 156 |
19926 | 157 (defcustom archive-arc-expunge |
11880 | 158 '("arc" "d") |
159 "*Program and its options to run in order to delete arc file members. | |
19926 | 160 Archive and member names will be added." |
161 :type '(list (string :tag "Program") | |
162 (repeat :tag "Options" | |
163 :inline t | |
164 (string :format "%v"))) | |
165 :group 'archive-arc) | |
11880 | 166 |
19926 | 167 (defcustom archive-arc-write-file-member |
11880 | 168 '("arc" "u") |
169 "*Program and its options to run in order to update an arc file member. | |
19926 | 170 Archive and member name will be added." |
171 :type '(list (string :tag "Program") | |
172 (repeat :tag "Options" | |
173 :inline t | |
174 (string :format "%v"))) | |
175 :group 'archive-arc) | |
11880 | 176 ;; ------------------------------ |
177 ;; Lzh archive configuration | |
178 | |
19926 | 179 (defcustom archive-lzh-extract |
11880 | 180 '("lha" "pq") |
12791
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
181 "*Program and its options to run in order to extract an lzh file member. |
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
182 Extraction should happen to standard output. Archive and member name will |
19926 | 183 be added." |
184 :type '(list (string :tag "Program") | |
185 (repeat :tag "Options" | |
186 :inline t | |
187 (string :format "%v"))) | |
188 :group 'archive-lzh) | |
11880 | 189 |
19926 | 190 (defcustom archive-lzh-expunge |
11880 | 191 '("lha" "d") |
192 "*Program and its options to run in order to delete lzh file members. | |
19926 | 193 Archive and member names will be added." |
194 :type '(list (string :tag "Program") | |
195 (repeat :tag "Options" | |
196 :inline t | |
197 (string :format "%v"))) | |
198 :group 'archive-lzh) | |
11880 | 199 |
19926 | 200 (defcustom archive-lzh-write-file-member |
11880 | 201 '("lha" "a") |
202 "*Program and its options to run in order to update an lzh file member. | |
19926 | 203 Archive and member name will be added." |
204 :type '(list (string :tag "Program") | |
205 (repeat :tag "Options" | |
206 :inline t | |
207 (string :format "%v"))) | |
208 :group 'archive-lzh) | |
11880 | 209 ;; ------------------------------ |
210 ;; Zip archive configuration | |
211 | |
19926 | 212 (defcustom archive-zip-use-pkzip (memq system-type '(ms-dos windows-nt)) |
12791
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
213 "*If non-nil then pkzip option are used instead of zip options. |
19926 | 214 Only set to true for msdog systems!" |
215 :type 'boolean | |
216 :group 'archive-zip) | |
11880 | 217 |
19926 | 218 (defcustom archive-zip-extract |
21570
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
219 (if archive-zip-use-pkzip '("pkunzip" "-e" "-o-") '("unzip" "-qq" "-c")) |
12791
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
220 "*Program and its options to run in order to extract a zip file member. |
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
221 Extraction should happen to standard output. Archive and member name will |
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
222 be added. If `archive-zip-use-pkzip' is non-nil then this program is |
19926 | 223 expected to extract to a file junking the directory part of the name." |
224 :type '(list (string :tag "Program") | |
225 (repeat :tag "Options" | |
226 :inline t | |
227 (string :format "%v"))) | |
228 :group 'archive-zip) | |
11880 | 229 |
13966
82eeef849f8b
(archive-summarize-files): Doc fix.
Karl Heuer <kwzh@gnu.org>
parents:
13539
diff
changeset
|
230 ;; For several reasons the latter behaviour is not desirable in general. |
11880 | 231 ;; (1) It uses more disk space. (2) Error checking is worse or non- |
232 ;; existent. (3) It tends to do funny things with other systems' file | |
233 ;; names. | |
234 | |
19926 | 235 (defcustom archive-zip-expunge |
11880 | 236 (if archive-zip-use-pkzip '("pkzip" "-d") '("zip" "-d" "-q")) |
237 "*Program and its options to run in order to delete zip file members. | |
19926 | 238 Archive and member names will be added." |
239 :type '(list (string :tag "Program") | |
240 (repeat :tag "Options" | |
241 :inline t | |
242 (string :format "%v"))) | |
243 :group 'archive-zip) | |
11880 | 244 |
19926 | 245 (defcustom archive-zip-update |
11880 | 246 (if archive-zip-use-pkzip '("pkzip" "-u") '("zip" "-q")) |
247 "*Program and its options to run in order to update a zip file member. | |
248 Options should ensure that specified directory will be put into the zip | |
19926 | 249 file. Archive and member name will be added." |
250 :type '(list (string :tag "Program") | |
251 (repeat :tag "Options" | |
252 :inline t | |
253 (string :format "%v"))) | |
254 :group 'archive-zip) | |
11880 | 255 |
19926 | 256 (defcustom archive-zip-update-case |
11880 | 257 (if archive-zip-use-pkzip archive-zip-update '("zip" "-q" "-k")) |
12791
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
258 "*Program and its options to run in order to update a case fiddled zip member. |
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
259 Options should ensure that specified directory will be put into the zip file. |
19926 | 260 Archive and member name will be added." |
261 :type '(list (string :tag "Program") | |
262 (repeat :tag "Options" | |
263 :inline t | |
264 (string :format "%v"))) | |
265 :group 'archive-zip) | |
11880 | 266 |
19926 | 267 (defcustom archive-zip-case-fiddle t |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
268 "*If non-nil then zip file members may be down-cased. |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
269 This case fiddling will only happen for members created by a system |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
270 that uses caseless file names." |
19926 | 271 :type 'boolean |
272 :group 'archive-zip) | |
11880 | 273 ;; ------------------------------ |
274 ;; Zoo archive configuration | |
275 | |
19926 | 276 (defcustom archive-zoo-extract |
11880 | 277 '("zoo" "xpq") |
12791
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
278 "*Program and its options to run in order to extract a zoo file member. |
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
279 Extraction should happen to standard output. Archive and member name will |
19926 | 280 be added." |
281 :type '(list (string :tag "Program") | |
282 (repeat :tag "Options" | |
283 :inline t | |
284 (string :format "%v"))) | |
285 :group 'archive-zoo) | |
11880 | 286 |
19926 | 287 (defcustom archive-zoo-expunge |
11880 | 288 '("zoo" "DqPP") |
289 "*Program and its options to run in order to delete zoo file members. | |
19926 | 290 Archive and member names will be added." |
291 :type '(list (string :tag "Program") | |
292 (repeat :tag "Options" | |
293 :inline t | |
294 (string :format "%v"))) | |
295 :group 'archive-zoo) | |
11880 | 296 |
19926 | 297 (defcustom archive-zoo-write-file-member |
11880 | 298 '("zoo" "a") |
299 "*Program and its options to run in order to update a zoo file member. | |
19926 | 300 Archive and member name will be added." |
301 :type '(list (string :tag "Program") | |
302 (repeat :tag "Options" | |
303 :inline t | |
304 (string :format "%v"))) | |
305 :group 'archive-zoo) | |
11880 | 306 ;; ------------------------------------------------------------------------- |
307 ;; Section: Variables | |
308 | |
309 (defvar archive-subtype nil "*Symbol describing archive type.") | |
310 (defvar archive-file-list-start nil "*Position of first contents line.") | |
311 (defvar archive-file-list-end nil "*Position just after last contents line.") | |
312 (defvar archive-proper-file-start nil "*Position of real archive's start.") | |
313 (defvar archive-read-only nil "*Non-nil if the archive is read-only on disk.") | |
314 (defvar archive-local-name nil "*Name of local copy of remote archive.") | |
315 (defvar archive-mode-map nil "*Local keymap for archive mode listings.") | |
316 (defvar archive-file-name-indent nil "*Column where file names start.") | |
317 | |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
318 (defvar archive-remote nil "*Non-nil if the archive is outside file system.") |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
319 (make-variable-buffer-local 'archive-remote) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
320 (put 'archive-remote 'permanent-local t) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
321 |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
322 (defvar archive-member-coding-system nil "Coding-system of archive member.") |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
323 (make-variable-buffer-local 'archive-member-coding-system) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
324 |
11880 | 325 (defvar archive-alternate-display nil |
326 "*Non-nil when alternate information is shown.") | |
327 (make-variable-buffer-local 'archive-alternate-display) | |
328 (put 'archive-alternate-display 'permanent-local t) | |
329 | |
330 (defvar archive-superior-buffer nil "*In archive members, points to archive.") | |
331 (put 'archive-superior-buffer 'permanent-local t) | |
332 | |
333 (defvar archive-subfile-mode nil "*Non-nil in archive member buffers.") | |
334 (make-variable-buffer-local 'archive-subfile-mode) | |
335 (put 'archive-subfile-mode 'permanent-local t) | |
336 | |
16291 | 337 (defvar archive-files nil |
338 "Vector of file descriptors. | |
339 Each descriptor is a vector of the form | |
340 [EXT-FILE-NAME INT-FILE-NAME CASE-FIDDLED MODE ...]") | |
11880 | 341 (make-variable-buffer-local 'archive-files) |
12024
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
342 |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
343 (defvar archive-lemacs |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
344 (string-match "\\(Lucid\\|Xemacs\\)" emacs-version) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
345 "*Non-nil when running under under Lucid Emacs or Xemacs.") |
11880 | 346 ;; ------------------------------------------------------------------------- |
347 ;; Section: Support functions. | |
348 | |
349 (defsubst archive-name (suffix) | |
350 (intern (concat "archive-" (symbol-name archive-subtype) "-" suffix))) | |
351 | |
352 (defun archive-l-e (str &optional len) | |
12791
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
353 "Convert little endian string/vector to integer. |
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
354 Alternatively, first argument may be a buffer position in the current buffer |
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
355 in which case a second argument, length, should be supplied." |
11880 | 356 (if (stringp str) |
357 (setq len (length str)) | |
358 (setq str (buffer-substring str (+ str len)))) | |
359 (let ((result 0) | |
360 (i 0)) | |
361 (while (< i len) | |
362 (setq i (1+ i) | |
363 result (+ (ash result 8) (aref str (- len i))))) | |
364 result)) | |
365 | |
366 (defun archive-int-to-mode (mode) | |
367 "Turn an integer like 0700 (i.e., 448) into a mode string like -rwx------" | |
368 (let ((str (make-string 10 ?-))) | |
369 (or (zerop (logand 16384 mode)) (aset str 0 ?d)) | |
370 (or (zerop (logand 8192 mode)) (aset str 0 ?c)) ; completeness | |
371 (or (zerop (logand 256 mode)) (aset str 1 ?r)) | |
372 (or (zerop (logand 128 mode)) (aset str 2 ?w)) | |
373 (or (zerop (logand 64 mode)) (aset str 3 ?x)) | |
374 (or (zerop (logand 32 mode)) (aset str 4 ?r)) | |
375 (or (zerop (logand 16 mode)) (aset str 5 ?w)) | |
376 (or (zerop (logand 8 mode)) (aset str 6 ?x)) | |
377 (or (zerop (logand 4 mode)) (aset str 7 ?r)) | |
378 (or (zerop (logand 2 mode)) (aset str 8 ?w)) | |
379 (or (zerop (logand 1 mode)) (aset str 9 ?x)) | |
380 (or (zerop (logand 1024 mode)) (aset str 3 (if (zerop (logand 64 mode)) | |
381 ?S ?s))) | |
382 (or (zerop (logand 2048 mode)) (aset str 6 (if (zerop (logand 8 mode)) | |
383 ?S ?s))) | |
384 str)) | |
385 | |
386 (defun archive-calc-mode (oldmode newmode &optional error) | |
12791
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
387 "From the integer OLDMODE and the string NEWMODE calculate a new file mode. |
11880 | 388 NEWMODE may be an octal number including a leading zero in which case it |
389 will become the new mode.\n | |
390 NEWMODE may also be a relative specification like \"og-rwx\" in which case | |
391 OLDMODE will be modified accordingly just like chmod(2) would have done.\n | |
392 If optional third argument ERROR is non-nil an error will be signaled if | |
393 the mode is invalid. If ERROR is nil then nil will be returned." | |
394 (cond ((string-match "^0[0-7]*$" newmode) | |
395 (let ((result 0) | |
396 (len (length newmode)) | |
397 (i 1)) | |
398 (while (< i len) | |
399 (setq result (+ (lsh result 3) (aref newmode i) (- ?0)) | |
400 i (1+ i))) | |
401 (logior (logand oldmode 65024) result))) | |
402 ((string-match "^\\([agou]+\\)\\([---+=]\\)\\([rwxst]+\\)$" newmode) | |
403 (let ((who 0) | |
404 (result oldmode) | |
405 (op (aref newmode (match-beginning 2))) | |
406 (bits 0) | |
407 (i (match-beginning 3))) | |
408 (while (< i (match-end 3)) | |
409 (let ((rwx (aref newmode i))) | |
410 (setq bits (logior bits (cond ((= rwx ?r) 292) | |
411 ((= rwx ?w) 146) | |
412 ((= rwx ?x) 73) | |
413 ((= rwx ?s) 3072) | |
414 ((= rwx ?t) 512))) | |
415 i (1+ i)))) | |
416 (while (< who (match-end 1)) | |
417 (let* ((whoc (aref newmode who)) | |
418 (whomask (cond ((= whoc ?a) 4095) | |
419 ((= whoc ?u) 1472) | |
420 ((= whoc ?g) 2104) | |
421 ((= whoc ?o) 7)))) | |
422 (if (= op ?=) | |
423 (setq result (logand result (lognot whomask)))) | |
424 (if (= op ?-) | |
425 (setq result (logand result (lognot (logand whomask bits)))) | |
426 (setq result (logior result (logand whomask bits))))) | |
427 (setq who (1+ who))) | |
428 result)) | |
429 (t | |
430 (if error | |
431 (error "Invalid mode specification: %s" newmode))))) | |
432 | |
433 (defun archive-dosdate (date) | |
434 "Stringify dos packed DATE record." | |
435 (let ((year (+ 1980 (logand (ash date -9) 127))) | |
436 (month (logand (ash date -5) 15)) | |
437 (day (logand date 31))) | |
438 (if (or (> month 12) (< month 1)) | |
439 "" | |
440 (format "%2d-%s-%d" | |
441 day | |
442 (aref ["Jan" "Feb" "Mar" "Apr" "May" "Jun" | |
443 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"] (1- month)) | |
444 year)))) | |
445 | |
446 (defun archive-dostime (time) | |
447 "Stringify dos packed TIME record." | |
448 (let ((hour (logand (ash time -11) 31)) | |
449 (minute (logand (ash time -5) 53)) | |
450 (second (* 2 (logand time 31)))) ; 2 seconds resolution | |
451 (format "%02d:%02d:%02d" hour minute second))) | |
452 | |
453 ;;(defun archive-unixdate (low high) | |
454 ;; "Stringify unix (LOW HIGH) date." | |
455 ;; (let ((str (current-time-string (cons high low)))) | |
456 ;; (format "%s-%s-%s" | |
457 ;; (substring str 8 9) | |
458 ;; (substring str 4 7) | |
459 ;; (substring str 20 24)))) | |
460 | |
461 ;;(defun archive-unixtime (low high) | |
462 ;; "Stringify unix (LOW HIGH) time." | |
463 ;; (let ((str (current-time-string (cons high low)))) | |
464 ;; (substring str 11 19))) | |
465 | |
466 (defun archive-get-lineno () | |
467 (if (>= (point) archive-file-list-start) | |
468 (count-lines archive-file-list-start | |
469 (save-excursion (beginning-of-line) (point))) | |
470 0)) | |
471 | |
472 (defun archive-get-descr (&optional noerror) | |
12791
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
473 "Return the descriptor vector for file at point. |
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
474 Does not signal an error if optional second argument NOERROR is non-nil." |
11880 | 475 (let ((no (archive-get-lineno))) |
476 (if (and (>= (point) archive-file-list-start) | |
477 (< no (length archive-files))) | |
478 (let ((item (aref archive-files no))) | |
479 (if (vectorp item) | |
480 item | |
481 (if (not noerror) | |
482 (error "Entry is not a regular member of the archive")))) | |
483 (if (not noerror) | |
484 (error "Line does not describe a member of the archive"))))) | |
485 ;; ------------------------------------------------------------------------- | |
486 ;; Section: the mode definition | |
487 | |
12437
c3597b66e4bf
(archive-mode): Add autoload cookie.
Richard M. Stallman <rms@gnu.org>
parents:
12304
diff
changeset
|
488 ;;;###autoload |
11880 | 489 (defun archive-mode (&optional force) |
12791
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
490 "Major mode for viewing an archive file in a dired-like way. |
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
491 You can move around using the usual cursor motion commands. |
11880 | 492 Letters no longer insert themselves. |
493 Type `e' to pull a file out of the archive and into its own buffer; | |
494 or click mouse-2 on the file's line in the archive mode buffer. | |
495 | |
496 If you edit a sub-file of this archive (as with the `e' command) and | |
497 save it, the contents of that buffer will be saved back into the | |
498 archive. | |
499 | |
500 \\{archive-mode-map}" | |
501 ;; This is not interactive because you shouldn't be turning this | |
502 ;; mode on and off. You can corrupt things that way. | |
503 (if (zerop (buffer-size)) | |
504 ;; At present we cannot create archives from scratch | |
505 (funcall default-major-mode) | |
506 (if (and (not force) archive-files) nil | |
507 (let* ((type (archive-find-type)) | |
508 (typename (copy-sequence (symbol-name type)))) | |
509 (aset typename 0 (upcase (aref typename 0))) | |
510 (kill-all-local-variables) | |
511 (make-local-variable 'archive-subtype) | |
512 (setq archive-subtype type) | |
513 | |
514 ;; Buffer contains treated image of file before the file contents | |
515 (make-local-variable 'revert-buffer-function) | |
516 (setq revert-buffer-function 'archive-mode-revert) | |
517 (auto-save-mode 0) | |
518 | |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
519 ;; Remote archives are not written by a hook. |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
520 (if archive-remote nil |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
521 (make-local-variable 'write-contents-hooks) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
522 (add-hook 'write-contents-hooks 'archive-write-file)) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
523 |
11880 | 524 (make-local-variable 'require-final-newline) |
525 (setq require-final-newline nil) | |
22472
7d99675ff55f
(archive-mode): Locally bind local-enable-local-variables, not
Richard M. Stallman <rms@gnu.org>
parents:
22327
diff
changeset
|
526 (make-local-variable 'local-enable-local-variables) |
7d99675ff55f
(archive-mode): Locally bind local-enable-local-variables, not
Richard M. Stallman <rms@gnu.org>
parents:
22327
diff
changeset
|
527 (setq local-enable-local-variables nil) |
11880 | 528 |
23481
4e3bead33d34
(archive-mode): Locally set file-precious-flag.
Richard M. Stallman <rms@gnu.org>
parents:
23467
diff
changeset
|
529 ;; Prevent loss of data when saving the file. |
4e3bead33d34
(archive-mode): Locally set file-precious-flag.
Richard M. Stallman <rms@gnu.org>
parents:
23467
diff
changeset
|
530 (make-local-variable 'file-precious-flag) |
4e3bead33d34
(archive-mode): Locally set file-precious-flag.
Richard M. Stallman <rms@gnu.org>
parents:
23467
diff
changeset
|
531 (setq file-precious-flag t) |
4e3bead33d34
(archive-mode): Locally set file-precious-flag.
Richard M. Stallman <rms@gnu.org>
parents:
23467
diff
changeset
|
532 |
11880 | 533 (make-local-variable 'archive-read-only) |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
534 ;; Archives which are inside other archives and whose |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
535 ;; names are invalid for this OS, can't be written. |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
536 (setq archive-read-only |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
537 (or (not (file-writable-p (buffer-file-name))) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
538 (and archive-subfile-mode |
22174
18a455216af7
(archive-file-name-invalid-regexp): Remove.
Eli Zaretskii <eliz@gnu.org>
parents:
22096
diff
changeset
|
539 (string-match file-name-invalid-regexp |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
540 (aref archive-subfile-mode 0))))) |
11880 | 541 |
542 ;; Should we use a local copy when accessing from outside Emacs? | |
543 (make-local-variable 'archive-local-name) | |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
544 |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
545 ;; An archive can contain another archive whose name is invalid |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
546 ;; on local filesystem. Treat such archives as remote. |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
547 (or archive-remote |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
548 (setq archive-remote |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
549 (or (string-match archive-remote-regexp (buffer-file-name)) |
22174
18a455216af7
(archive-file-name-invalid-regexp): Remove.
Eli Zaretskii <eliz@gnu.org>
parents:
22096
diff
changeset
|
550 (string-match file-name-invalid-regexp |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
551 (buffer-file-name))))) |
11880 | 552 |
553 (setq major-mode 'archive-mode) | |
554 (setq mode-name (concat typename "-Archive")) | |
555 ;; Run archive-foo-mode-hook and archive-mode-hook | |
556 (run-hooks (archive-name "mode-hook") 'archive-mode-hook) | |
557 (use-local-map archive-mode-map)) | |
558 | |
559 (make-local-variable 'archive-proper-file-start) | |
560 (make-local-variable 'archive-file-list-start) | |
561 (make-local-variable 'archive-file-list-end) | |
562 (make-local-variable 'archive-file-name-indent) | |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
563 (archive-summarize nil) |
11880 | 564 (setq buffer-read-only t)))) |
565 | |
566 ;; Archive mode is suitable only for specially formatted data. | |
567 (put 'archive-mode 'mode-class 'special) | |
568 ;; ------------------------------------------------------------------------- | |
569 ;; Section: Key maps | |
570 | |
571 (if archive-mode-map nil | |
572 (setq archive-mode-map (make-keymap)) | |
573 (suppress-keymap archive-mode-map) | |
574 (define-key archive-mode-map " " 'archive-next-line) | |
575 (define-key archive-mode-map "a" 'archive-alternate-display) | |
576 ;;(define-key archive-mode-map "c" 'archive-copy) | |
577 (define-key archive-mode-map "d" 'archive-flag-deleted) | |
578 (define-key archive-mode-map "\C-d" 'archive-flag-deleted) | |
579 (define-key archive-mode-map "e" 'archive-extract) | |
580 (define-key archive-mode-map "f" 'archive-extract) | |
581 (define-key archive-mode-map "\C-m" 'archive-extract) | |
582 (define-key archive-mode-map "g" 'revert-buffer) | |
583 (define-key archive-mode-map "h" 'describe-mode) | |
584 (define-key archive-mode-map "m" 'archive-mark) | |
585 (define-key archive-mode-map "n" 'archive-next-line) | |
586 (define-key archive-mode-map "\C-n" 'archive-next-line) | |
587 (define-key archive-mode-map [down] 'archive-next-line) | |
588 (define-key archive-mode-map "o" 'archive-extract-other-window) | |
589 (define-key archive-mode-map "p" 'archive-previous-line) | |
590 (define-key archive-mode-map "\C-p" 'archive-previous-line) | |
591 (define-key archive-mode-map [up] 'archive-previous-line) | |
592 (define-key archive-mode-map "r" 'archive-rename-entry) | |
593 (define-key archive-mode-map "u" 'archive-unflag) | |
594 (define-key archive-mode-map "\M-\C-?" 'archive-unmark-all-files) | |
595 (define-key archive-mode-map "v" 'archive-view) | |
596 (define-key archive-mode-map "x" 'archive-expunge) | |
597 (define-key archive-mode-map "\177" 'archive-unflag-backwards) | |
598 (define-key archive-mode-map "E" 'archive-extract-other-window) | |
599 (define-key archive-mode-map "M" 'archive-chmod-entry) | |
600 (define-key archive-mode-map "G" 'archive-chgrp-entry) | |
601 (define-key archive-mode-map "O" 'archive-chown-entry) | |
602 | |
12024
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
603 (if archive-lemacs |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
604 (progn |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
605 ;; Not a nice "solution" but it'll have to do |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
606 (define-key archive-mode-map "\C-xu" 'archive-undo) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
607 (define-key archive-mode-map "\C-_" 'archive-undo)) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
608 (substitute-key-definition 'undo 'archive-undo |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
609 archive-mode-map global-map)) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
610 |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
611 (define-key archive-mode-map |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
612 (if archive-lemacs 'button2 [mouse-2]) 'archive-mouse-extract) |
11880 | 613 |
12024
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
614 (if archive-lemacs |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
615 () ; out of luck |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
616 ;; Get rid of the Edit menu bar item to save space. |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
617 (define-key archive-mode-map [menu-bar edit] 'undefined) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
618 |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
619 (define-key archive-mode-map [menu-bar immediate] |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
620 (cons "Immediate" (make-sparse-keymap "Immediate"))) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
621 (define-key archive-mode-map [menu-bar immediate alternate] |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
622 '("Alternate Display" . archive-alternate-display)) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
623 (put 'archive-alternate-display 'menu-enable |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
624 '(boundp (archive-name "alternate-display"))) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
625 (define-key archive-mode-map [menu-bar immediate view] |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
626 '("View This File" . archive-view)) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
627 (define-key archive-mode-map [menu-bar immediate display] |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
628 '("Display in Other Window" . archive-display-other-window)) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
629 (define-key archive-mode-map [menu-bar immediate find-file-other-window] |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
630 '("Find in Other Window" . archive-extract-other-window)) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
631 (define-key archive-mode-map [menu-bar immediate find-file] |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
632 '("Find This File" . archive-extract)) |
11880 | 633 |
12024
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
634 (define-key archive-mode-map [menu-bar mark] |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
635 (cons "Mark" (make-sparse-keymap "Mark"))) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
636 (define-key archive-mode-map [menu-bar mark unmark-all] |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
637 '("Unmark All" . archive-unmark-all-files)) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
638 (define-key archive-mode-map [menu-bar mark deletion] |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
639 '("Flag" . archive-flag-deleted)) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
640 (define-key archive-mode-map [menu-bar mark unmark] |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
641 '("Unflag" . archive-unflag)) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
642 (define-key archive-mode-map [menu-bar mark mark] |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
643 '("Mark" . archive-mark)) |
11880 | 644 |
12024
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
645 (define-key archive-mode-map [menu-bar operate] |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
646 (cons "Operate" (make-sparse-keymap "Operate"))) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
647 (define-key archive-mode-map [menu-bar operate chown] |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
648 '("Change Owner..." . archive-chown-entry)) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
649 (put 'archive-chown-entry 'menu-enable |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
650 '(fboundp (archive-name "chown-entry"))) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
651 (define-key archive-mode-map [menu-bar operate chgrp] |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
652 '("Change Group..." . archive-chgrp-entry)) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
653 (put 'archive-chgrp-entry 'menu-enable |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
654 '(fboundp (archive-name "chgrp-entry"))) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
655 (define-key archive-mode-map [menu-bar operate chmod] |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
656 '("Change Mode..." . archive-chmod-entry)) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
657 (put 'archive-chmod-entry 'menu-enable |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
658 '(fboundp (archive-name "chmod-entry"))) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
659 (define-key archive-mode-map [menu-bar operate rename] |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
660 '("Rename to..." . archive-rename-entry)) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
661 (put 'archive-rename-entry 'menu-enable |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
662 '(fboundp (archive-name "rename-entry"))) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
663 ;;(define-key archive-mode-map [menu-bar operate copy] |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
664 ;; '("Copy to..." . archive-copy)) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
665 (define-key archive-mode-map [menu-bar operate expunge] |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
666 '("Expunge Marked Files" . archive-expunge)) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
667 )) |
11880 | 668 |
669 (let* ((item1 '(archive-subfile-mode " Archive")) | |
21570
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
670 (items (list item1))) |
11880 | 671 (or (member item1 minor-mode-alist) |
672 (setq minor-mode-alist (append items minor-mode-alist)))) | |
673 ;; ------------------------------------------------------------------------- | |
674 (defun archive-find-type () | |
675 (widen) | |
676 (goto-char (point-min)) | |
677 ;; The funny [] here make it unlikely that the .elc file will be treated | |
678 ;; as an archive by other software. | |
679 (let (case-fold-search) | |
680 (cond ((looking-at "[P]K\003\004") 'zip) | |
20767
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
681 ((looking-at "..-l[hz][0-9ds]-") 'lzh) |
11880 | 682 ((looking-at "....................[\334]\247\304\375") 'zoo) |
683 ((and (looking-at "\C-z") ; signature too simple, IMHO | |
684 (string-match "\\.[aA][rR][cC]$" | |
685 (or buffer-file-name (buffer-name)))) | |
686 'arc) | |
687 (t (error "Buffer format not recognized."))))) | |
688 ;; ------------------------------------------------------------------------- | |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
689 (defun archive-summarize (&optional shut-up) |
11880 | 690 "Parse the contents of the archive file in the current buffer. |
691 Place a dired-like listing on the front; | |
692 then narrow to it, so that only that listing | |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
693 is visible (and the real data of the buffer is hidden). |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
694 Optional argument SHUT-UP, if non-nil, means don't print messages |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
695 when parsing the archive." |
11880 | 696 (widen) |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
697 (set-buffer-multibyte nil) |
11880 | 698 (let (buffer-read-only) |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
699 (or shut-up |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
700 (message "Parsing archive file...")) |
11880 | 701 (buffer-disable-undo (current-buffer)) |
702 (setq archive-files (funcall (archive-name "summarize"))) | |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
703 (or shut-up |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
704 (message "Parsing archive file...done.")) |
11880 | 705 (setq archive-proper-file-start (point-marker)) |
706 (narrow-to-region (point-min) (point)) | |
707 (set-buffer-modified-p nil) | |
708 (buffer-enable-undo)) | |
709 (goto-char archive-file-list-start) | |
710 (archive-next-line 0)) | |
711 | |
712 (defun archive-resummarize () | |
713 "Recreate the contents listing of an archive." | |
714 (let ((modified (buffer-modified-p)) | |
715 (no (archive-get-lineno)) | |
716 buffer-read-only) | |
717 (widen) | |
718 (delete-region (point-min) archive-proper-file-start) | |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
719 (archive-summarize t) |
11880 | 720 (set-buffer-modified-p modified) |
721 (goto-char archive-file-list-start) | |
722 (archive-next-line no))) | |
723 | |
724 (defun archive-summarize-files (files) | |
16291 | 725 "Insert a description of a list of files annotated with proper mouse face." |
11880 | 726 (setq archive-file-list-start (point-marker)) |
727 (setq archive-file-name-indent (if files (aref (car files) 1) 0)) | |
728 ;; We don't want to do an insert for each element since that takes too | |
729 ;; long when the archive -- which has to be moved in memory -- is large. | |
730 (insert | |
731 (apply | |
732 (function concat) | |
733 (mapcar | |
12024
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
734 (function |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
735 (lambda (fil) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
736 ;; Using `concat' here copies the text also, so we can add |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
737 ;; properties without problems. |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
738 (let ((text (concat (aref fil 0) "\n"))) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
739 (if archive-lemacs |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
740 () ; out of luck |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
741 (put-text-property (aref fil 1) (aref fil 2) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
742 'mouse-face 'highlight |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
743 text)) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
744 text))) |
11880 | 745 files))) |
746 (setq archive-file-list-end (point-marker))) | |
747 | |
748 (defun archive-alternate-display () | |
12791
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
749 "Toggle alternative display. |
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
750 To avoid very long lines some archive mode don't show all information. |
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
751 This function changes the set of information shown for each files." |
11880 | 752 (interactive) |
753 (setq archive-alternate-display (not archive-alternate-display)) | |
754 (archive-resummarize)) | |
755 ;; ------------------------------------------------------------------------- | |
756 ;; Section: Local archive copy handling | |
757 | |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
758 (defun archive-unique-fname (fname dir) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
759 "Make sure a file FNAME can be created uniquely in directory DIR. |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
760 |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
761 If FNAME can be uniquely created in DIR, it is returned unaltered. |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
762 If FNAME is something our underlying filesystem can't grok, or if another |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
763 file by that name already exists in DIR, a unique new name is generated |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
764 using `make-temp-name', and the generated name is returned." |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
765 (let ((fullname (expand-file-name fname dir)) |
22174
18a455216af7
(archive-file-name-invalid-regexp): Remove.
Eli Zaretskii <eliz@gnu.org>
parents:
22096
diff
changeset
|
766 (alien (string-match file-name-invalid-regexp fname))) |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
767 (if (or alien (file-exists-p fullname)) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
768 (make-temp-name |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
769 (expand-file-name |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
770 (if (and (eq system-type 'ms-dos) (not (msdos-long-file-names))) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
771 "am" |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
772 "arc-mode.") |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
773 dir)) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
774 fullname))) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
775 |
11880 | 776 (defun archive-maybe-copy (archive) |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
777 (let ((coding-system-for-write 'no-conversion)) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
778 (if archive-remote |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
779 (let ((start (point-max)) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
780 ;; Sometimes ARCHIVE is invalid while its actual name, as |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
781 ;; recorded in its parent archive, is not. For example, an |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
782 ;; archive bar.zip inside another archive foo.zip gets a name |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
783 ;; "foo.zip:bar.zip", which is invalid on DOS/Windows. |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
784 ;; So use the actual name if available. |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
785 (archive-name |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
786 (or (and archive-subfile-mode (aref archive-subfile-mode 0)) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
787 archive))) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
788 (make-directory archive-tmpdir t) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
789 (setq archive-local-name |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
790 (archive-unique-fname archive-name archive-tmpdir)) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
791 (save-restriction |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
792 (widen) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
793 (write-region start (point-max) archive-local-name nil 'nomessage)) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
794 archive-local-name) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
795 (if (buffer-modified-p) (save-buffer)) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
796 archive))) |
11880 | 797 |
798 (defun archive-maybe-update (unchanged) | |
799 (if archive-remote | |
800 (let ((name archive-local-name) | |
801 (modified (buffer-modified-p)) | |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
802 (coding-system-for-read 'no-conversion) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
803 (lno (archive-get-lineno)) |
11880 | 804 buffer-read-only) |
805 (if unchanged nil | |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
806 (setq archive-files nil) |
11880 | 807 (erase-buffer) |
808 (insert-file-contents name) | |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
809 (archive-mode t) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
810 (goto-char archive-file-list-start) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
811 (archive-next-line lno)) |
11880 | 812 (archive-delete-local name) |
813 (if (not unchanged) | |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
814 (message |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
815 "Buffer `%s' must be saved for changes to take effect" |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
816 (buffer-name (current-buffer)))) |
11880 | 817 (set-buffer-modified-p (or modified (not unchanged)))))) |
818 | |
819 (defun archive-delete-local (name) | |
12791
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
820 "Delete file NAME and its parents up to and including `archive-tmpdir'." |
11880 | 821 (let ((again t) |
822 (top (directory-file-name (file-name-as-directory archive-tmpdir)))) | |
823 (condition-case nil | |
824 (delete-file name) | |
825 (error nil)) | |
826 (while again | |
827 (setq name (directory-file-name (file-name-directory name))) | |
828 (condition-case nil | |
829 (delete-directory name) | |
830 (error nil)) | |
831 (if (string= name top) (setq again nil))))) | |
832 ;; ------------------------------------------------------------------------- | |
833 ;; Section: Member extraction | |
834 | |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
835 (defun archive-file-name-handler (op &rest args) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
836 (or (eq op 'file-exists-p) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
837 (let ((file-name-handler-alist nil)) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
838 (apply op args)))) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
839 |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
840 (defun archive-set-buffer-as-visiting-file (filename) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
841 "Set the current buffer as if it were visiting FILENAME." |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
842 (save-excursion |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
843 (goto-char (point-min)) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
844 (let ((coding |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
845 (or coding-system-for-read |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
846 (and set-auto-coding-function |
24381
b3c0f3ad64d8
(archive-set-buffer-as-visiting-file): Save
Eli Zaretskii <eliz@gnu.org>
parents:
23481
diff
changeset
|
847 (save-excursion |
b3c0f3ad64d8
(archive-set-buffer-as-visiting-file): Save
Eli Zaretskii <eliz@gnu.org>
parents:
23481
diff
changeset
|
848 (funcall set-auto-coding-function |
b3c0f3ad64d8
(archive-set-buffer-as-visiting-file): Save
Eli Zaretskii <eliz@gnu.org>
parents:
23481
diff
changeset
|
849 filename (- (point-max) (point-min))))) |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
850 ;; dos-w32.el defines find-operation-coding-system for |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
851 ;; DOS/Windows systems which preserves the coding-system |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
852 ;; of existing files. We want it to act here as if the |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
853 ;; extracted file existed. |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
854 (let ((file-name-handler-alist |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
855 '(("" . archive-file-name-handler)))) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
856 (car (find-operation-coding-system 'insert-file-contents |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
857 filename t)))))) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
858 (if (and (not coding-system-for-read) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
859 (not enable-multibyte-characters)) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
860 (setq coding |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
861 (coding-system-change-text-conversion coding 'raw-text))) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
862 (if (and coding |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
863 (not (eq coding 'no-conversion))) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
864 (decode-coding-region (point-min) (point-max) coding) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
865 (setq last-coding-system-used coding)) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
866 (set-buffer-modified-p nil) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
867 (kill-local-variable 'buffer-file-coding-system) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
868 (after-insert-file-set-buffer-file-coding-system (- (point-max) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
869 (point-min)))))) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
870 |
11880 | 871 (defun archive-mouse-extract (event) |
872 "Extract a file whose name you click on." | |
873 (interactive "e") | |
12024
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
874 (mouse-set-point event) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
875 (switch-to-buffer |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
876 (save-excursion |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
877 (archive-extract) |
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
878 (current-buffer)))) |
11880 | 879 |
880 (defun archive-extract (&optional other-window-p) | |
881 "In archive mode, extract this entry of the archive into its own buffer." | |
882 (interactive) | |
883 (let* ((view-p (eq other-window-p 'view)) | |
884 (descr (archive-get-descr)) | |
885 (ename (aref descr 0)) | |
886 (iname (aref descr 1)) | |
887 (archive-buffer (current-buffer)) | |
888 (arcdir default-directory) | |
889 (archive (buffer-file-name)) | |
890 (arcname (file-name-nondirectory archive)) | |
891 (bufname (concat (file-name-nondirectory iname) " (" arcname ")")) | |
892 (extractor (archive-name "extract")) | |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
893 ;; Members with file names which aren't valid for the |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
894 ;; underlying filesystem, are treated as read-only. |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
895 (read-only-p (or archive-read-only |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
896 view-p |
22174
18a455216af7
(archive-file-name-invalid-regexp): Remove.
Eli Zaretskii <eliz@gnu.org>
parents:
22096
diff
changeset
|
897 (string-match file-name-invalid-regexp ename))) |
11880 | 898 (buffer (get-buffer bufname)) |
899 (just-created nil)) | |
900 (if buffer | |
901 nil | |
902 (setq archive (archive-maybe-copy archive)) | |
903 (setq buffer (get-buffer-create bufname)) | |
904 (setq just-created t) | |
905 (save-excursion | |
906 (set-buffer buffer) | |
907 (setq buffer-file-name | |
908 (expand-file-name (concat arcname ":" iname))) | |
909 (setq buffer-file-truename | |
910 (abbreviate-file-name buffer-file-name)) | |
911 ;; Set the default-directory to the dir of the superior buffer. | |
912 (setq default-directory arcdir) | |
913 (make-local-variable 'archive-superior-buffer) | |
914 (setq archive-superior-buffer archive-buffer) | |
915 (make-local-variable 'local-write-file-hooks) | |
916 (add-hook 'local-write-file-hooks 'archive-write-file-member) | |
917 (setq archive-subfile-mode descr) | |
21570
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
918 (if (and |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
919 (null |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
920 (let (;; We may have to encode file name arguement for |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
921 ;; external programs. |
22834
926aae368e61
(archive-set-buffer-as-visiting-file): Give FILENAME
Kenichi Handa <handa@m17n.org>
parents:
22830
diff
changeset
|
922 (coding-system-for-write |
926aae368e61
(archive-set-buffer-as-visiting-file): Give FILENAME
Kenichi Handa <handa@m17n.org>
parents:
22830
diff
changeset
|
923 (and enable-multibyte-characters |
926aae368e61
(archive-set-buffer-as-visiting-file): Give FILENAME
Kenichi Handa <handa@m17n.org>
parents:
22830
diff
changeset
|
924 file-name-coding-system)) |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
925 ;; We read an archive member by no-conversion at |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
926 ;; first, then decode appropriately by calling |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
927 ;; archive-set-buffer-as-visiting-file later. |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
928 (coding-system-for-read 'no-conversion)) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
929 (condition-case err |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
930 (if (fboundp extractor) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
931 (funcall extractor archive ename) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
932 (archive-*-extract archive ename |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
933 (symbol-value extractor))) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
934 (error |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
935 (ding (message "%s" (error-message-string err))) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
936 nil)))) |
21570
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
937 just-created) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
938 (progn |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
939 (set-buffer-modified-p nil) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
940 (kill-buffer buffer)) |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
941 (archive-set-buffer-as-visiting-file ename) |
21570
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
942 (goto-char (point-min)) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
943 (rename-buffer bufname) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
944 (setq buffer-read-only read-only-p) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
945 (setq buffer-undo-list nil) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
946 (set-buffer-modified-p nil) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
947 (setq buffer-saved-size (buffer-size)) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
948 (normal-mode) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
949 ;; Just in case an archive occurs inside another archive. |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
950 (if (eq major-mode 'archive-mode) |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
951 (progn |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
952 (setq archive-remote t) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
953 (if read-only-p (setq archive-read-only t)) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
954 ;; We will write out the archive ourselves if it is |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
955 ;; part of another archive. |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
956 (remove-hook 'write-contents-hooks 'archive-write-file t))) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
957 (run-hooks 'archive-extract-hooks) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
958 (if archive-read-only |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
959 (message "Note: altering this archive is not implemented.")))) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
960 (archive-maybe-update t)) |
21570
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
961 (or (not (buffer-name buffer)) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
962 (progn |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
963 (if view-p |
22327
c119045b2019
(archive-extract): Fix handling of 'view option.
Karl Heuer <kwzh@gnu.org>
parents:
22174
diff
changeset
|
964 (view-buffer buffer (and just-created 'kill-buffer)) |
c119045b2019
(archive-extract): Fix handling of 'view option.
Karl Heuer <kwzh@gnu.org>
parents:
22174
diff
changeset
|
965 (if (eq other-window-p 'display) |
c119045b2019
(archive-extract): Fix handling of 'view option.
Karl Heuer <kwzh@gnu.org>
parents:
22174
diff
changeset
|
966 (display-buffer buffer) |
c119045b2019
(archive-extract): Fix handling of 'view option.
Karl Heuer <kwzh@gnu.org>
parents:
22174
diff
changeset
|
967 (if other-window-p |
c119045b2019
(archive-extract): Fix handling of 'view option.
Karl Heuer <kwzh@gnu.org>
parents:
22174
diff
changeset
|
968 (switch-to-buffer-other-window buffer) |
c119045b2019
(archive-extract): Fix handling of 'view option.
Karl Heuer <kwzh@gnu.org>
parents:
22174
diff
changeset
|
969 (switch-to-buffer buffer)))))))) |
11880 | 970 |
971 (defun archive-*-extract (archive name command) | |
972 (let* ((default-directory (file-name-as-directory archive-tmpdir)) | |
973 (tmpfile (expand-file-name (file-name-nondirectory name) | |
21570
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
974 default-directory)) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
975 exit-status success) |
11880 | 976 (make-directory (directory-file-name default-directory) t) |
21570
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
977 (setq exit-status |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
978 (apply 'call-process |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
979 (car command) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
980 nil |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
981 nil |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
982 nil |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
983 (append (cdr command) (list archive name)))) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
984 (cond ((and (numberp exit-status) (= exit-status 0)) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
985 (if (not (file-exists-p tmpfile)) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
986 (ding (message "`%s': no such file or directory" tmpfile)) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
987 (insert-file-contents tmpfile) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
988 (setq success t))) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
989 ((numberp exit-status) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
990 (ding |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
991 (message "`%s' exited with status %d" (car command) exit-status))) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
992 ((stringp exit-status) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
993 (ding (message "`%s' aborted: %s" (car command) exit-status))) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
994 (t |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
995 (ding (message "`%s' failed" (car command))))) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
996 (archive-delete-local tmpfile) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
997 success)) |
11880 | 998 |
999 (defun archive-extract-by-stdout (archive name command) | |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1000 (apply 'call-process |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1001 (car command) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1002 nil |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1003 t |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1004 nil |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1005 (append (cdr command) (list archive name)))) |
11880 | 1006 |
1007 (defun archive-extract-other-window () | |
1008 "In archive mode, find this member in another window." | |
1009 (interactive) | |
1010 (archive-extract t)) | |
1011 | |
1012 (defun archive-display-other-window () | |
1013 "In archive mode, display this member in another window." | |
1014 (interactive) | |
1015 (archive-extract 'display)) | |
1016 | |
1017 (defun archive-view () | |
1018 "In archive mode, view the member on this line." | |
1019 (interactive) | |
1020 (archive-extract 'view)) | |
1021 | |
1022 (defun archive-add-new-member (arcbuf name) | |
12791
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
1023 "Add current buffer to the archive in ARCBUF naming it NAME." |
11880 | 1024 (interactive |
1025 (list (get-buffer | |
1026 (read-buffer "Buffer containing archive: " | |
1027 ;; Find first archive buffer and suggest that | |
1028 (let ((bufs (buffer-list))) | |
1029 (while (and bufs (not (eq (save-excursion | |
1030 (set-buffer (car bufs)) | |
1031 major-mode) | |
1032 'archive-mode))) | |
1033 (setq bufs (cdr bufs))) | |
1034 (if bufs | |
1035 (car bufs) | |
1036 (error "There are no archive buffers"))) | |
1037 t)) | |
1038 (read-string "File name in archive: " | |
1039 (if buffer-file-name | |
1040 (file-name-nondirectory buffer-file-name) | |
1041 "")))) | |
1042 (save-excursion | |
1043 (set-buffer arcbuf) | |
1044 (or (eq major-mode 'archive-mode) | |
1045 (error "Buffer is not an archive buffer")) | |
1046 (if archive-read-only | |
1047 (error "Archive is read-only"))) | |
1048 (if (eq arcbuf (current-buffer)) | |
1049 (error "An archive buffer cannot be added to itself")) | |
1050 (if (string= name "") | |
1051 (error "Archive members may not be given empty names")) | |
1052 (let ((func (save-excursion (set-buffer arcbuf) | |
1053 (archive-name "add-new-member"))) | |
1054 (membuf (current-buffer))) | |
1055 (if (fboundp func) | |
1056 (save-excursion | |
1057 (set-buffer arcbuf) | |
1058 (funcall func buffer-file-name membuf name)) | |
1059 (error "Adding a new member is not supported for this archive type")))) | |
1060 ;; ------------------------------------------------------------------------- | |
1061 ;; Section: IO stuff | |
1062 | |
1063 (defun archive-write-file-member () | |
21570
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
1064 (save-excursion |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
1065 (save-restriction |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
1066 (message "Updating archive...") |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
1067 (widen) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
1068 (let ((writer (save-excursion (set-buffer archive-superior-buffer) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
1069 (archive-name "write-file-member"))) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
1070 (archive (save-excursion (set-buffer archive-superior-buffer) |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1071 (archive-maybe-copy (buffer-file-name))))) |
21570
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
1072 (if (fboundp writer) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
1073 (funcall writer archive archive-subfile-mode) |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
1074 (archive-*-write-file-member archive |
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
1075 archive-subfile-mode |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1076 (symbol-value writer))) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1077 (set-buffer-modified-p nil) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1078 (message "Updating archive...done")) |
21570
e21c343b0c6e
(archive-extract-by-stdout): Don't use
Eli Zaretskii <eliz@gnu.org>
parents:
20767
diff
changeset
|
1079 (set-buffer archive-superior-buffer) |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1080 (if (not archive-remote) (revert-buffer) (archive-maybe-update nil)))) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1081 ;; Restore the value of last-coding-system-used, so that basic-save-buffer |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1082 ;; won't reset the coding-system of this archive member. |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1083 (if (local-variable-p 'archive-member-coding-system) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1084 (setq last-coding-system-used archive-member-coding-system)) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1085 t) |
11880 | 1086 |
1087 (defun archive-*-write-file-member (archive descr command) | |
1088 (let* ((ename (aref descr 0)) | |
1089 (tmpfile (expand-file-name ename archive-tmpdir)) | |
1090 (top (directory-file-name (file-name-as-directory archive-tmpdir))) | |
1091 (default-directory (file-name-as-directory top))) | |
1092 (unwind-protect | |
1093 (progn | |
1094 (make-directory (file-name-directory tmpfile) t) | |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1095 ;; If the member is itself an archive, write it without |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1096 ;; the dired-like listing we created. |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1097 (if (eq major-mode 'archive-mode) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1098 (archive-write-file tmpfile) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1099 (write-region (point-min) (point-max) tmpfile nil 'nomessage)) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1100 ;; basic-save-buffer needs last-coding-system-used to have |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1101 ;; the value used to write the file, so save it before any |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1102 ;; further processing clobbers it (we restore it in |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1103 ;; archive-write-file-member, above). |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1104 (setq archive-member-coding-system last-coding-system-used) |
11880 | 1105 (if (aref descr 3) |
1106 ;; Set the file modes, but make sure we can read it. | |
1107 (set-file-modes tmpfile (logior ?\400 (aref descr 3)))) | |
22834
926aae368e61
(archive-set-buffer-as-visiting-file): Give FILENAME
Kenichi Handa <handa@m17n.org>
parents:
22830
diff
changeset
|
1108 (if enable-multibyte-characters |
926aae368e61
(archive-set-buffer-as-visiting-file): Give FILENAME
Kenichi Handa <handa@m17n.org>
parents:
22830
diff
changeset
|
1109 (setq ename |
926aae368e61
(archive-set-buffer-as-visiting-file): Give FILENAME
Kenichi Handa <handa@m17n.org>
parents:
22830
diff
changeset
|
1110 (encode-coding-string ename file-name-coding-system))) |
11880 | 1111 (let ((exitcode (apply 'call-process |
1112 (car command) | |
1113 nil | |
1114 nil | |
1115 nil | |
1116 (append (cdr command) (list archive ename))))) | |
1117 (if (equal exitcode 0) | |
1118 nil | |
1119 (error "Updating was unsuccessful (%S)" exitcode)))) | |
1120 (archive-delete-local tmpfile)))) | |
1121 | |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1122 (defun archive-write-file (&optional file) |
11880 | 1123 (save-excursion |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1124 (let ((coding-system-for-write 'no-conversion)) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1125 (write-region archive-proper-file-start (point-max) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1126 (or file buffer-file-name) nil t) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1127 (set-buffer-modified-p nil)) |
11880 | 1128 t)) |
1129 ;; ------------------------------------------------------------------------- | |
1130 ;; Section: Marking and unmarking. | |
1131 | |
1132 (defun archive-flag-deleted (p &optional type) | |
1133 "In archive mode, mark this member to be deleted from the archive. | |
1134 With a prefix argument, mark that many files." | |
1135 (interactive "p") | |
1136 (or type (setq type ?D)) | |
1137 (beginning-of-line) | |
1138 (let ((sign (if (>= p 0) +1 -1)) | |
1139 (modified (buffer-modified-p)) | |
1140 buffer-read-only) | |
1141 (while (not (zerop p)) | |
1142 (if (archive-get-descr t) | |
1143 (progn | |
1144 (delete-char 1) | |
1145 (insert type))) | |
1146 (forward-line sign) | |
1147 (setq p (- p sign))) | |
1148 (set-buffer-modified-p modified)) | |
1149 (archive-next-line 0)) | |
1150 | |
1151 (defun archive-unflag (p) | |
1152 "In archive mode, un-mark this member if it is marked to be deleted. | |
1153 With a prefix argument, un-mark that many files forward." | |
1154 (interactive "p") | |
1155 (archive-flag-deleted p ? )) | |
1156 | |
1157 (defun archive-unflag-backwards (p) | |
1158 "In archive mode, un-mark this member if it is marked to be deleted. | |
1159 With a prefix argument, un-mark that many members backward." | |
1160 (interactive "p") | |
1161 (archive-flag-deleted (- p) ? )) | |
1162 | |
1163 (defun archive-unmark-all-files () | |
1164 "Remove all marks." | |
1165 (interactive) | |
1166 (let ((modified (buffer-modified-p)) | |
1167 buffer-read-only) | |
1168 (save-excursion | |
1169 (goto-char archive-file-list-start) | |
1170 (while (< (point) archive-file-list-end) | |
1171 (or (= (following-char) ? ) | |
1172 (progn (delete-char 1) (insert ? ))) | |
1173 (forward-line 1))) | |
1174 (set-buffer-modified-p modified))) | |
1175 | |
1176 (defun archive-mark (p) | |
1177 "In archive mode, mark this member for group operations. | |
1178 With a prefix argument, mark that many members. | |
1179 Use \\[archive-unmark-all-files] to remove all marks." | |
1180 (interactive "p") | |
1181 (archive-flag-deleted p ?*)) | |
1182 | |
1183 (defun archive-get-marked (mark &optional default) | |
1184 (let (files) | |
1185 (save-excursion | |
1186 (goto-char archive-file-list-start) | |
1187 (while (< (point) archive-file-list-end) | |
1188 (if (= (following-char) mark) | |
1189 (setq files (cons (archive-get-descr) files))) | |
1190 (forward-line 1))) | |
1191 (or (nreverse files) | |
1192 (and default | |
1193 (list (archive-get-descr)))))) | |
1194 ;; ------------------------------------------------------------------------- | |
1195 ;; Section: Operate | |
1196 | |
1197 (defun archive-next-line (p) | |
1198 (interactive "p") | |
1199 (forward-line p) | |
1200 (or (eobp) | |
1201 (forward-char archive-file-name-indent))) | |
1202 | |
1203 (defun archive-previous-line (p) | |
1204 (interactive "p") | |
1205 (archive-next-line (- p))) | |
1206 | |
1207 (defun archive-chmod-entry (new-mode) | |
12791
61bbb487bf2c
Standardize layout of doc strings.
Richard M. Stallman <rms@gnu.org>
parents:
12756
diff
changeset
|
1208 "Change the protection bits associated with all marked or this member. |
11880 | 1209 The new protection bits can either be specified as an octal number or |
1210 as a relative change like \"g+rw\" as for chmod(2)" | |
1211 (interactive "sNew mode (octal or relative): ") | |
1212 (if archive-read-only (error "Archive is read-only")) | |
1213 (let ((func (archive-name "chmod-entry"))) | |
1214 (if (fboundp func) | |
1215 (progn | |
1216 (funcall func new-mode (archive-get-marked ?* t)) | |
1217 (archive-resummarize)) | |
1218 (error "Setting mode bits is not supported for this archive type")))) | |
1219 | |
1220 (defun archive-chown-entry (new-uid) | |
1221 "Change the owner of all marked or this member." | |
1222 (interactive "nNew uid: ") | |
1223 (if archive-read-only (error "Archive is read-only")) | |
1224 (let ((func (archive-name "chown-entry"))) | |
1225 (if (fboundp func) | |
1226 (progn | |
1227 (funcall func new-uid (archive-get-marked ?* t)) | |
1228 (archive-resummarize)) | |
1229 (error "Setting owner is not supported for this archive type")))) | |
1230 | |
1231 (defun archive-chgrp-entry (new-gid) | |
1232 "Change the group of all marked or this member." | |
1233 (interactive "nNew gid: ") | |
1234 (if archive-read-only (error "Archive is read-only")) | |
1235 (let ((func (archive-name "chgrp-entry"))) | |
1236 (if (fboundp func) | |
1237 (progn | |
1238 (funcall func new-gid (archive-get-marked ?* t)) | |
1239 (archive-resummarize)) | |
1240 (error "Setting group is not supported for this archive type")))) | |
1241 | |
1242 (defun archive-expunge () | |
1243 "Do the flagged deletions." | |
1244 (interactive) | |
1245 (let (files) | |
1246 (save-excursion | |
1247 (goto-char archive-file-list-start) | |
1248 (while (< (point) archive-file-list-end) | |
1249 (if (= (following-char) ?D) | |
1250 (setq files (cons (aref (archive-get-descr) 0) files))) | |
1251 (forward-line 1))) | |
1252 (setq files (nreverse files)) | |
1253 (and files | |
1254 (or (not archive-read-only) | |
1255 (error "Archive is read-only")) | |
1256 (or (yes-or-no-p (format "Really delete %d member%s? " | |
1257 (length files) | |
1258 (if (null (cdr files)) "" "s"))) | |
1259 (error "Operation aborted")) | |
1260 (let ((archive (archive-maybe-copy (buffer-file-name))) | |
1261 (expunger (archive-name "expunge"))) | |
1262 (if (fboundp expunger) | |
1263 (funcall expunger archive files) | |
1264 (archive-*-expunge archive files (symbol-value expunger))) | |
1265 (archive-maybe-update nil) | |
1266 (if archive-remote | |
1267 (archive-resummarize) | |
1268 (revert-buffer)))))) | |
1269 | |
1270 (defun archive-*-expunge (archive files command) | |
1271 (apply 'call-process | |
1272 (car command) | |
1273 nil | |
1274 nil | |
1275 nil | |
1276 (append (cdr command) (cons archive files)))) | |
1277 | |
1278 (defun archive-rename-entry (newname) | |
1279 "Change the name associated with this entry in the tar file." | |
1280 (interactive "sNew name: ") | |
1281 (if archive-read-only (error "Archive is read-only")) | |
1282 (if (string= newname "") | |
1283 (error "Archive members may not be given empty names")) | |
1284 (let ((func (archive-name "rename-entry")) | |
1285 (descr (archive-get-descr))) | |
1286 (if (fboundp func) | |
1287 (progn | |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1288 (funcall func (buffer-file-name) |
22834
926aae368e61
(archive-set-buffer-as-visiting-file): Give FILENAME
Kenichi Handa <handa@m17n.org>
parents:
22830
diff
changeset
|
1289 (if enable-multibyte-characters |
926aae368e61
(archive-set-buffer-as-visiting-file): Give FILENAME
Kenichi Handa <handa@m17n.org>
parents:
22830
diff
changeset
|
1290 (encode-coding-string newname file-name-coding-system) |
926aae368e61
(archive-set-buffer-as-visiting-file): Give FILENAME
Kenichi Handa <handa@m17n.org>
parents:
22830
diff
changeset
|
1291 newname) |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1292 descr) |
11880 | 1293 (archive-resummarize)) |
1294 (error "Renaming is not supported for this archive type")))) | |
1295 | |
1296 ;; Revert the buffer and recompute the dired-like listing. | |
23383
7af3fdca3189
(archive-mode-revert): Arg no-auto-save renamed from no-autosave.
Karl Heuer <kwzh@gnu.org>
parents:
22834
diff
changeset
|
1297 (defun archive-mode-revert (&optional no-auto-save no-confirm) |
11880 | 1298 (let ((no (archive-get-lineno))) |
1299 (setq archive-files nil) | |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1300 (let ((revert-buffer-function nil) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1301 (coding-system-for-read 'no-conversion)) |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1302 (set-buffer-multibyte nil) |
11880 | 1303 (revert-buffer t t)) |
1304 (archive-mode) | |
1305 (goto-char archive-file-list-start) | |
1306 (archive-next-line no))) | |
1307 | |
1308 (defun archive-undo () | |
1309 "Undo in an archive buffer. | |
1310 This doesn't recover lost files, it just undoes changes in the buffer itself." | |
1311 (interactive) | |
1312 (let (buffer-read-only) | |
1313 (undo))) | |
1314 ;; ------------------------------------------------------------------------- | |
1315 ;; Section: Arc Archives | |
1316 | |
1317 (defun archive-arc-summarize () | |
1318 (let ((p 1) | |
1319 (totalsize 0) | |
1320 (maxlen 8) | |
1321 files | |
1322 visual) | |
1323 (while (and (< (+ p 29) (point-max)) | |
1324 (= (char-after p) ?\C-z) | |
1325 (> (char-after (1+ p)) 0)) | |
1326 (let* ((namefld (buffer-substring (+ p 2) (+ p 2 13))) | |
1327 (fnlen (or (string-match "\0" namefld) 13)) | |
1328 (efnname (substring namefld 0 fnlen)) | |
1329 (csize (archive-l-e (+ p 15) 4)) | |
1330 (moddate (archive-l-e (+ p 19) 2)) | |
1331 (modtime (archive-l-e (+ p 21) 2)) | |
1332 (ucsize (archive-l-e (+ p 25) 4)) | |
1333 (fiddle (string= efnname (upcase efnname))) | |
1334 (ifnname (if fiddle (downcase efnname) efnname)) | |
1335 (text (format " %8d %-11s %-8s %s" | |
1336 ucsize | |
1337 (archive-dosdate moddate) | |
1338 (archive-dostime modtime) | |
1339 ifnname))) | |
1340 (setq maxlen (max maxlen fnlen) | |
1341 totalsize (+ totalsize ucsize) | |
1342 visual (cons (vector text | |
1343 (- (length text) (length ifnname)) | |
1344 (length text)) | |
1345 visual) | |
1346 files (cons (vector efnname ifnname fiddle nil (1- p)) | |
1347 files) | |
1348 p (+ p 29 csize)))) | |
1349 (goto-char (point-min)) | |
1350 (let ((dash (concat "- -------- ----------- -------- " | |
1351 (make-string maxlen ?-) | |
1352 "\n"))) | |
1353 (insert "M Length Date Time File\n" | |
1354 dash) | |
1355 (archive-summarize-files (nreverse visual)) | |
1356 (insert dash | |
1357 (format " %8d %d file%s" | |
1358 totalsize | |
1359 (length files) | |
1360 (if (= 1 (length files)) "" "s")) | |
1361 "\n")) | |
1362 (apply 'vector (nreverse files)))) | |
1363 | |
1364 (defun archive-arc-rename-entry (archive newname descr) | |
1365 (if (string-match "[:\\\\/]" newname) | |
1366 (error "File names in arc files may not contain a path")) | |
1367 (if (> (length newname) 12) | |
1368 (error "File names in arc files are limited to 12 characters")) | |
1369 (let ((name (concat newname (substring "\0\0\0\0\0\0\0\0\0\0\0\0\0" | |
1370 (length newname)))) | |
1371 buffer-read-only) | |
1372 (save-restriction | |
1373 (save-excursion | |
1374 (widen) | |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1375 (set-buffer-multibyte nil) |
11880 | 1376 (goto-char (+ archive-proper-file-start (aref descr 4) 2)) |
1377 (delete-char 13) | |
1378 (insert name))))) | |
1379 ;; ------------------------------------------------------------------------- | |
1380 ;; Section: Lzh Archives | |
1381 | |
1382 (defun archive-lzh-summarize () | |
1383 (let ((p 1) | |
1384 (totalsize 0) | |
1385 (maxlen 8) | |
1386 files | |
1387 visual) | |
20767
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1388 (while (progn (goto-char p) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1389 (looking-at "\\(.\\|\n\\)\\(.\\|\n\\)-l[hz][0-9ds]-")) |
11880 | 1390 (let* ((hsize (char-after p)) |
1391 (csize (archive-l-e (+ p 7) 4)) | |
1392 (ucsize (archive-l-e (+ p 11) 4)) | |
1393 (modtime (archive-l-e (+ p 15) 2)) | |
1394 (moddate (archive-l-e (+ p 17) 2)) | |
20767
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1395 (hdrlvl (char-after (+ p 20))) |
11880 | 1396 (fnlen (char-after (+ p 21))) |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1397 (efnname (let ((str (buffer-substring (+ p 22) (+ p 22 fnlen)))) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1398 (if file-name-coding-system |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1399 (decode-coding-string str file-name-coding-system) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1400 (string-as-multibyte str)))) |
11880 | 1401 (fiddle (string= efnname (upcase efnname))) |
1402 (ifnname (if fiddle (downcase efnname) efnname)) | |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1403 (width (string-width ifnname)) |
11880 | 1404 (p2 (+ p 22 fnlen)) |
1405 (creator (if (>= (- hsize fnlen) 24) (char-after (+ p2 2)) 0)) | |
20767
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1406 mode modestr uid gid text path prname |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1407 ) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1408 (if (= hdrlvl 0) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1409 (setq mode (if (= creator ?U) (archive-l-e (+ p2 8) 2) ?\666) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1410 uid (if (= creator ?U) (archive-l-e (+ p2 10) 2)) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1411 gid (if (= creator ?U) (archive-l-e (+ p2 12) 2))) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1412 (if (= creator ?U) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1413 (let* ((p3 (+ p2 3)) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1414 (hsize (archive-l-e p3 2)) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1415 (etype (char-after (+ p3 2)))) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1416 (while (not (= hsize 0)) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1417 (cond |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1418 ((= etype 2) (let ((i (+ p3 3))) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1419 (while (< i (+ p3 hsize)) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1420 (setq path (concat path |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1421 (if (= (char-after i) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1422 255) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1423 "/" |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1424 (char-to-string |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1425 (char-after i))))) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1426 (setq i (1+ i))))) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1427 ((= etype 80) (setq mode (archive-l-e (+ p3 3) 2))) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1428 ((= etype 81) (progn (setq uid (archive-l-e (+ p3 3) 2)) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1429 (setq gid (archive-l-e (+ p3 5) 2)))) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1430 ) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1431 (setq p3 (+ p3 hsize)) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1432 (setq hsize (archive-l-e p3 2)) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1433 (setq etype (char-after (+ p3 2))))))) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1434 (setq prname (if path (concat path ifnname) ifnname)) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1435 (setq modestr (if mode (archive-int-to-mode mode) "??????????")) |
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1436 (setq text (if archive-alternate-display |
11880 | 1437 (format " %8d %5S %5S %s" |
1438 ucsize | |
1439 (or uid "?") | |
1440 (or gid "?") | |
1441 ifnname) | |
1442 (format " %10s %8d %-11s %-8s %s" | |
1443 modestr | |
1444 ucsize | |
1445 (archive-dosdate moddate) | |
1446 (archive-dostime modtime) | |
20767
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1447 ifnname))) |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1448 (setq maxlen (max maxlen width) |
11880 | 1449 totalsize (+ totalsize ucsize) |
1450 visual (cons (vector text | |
1451 (- (length text) (length ifnname)) | |
1452 (length text)) | |
1453 visual) | |
20767
ad6c6f1bd674
(archive-find-type): Accept d or s after digit, for lzh.
Richard M. Stallman <rms@gnu.org>
parents:
20239
diff
changeset
|
1454 files (cons (vector prname ifnname fiddle mode (1- p)) |
11880 | 1455 files) |
1456 p (+ p hsize 2 csize)))) | |
1457 (goto-char (point-min)) | |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1458 (set-buffer-multibyte default-enable-multibyte-characters) |
11880 | 1459 (let ((dash (concat (if archive-alternate-display |
1460 "- -------- ----- ----- " | |
1461 "- ---------- -------- ----------- -------- ") | |
1462 (make-string maxlen ?-) | |
1463 "\n")) | |
1464 (header (if archive-alternate-display | |
1465 "M Length Uid Gid File\n" | |
1466 "M Filemode Length Date Time File\n")) | |
1467 (sumline (if archive-alternate-display | |
1468 " %8d %d file%s" | |
1469 " %8d %d file%s"))) | |
1470 (insert header dash) | |
1471 (archive-summarize-files (nreverse visual)) | |
1472 (insert dash | |
1473 (format sumline | |
1474 totalsize | |
1475 (length files) | |
1476 (if (= 1 (length files)) "" "s")) | |
1477 "\n")) | |
1478 (apply 'vector (nreverse files)))) | |
1479 | |
1480 (defconst archive-lzh-alternate-display t) | |
1481 | |
1482 (defun archive-lzh-extract (archive name) | |
1483 (archive-extract-by-stdout archive name archive-lzh-extract)) | |
1484 | |
1485 (defun archive-lzh-resum (p count) | |
1486 (let ((sum 0)) | |
1487 (while (> count 0) | |
1488 (setq count (1- count) | |
1489 sum (+ sum (char-after p)) | |
1490 p (1+ p))) | |
1491 (logand sum 255))) | |
1492 | |
1493 (defun archive-lzh-rename-entry (archive newname descr) | |
1494 (save-restriction | |
1495 (save-excursion | |
1496 (widen) | |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1497 (set-buffer-multibyte nil) |
11880 | 1498 (let* ((p (+ archive-proper-file-start (aref descr 4))) |
1499 (oldhsize (char-after p)) | |
1500 (oldfnlen (char-after (+ p 21))) | |
1501 (newfnlen (length newname)) | |
1502 (newhsize (+ oldhsize newfnlen (- oldfnlen))) | |
1503 buffer-read-only) | |
1504 (if (> newhsize 255) | |
1505 (error "The file name is too long")) | |
1506 (goto-char (+ p 21)) | |
1507 (delete-char (1+ oldfnlen)) | |
1508 (insert newfnlen newname) | |
1509 (goto-char p) | |
1510 (delete-char 2) | |
1511 (insert newhsize (archive-lzh-resum p newhsize)))))) | |
1512 | |
1513 (defun archive-lzh-ogm (newval files errtxt ofs) | |
1514 (save-restriction | |
1515 (save-excursion | |
1516 (widen) | |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1517 (set-buffer-multibyte nil) |
11880 | 1518 (while files |
1519 (let* ((fil (car files)) | |
1520 (p (+ archive-proper-file-start (aref fil 4))) | |
1521 (hsize (char-after p)) | |
1522 (fnlen (char-after (+ p 21))) | |
1523 (p2 (+ p 22 fnlen)) | |
1524 (creator (if (>= (- hsize fnlen) 24) (char-after (+ p2 2)) 0)) | |
1525 buffer-read-only) | |
1526 (if (= creator ?U) | |
1527 (progn | |
1528 (or (numberp newval) | |
1529 (setq newval (funcall newval (archive-l-e (+ p2 ofs) 2)))) | |
1530 (goto-char (+ p2 ofs)) | |
1531 (delete-char 2) | |
1532 (insert (logand newval 255) (lsh newval -8)) | |
1533 (goto-char (1+ p)) | |
1534 (delete-char 1) | |
1535 (insert (archive-lzh-resum (1+ p) hsize))) | |
1536 (message "Member %s does not have %s field" | |
1537 (aref fil 1) errtxt))) | |
1538 (setq files (cdr files)))))) | |
1539 | |
1540 (defun archive-lzh-chown-entry (newuid files) | |
1541 (archive-lzh-ogm newuid files "an uid" 10)) | |
1542 | |
1543 (defun archive-lzh-chgrp-entry (newgid files) | |
1544 (archive-lzh-ogm newgid files "a gid" 12)) | |
1545 | |
1546 (defun archive-lzh-chmod-entry (newmode files) | |
1547 (archive-lzh-ogm | |
1548 ;; This should work even though newmode will be dynamically accessed. | |
12024
8e31a35ac027
(archive-lemacs): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
11887
diff
changeset
|
1549 (function (lambda (old) (archive-calc-mode old newmode t))) |
11880 | 1550 files "a unix-style mode" 8)) |
1551 ;; ------------------------------------------------------------------------- | |
1552 ;; Section: Zip Archives | |
1553 | |
1554 (defun archive-zip-summarize () | |
1555 (goto-char (- (point-max) (- 22 18))) | |
1556 (search-backward-regexp "[P]K\005\006") | |
1557 (let ((p (1+ (archive-l-e (+ (point) 16) 4))) | |
1558 (maxlen 8) | |
1559 (totalsize 0) | |
1560 files | |
1561 visual) | |
1562 (while (string= "PK\001\002" (buffer-substring p (+ p 4))) | |
1563 (let* ((creator (char-after (+ p 5))) | |
1564 (method (archive-l-e (+ p 10) 2)) | |
1565 (modtime (archive-l-e (+ p 12) 2)) | |
1566 (moddate (archive-l-e (+ p 14) 2)) | |
1567 (ucsize (archive-l-e (+ p 24) 4)) | |
1568 (fnlen (archive-l-e (+ p 28) 2)) | |
1569 (exlen (archive-l-e (+ p 30) 2)) | |
12304
3cf4df625c3b
(archive-zip-summarize): Handle per-file comments in central directory.
Richard M. Stallman <rms@gnu.org>
parents:
12024
diff
changeset
|
1570 (fclen (archive-l-e (+ p 32) 2)) |
11880 | 1571 (lheader (archive-l-e (+ p 42) 4)) |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1572 (efnname (let ((str (buffer-substring (+ p 46) (+ p 46 fnlen)))) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1573 (if file-name-coding-system |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1574 (decode-coding-string str file-name-coding-system) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1575 (string-as-multibyte str)))) |
11880 | 1576 (isdir (and (= ucsize 0) |
1577 (string= (file-name-nondirectory efnname) ""))) | |
1578 (mode (cond ((memq creator '(2 3)) ; Unix + VMS | |
1579 (archive-l-e (+ p 40) 2)) | |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1580 ((memq creator '(0 5 6 7 10 11 15)) ; Dos etc. |
11880 | 1581 (logior ?\444 |
1582 (if isdir (logior 16384 ?\111) 0) | |
1583 (if (zerop | |
1584 (logand 1 (char-after (+ p 38)))) | |
1585 ?\222 0))) | |
1586 (t nil))) | |
1587 (modestr (if mode (archive-int-to-mode mode) "??????????")) | |
1588 (fiddle (and archive-zip-case-fiddle | |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1589 (not (not (memq creator '(0 2 4 5 9)))) |
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1590 (string= (upcase efnname) efnname))) |
11880 | 1591 (ifnname (if fiddle (downcase efnname) efnname)) |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1592 (width (string-width ifnname)) |
11880 | 1593 (text (format " %10s %8d %-11s %-8s %s" |
1594 modestr | |
1595 ucsize | |
1596 (archive-dosdate moddate) | |
1597 (archive-dostime modtime) | |
1598 ifnname))) | |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1599 (setq maxlen (max maxlen width) |
11880 | 1600 totalsize (+ totalsize ucsize) |
1601 visual (cons (vector text | |
1602 (- (length text) (length ifnname)) | |
1603 (length text)) | |
1604 visual) | |
1605 files (cons (if isdir | |
1606 nil | |
1607 (vector efnname ifnname fiddle mode | |
1608 (list (1- p) lheader))) | |
1609 files) | |
12304
3cf4df625c3b
(archive-zip-summarize): Handle per-file comments in central directory.
Richard M. Stallman <rms@gnu.org>
parents:
12024
diff
changeset
|
1610 p (+ p 46 fnlen exlen fclen)))) |
11880 | 1611 (goto-char (point-min)) |
1612 (let ((dash (concat "- ---------- -------- ----------- -------- " | |
1613 (make-string maxlen ?-) | |
1614 "\n"))) | |
1615 (insert "M Filemode Length Date Time File\n" | |
1616 dash) | |
1617 (archive-summarize-files (nreverse visual)) | |
1618 (insert dash | |
1619 (format " %8d %d file%s" | |
1620 totalsize | |
1621 (length files) | |
1622 (if (= 1 (length files)) "" "s")) | |
1623 "\n")) | |
1624 (apply 'vector (nreverse files)))) | |
1625 | |
1626 (defun archive-zip-extract (archive name) | |
1627 (if archive-zip-use-pkzip | |
1628 (archive-*-extract archive name archive-zip-extract) | |
1629 (archive-extract-by-stdout archive name archive-zip-extract))) | |
1630 | |
1631 (defun archive-zip-write-file-member (archive descr) | |
1632 (archive-*-write-file-member | |
1633 archive | |
1634 descr | |
1635 (if (aref descr 2) archive-zip-update-case archive-zip-update))) | |
1636 | |
1637 (defun archive-zip-chmod-entry (newmode files) | |
1638 (save-restriction | |
1639 (save-excursion | |
1640 (widen) | |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1641 (set-buffer-multibyte nil) |
11880 | 1642 (while files |
1643 (let* ((fil (car files)) | |
1644 (p (+ archive-proper-file-start (car (aref fil 4)))) | |
1645 (creator (char-after (+ p 5))) | |
1646 (oldmode (aref fil 3)) | |
1647 (newval (archive-calc-mode oldmode newmode t)) | |
1648 buffer-read-only) | |
1649 (cond ((memq creator '(2 3)) ; Unix + VMS | |
1650 (goto-char (+ p 40)) | |
1651 (delete-char 2) | |
1652 (insert (logand newval 255) (lsh newval -8))) | |
22062
029145c16497
(archive-tmpdir): Make the prefix of the temporary
Eli Zaretskii <eliz@gnu.org>
parents:
21570
diff
changeset
|
1653 ((memq creator '(0 5 6 7 10 11 15)) ; Dos etc. |
11880 | 1654 (goto-char (+ p 38)) |
1655 (insert (logior (logand (char-after (point)) 254) | |
1656 (logand (logxor 1 (lsh newval -7)) 1))) | |
1657 (delete-char 1)) | |
1658 (t (message "Don't know how to change mode for this member")))) | |
1659 (setq files (cdr files)))))) | |
1660 ;; ------------------------------------------------------------------------- | |
1661 ;; Section: Zoo Archives | |
1662 | |
1663 (defun archive-zoo-summarize () | |
1664 (let ((p (1+ (archive-l-e 25 4))) | |
1665 (maxlen 8) | |
1666 (totalsize 0) | |
1667 files | |
1668 visual) | |
1669 (while (and (string= "\334\247\304\375" (buffer-substring p (+ p 4))) | |
1670 (> (archive-l-e (+ p 6) 4) 0)) | |
1671 (let* ((next (1+ (archive-l-e (+ p 6) 4))) | |
1672 (moddate (archive-l-e (+ p 14) 2)) | |
1673 (modtime (archive-l-e (+ p 16) 2)) | |
1674 (ucsize (archive-l-e (+ p 20) 4)) | |
1675 (namefld (buffer-substring (+ p 38) (+ p 38 13))) | |
13339
13b7b667b18f
(archive-zoo-summarize): Handle archives with long file names.
Richard M. Stallman <rms@gnu.org>
parents:
12791
diff
changeset
|
1676 (dirtype (char-after (+ p 4))) |
13b7b667b18f
(archive-zoo-summarize): Handle archives with long file names.
Richard M. Stallman <rms@gnu.org>
parents:
12791
diff
changeset
|
1677 (lfnlen (if (= dirtype 2) (char-after (+ p 56)) 0)) |
13b7b667b18f
(archive-zoo-summarize): Handle archives with long file names.
Richard M. Stallman <rms@gnu.org>
parents:
12791
diff
changeset
|
1678 (ldirlen (if (= dirtype 2) (char-after (+ p 57)) 0)) |
20239
5bf13ca1dbac
(archive-zoo-summarize): Properly handle the case of
Andreas Schwab <schwab@suse.de>
parents:
19998
diff
changeset
|
1679 (fnlen (or (string-match "\0" namefld) 13)) |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1680 (efnname (let ((str |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1681 (concat |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1682 (if (> ldirlen 0) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1683 (concat (buffer-substring |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1684 (+ p 58 lfnlen) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1685 (+ p 58 lfnlen ldirlen -1)) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1686 "/") |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1687 "") |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1688 (if (> lfnlen 0) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1689 (buffer-substring (+ p 58) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1690 (+ p 58 lfnlen -1)) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1691 (substring namefld 0 fnlen))))) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1692 (if file-name-coding-system |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1693 (decode-coding-string str file-name-coding-system) |
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1694 (string-as-multibyte str)))) |
13339
13b7b667b18f
(archive-zoo-summarize): Handle archives with long file names.
Richard M. Stallman <rms@gnu.org>
parents:
12791
diff
changeset
|
1695 (fiddle (and (= lfnlen 0) (string= efnname (upcase efnname)))) |
11880 | 1696 (ifnname (if fiddle (downcase efnname) efnname)) |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1697 (width (string-width ifnname)) |
11880 | 1698 (text (format " %8d %-11s %-8s %s" |
1699 ucsize | |
1700 (archive-dosdate moddate) | |
1701 (archive-dostime modtime) | |
1702 ifnname))) | |
22830
d79de5a60ee8
(archive-summarize): Set buffer unibyte before
Eli Zaretskii <eliz@gnu.org>
parents:
22782
diff
changeset
|
1703 (setq maxlen (max maxlen (length width)) |
11880 | 1704 totalsize (+ totalsize ucsize) |
1705 visual (cons (vector text | |
1706 (- (length text) (length ifnname)) | |
1707 (length text)) | |
1708 visual) | |
1709 files (cons (vector efnname ifnname fiddle nil (1- p)) | |
1710 files) | |
1711 p next))) | |
1712 (goto-char (point-min)) | |
1713 (let ((dash (concat "- -------- ----------- -------- " | |
1714 (make-string maxlen ?-) | |
1715 "\n"))) | |
1716 (insert "M Length Date Time File\n" | |
1717 dash) | |
1718 (archive-summarize-files (nreverse visual)) | |
1719 (insert dash | |
1720 (format " %8d %d file%s" | |
1721 totalsize | |
1722 (length files) | |
1723 (if (= 1 (length files)) "" "s")) | |
1724 "\n")) | |
1725 (apply 'vector (nreverse files)))) | |
1726 | |
1727 (defun archive-zoo-extract (archive name) | |
1728 (archive-extract-by-stdout archive name archive-zoo-extract)) | |
1729 ;; ------------------------------------------------------------------------- | |
23467
dd5bbd8db2f5
(arc-mode): Provide arc-mode.
Richard M. Stallman <rms@gnu.org>
parents:
23383
diff
changeset
|
1730 ;; This line was a mistake; it is kept now for compatibility. |
dd5bbd8db2f5
(arc-mode): Provide arc-mode.
Richard M. Stallman <rms@gnu.org>
parents:
23383
diff
changeset
|
1731 ;; rms 15 Oct 98 |
11880 | 1732 (provide 'archive-mode) |
1733 | |
23467
dd5bbd8db2f5
(arc-mode): Provide arc-mode.
Richard M. Stallman <rms@gnu.org>
parents:
23383
diff
changeset
|
1734 (provide 'arc-mode) |
dd5bbd8db2f5
(arc-mode): Provide arc-mode.
Richard M. Stallman <rms@gnu.org>
parents:
23383
diff
changeset
|
1735 |
11880 | 1736 ;; arc-mode.el ends here. |