1 ;;; tar-mode.el --- simple editing of tar files from GNU emacs
3 ;; Copyright (C) 1990, 1991, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 ;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
6 ;; Author: Jamie Zawinski <jwz@lucid.com>
8 ;; Created: 04 Apr 1990
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software: you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation, either version 3 of the License, or
16 ;; (at your option) any later version.
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
28 ;; This package attempts to make dealing with Unix 'tar' archives easier.
29 ;; When this code is loaded, visiting a file whose name ends in '.tar' will
30 ;; cause the contents of that archive file to be displayed in a Dired-like
31 ;; listing. It is then possible to use the customary Dired keybindings to
32 ;; extract sub-files from that archive, either by reading them into their own
33 ;; editor buffers, or by copying them directly to arbitrary files on disk.
34 ;; It is also possible to delete sub-files from within the tar file and write
35 ;; the modified archive back to disk, or to edit sub-files within the archive
36 ;; and re-insert the modified files into the archive. See the documentation
37 ;; string of tar-mode for more info.
39 ;; This code now understands the extra fields that GNU tar adds to tar files.
41 ;; This interacts correctly with "uncompress.el" in the Emacs library,
44 ;; (autoload 'uncompress-while-visiting "uncompress")
45 ;; (setq auto-mode-alist (cons '("\\.Z$" . uncompress-while-visiting)
48 ;; Do not attempt to use tar-mode.el with crypt.el, you will lose.
50 ;; *************** TO DO ***************
52 ;; o chmod should understand "a+x,og-w".
54 ;; o It's not possible to add a NEW file to a tar archive; not that
55 ;; important, but still...
57 ;; o The code is less efficient that it could be - in a lot of places, I
58 ;; pull a 512-character string out of the buffer and parse it, when I could
59 ;; be parsing it in place, not garbaging a string. Should redo that.
61 ;; o I'd like a command that searches for a string/regexp in every subfile
62 ;; of an archive, where <esc> would leave you in a subfile-edit buffer.
63 ;; (Like the Meta-R command of the Zmacs mail reader.)
65 ;; o Sometimes (but not always) reverting the tar-file buffer does not
66 ;; re-grind the listing, and you are staring at the binary tar data.
67 ;; Typing 'g' again immediately after that will always revert and re-grind
68 ;; it, though. I have no idea why this happens.
70 ;; o Tar-mode interacts poorly with crypt.el and zcat.el because the tar
71 ;; write-file-hook actually writes the file. Instead it should remove the
72 ;; header (and conspire to put it back afterwards) so that other write-file
73 ;; hooks which frob the buffer have a chance to do their dirty work. There
74 ;; might be a problem if the tar write-file-hook does not come *first* on
77 ;; o Block files, sparse files, continuation files, and the various header
78 ;; types aren't editable. Actually I don't know that they work at all.
82 ;; Why does tar-mode edit the file itself instead of using tar?
84 ;; That means that you can edit tar files which you don't have room for
85 ;; on your local disk.
87 ;; I don't know about recent features in gnu tar, but old versions of tar
88 ;; can't replace a file in the middle of a tar file with a new version.
89 ;; Tar-mode can. I don't think tar can do things like chmod the subfiles.
90 ;; An implementation which involved unpacking and repacking the file into
91 ;; some scratch directory would be very wasteful, and wouldn't be able to
92 ;; preserve the file owners.
96 ;; - Expunge and rename on ././@LongLink files
97 ;; - Revert confirmation displays the raw data temporarily.
98 ;; - Incorrect goal-column if username is too long.
102 (eval-when-compile (require 'cl
))
105 "Simple editing of tar files."
109 (defcustom tar-anal-blocksize
20
110 "The blocksize of tar files written by Emacs, or nil, meaning don't care.
111 The blocksize of a tar file is not really the size of the blocks; rather, it is
112 the number of blocks written with one system call. When tarring to a tape,
113 this is the size of the *tape* blocks, but when writing to a file, it doesn't
114 matter much. The only noticeable difference is that if a tar file does not
115 have a blocksize of 20, tar will tell you that; all this really controls is
116 how many null padding bytes go on the end of the tar file."
117 :type
'(choice integer
(const nil
))
120 (defcustom tar-update-datestamp nil
121 "Non-nil means Tar mode should play fast and loose with sub-file datestamps.
122 If this is true, then editing and saving a tar file entry back into its
123 tar file will update its datestamp. If false, the datestamp is unchanged.
124 You may or may not want this - it is good in that you can tell when a file
125 in a tar archive has been changed, but it is bad for the same reason that
126 editing a file in the tar archive at all is bad - the changed version of
127 the file never exists on disk."
131 (defcustom tar-mode-show-date nil
132 "Non-nil means Tar mode should show the date/time of each subfile.
133 This information is useful, but it takes screen space away from file names."
137 (defvar tar-parse-info nil
)
138 (defvar tar-superior-buffer nil
)
139 (defvar tar-superior-descriptor nil
)
140 (defvar tar-subfile-mode nil
)
141 (defvar tar-file-name-coding-system nil
)
143 (put 'tar-superior-buffer
'permanent-local t
)
144 (put 'tar-superior-descriptor
'permanent-local t
)
146 ;; The Tar data is made up of bytes and better manipulated as bytes
147 ;; and can be very large, so insert/delete can be costly. The summary we
148 ;; want to display may contain non-ascci chars, of course, so we'd like it
149 ;; to be multibyte. We used to keep both in the same buffer and switch
150 ;; from/to uni/multibyte. But this had several downsides:
151 ;; - set-buffer-multibyte has an O(N^2) worst case that tends to be triggered
152 ;; here, so it gets atrociously slow on large Tar files.
153 ;; - need to widen/narrow the buffer to show/hide the raw data, and need to
154 ;; maintain a tar-header-offset that keeps track of the boundary between
156 ;; - can't use markers because they're not preserved by set-buffer-multibyte.
157 ;; So instead, we now keep the two pieces of data in separate buffers, and
158 ;; use the new buffer-swap-text primitive when we need to change which data
159 ;; is associated with "the" buffer.
160 (defvar tar-data-buffer nil
"Buffer that holds the actual raw tar bytes.")
161 (make-variable-buffer-local 'tar-data-buffer
)
163 (defun tar-data-swapped-p ()
164 "Return non-nil if the tar-data is in `tar-data-buffer'."
165 ;; We need to be careful to keep track of which buffer holds the tar-data,
166 ;; since we swap them back and forth. Since the user may make the summary
167 ;; buffer unibyte, we can't rely on the multibyteness of the buffers.
168 ;; We could try and recognize the tar-format signature, but instead
169 ;; I decided to go for something simpler.
170 (and (buffer-live-p tar-data-buffer
)
171 (> (buffer-size tar-data-buffer
) (buffer-size))))
174 (defmacro tar-setf
(form val
)
175 "A mind-numbingly simple implementation of setf."
176 (let ((mform (macroexpand form
(and (boundp 'byte-compile-macro-environment
)
177 byte-compile-macro-environment
))))
178 (cond ((symbolp mform
) (list 'setq mform val
))
179 ((not (consp mform
)) (error "can't setf %s" form
))
180 ((eq (car mform
) 'aref
)
181 (list 'aset
(nth 1 mform
) (nth 2 mform
) val
))
182 ((eq (car mform
) 'car
)
183 (list 'setcar
(nth 1 mform
) val
))
184 ((eq (car mform
) 'cdr
)
185 (list 'setcdr
(nth 1 mform
) val
))
186 (t (error "don't know how to setf %s" form
)))))
188 ;;; down to business.
190 (defmacro make-tar-header
(name mode uid git size date ck lt ln
191 magic uname gname devmaj devmin
)
192 (list 'vector name mode uid git size date ck lt ln
193 magic uname gname devmaj devmin
))
195 (defmacro tar-header-name
(x) (list 'aref x
0))
196 (defmacro tar-header-mode
(x) (list 'aref x
1))
197 (defmacro tar-header-uid
(x) (list 'aref x
2))
198 (defmacro tar-header-gid
(x) (list 'aref x
3))
199 (defmacro tar-header-size
(x) (list 'aref x
4))
200 (defmacro tar-header-date
(x) (list 'aref x
5))
201 (defmacro tar-header-checksum
(x) (list 'aref x
6))
202 (defmacro tar-header-link-type
(x) (list 'aref x
7))
203 (defmacro tar-header-link-name
(x) (list 'aref x
8))
204 (defmacro tar-header-magic
(x) (list 'aref x
9))
205 (defmacro tar-header-uname
(x) (list 'aref x
10))
206 (defmacro tar-header-gname
(x) (list 'aref x
11))
207 (defmacro tar-header-dmaj
(x) (list 'aref x
12))
208 (defmacro tar-header-dmin
(x) (list 'aref x
13))
210 (defmacro make-tar-desc
(data-start tokens
)
211 (list 'cons data-start tokens
))
213 (defmacro tar-desc-data-start
(x) (list 'car x
))
214 (defmacro tar-desc-tokens
(x) (list 'cdr x
))
216 (defconst tar-name-offset
0)
217 (defconst tar-mode-offset
(+ tar-name-offset
100))
218 (defconst tar-uid-offset
(+ tar-mode-offset
8))
219 (defconst tar-gid-offset
(+ tar-uid-offset
8))
220 (defconst tar-size-offset
(+ tar-gid-offset
8))
221 (defconst tar-time-offset
(+ tar-size-offset
12))
222 (defconst tar-chk-offset
(+ tar-time-offset
12))
223 (defconst tar-linkp-offset
(+ tar-chk-offset
8))
224 (defconst tar-link-offset
(+ tar-linkp-offset
1))
225 ;;; GNU-tar specific slots.
226 (defconst tar-magic-offset
(+ tar-link-offset
100))
227 (defconst tar-uname-offset
(+ tar-magic-offset
8))
228 (defconst tar-gname-offset
(+ tar-uname-offset
32))
229 (defconst tar-dmaj-offset
(+ tar-gname-offset
32))
230 (defconst tar-dmin-offset
(+ tar-dmaj-offset
8))
231 (defconst tar-prefix-offset
(+ tar-dmin-offset
8))
232 (defconst tar-end-offset
(+ tar-prefix-offset
155))
234 (defun tar-header-block-tokenize (string)
235 "Return a `tar-header' structure.
236 This is a list of name, mode, uid, gid, size,
237 write-date, checksum, link-type, and link-name."
238 (setq string
(string-as-unibyte string
))
239 (cond ((< (length string
) 512) nil
)
240 (;(some 'plusp string) ; <-- oops, massive cycle hog!
241 (or (not (= 0 (aref string
0))) ; This will do.
242 (not (= 0 (aref string
101))))
243 (let* ((name-end tar-mode-offset
)
244 (link-end (1- tar-magic-offset
))
245 (uname-end (1- tar-gname-offset
))
246 (gname-end (1- tar-dmaj-offset
))
247 (link-p (aref string tar-linkp-offset
))
248 (magic-str (substring string tar-magic-offset
(1- tar-uname-offset
)))
249 (uname-valid-p (or (string= "ustar " magic-str
) (string= "GNUtar " magic-str
)
250 (string= "ustar\0000" magic-str
)))
252 (nulsexp "[^\000]*\000"))
253 (when (string-match nulsexp string tar-name-offset
)
254 (setq name-end
(min name-end
(1- (match-end 0)))))
255 (when (string-match nulsexp string tar-link-offset
)
256 (setq link-end
(min link-end
(1- (match-end 0)))))
257 (when (string-match nulsexp string tar-uname-offset
)
258 (setq uname-end
(min uname-end
(1- (match-end 0)))))
259 (when (string-match nulsexp string tar-gname-offset
)
260 (setq gname-end
(min gname-end
(1- (match-end 0)))))
261 (setq name
(substring string tar-name-offset name-end
)
262 link-p
(if (or (= link-p
0) (= link-p ?
0))
265 (setq linkname
(substring string tar-link-offset link-end
))
266 (when (and uname-valid-p
267 (string-match nulsexp string tar-prefix-offset
)
268 (> (match-end 0) (1+ tar-prefix-offset
)))
269 (setq name
(concat (substring string tar-prefix-offset
272 (if default-enable-multibyte-characters
274 (decode-coding-string name tar-file-name-coding-system
)
276 (decode-coding-string linkname
277 tar-file-name-coding-system
)))
278 (if (and (null link-p
) (string-match "/\\'" name
)) (setq link-p
5)) ; directory
281 (tar-parse-octal-integer string tar-mode-offset tar-uid-offset
)
282 (tar-parse-octal-integer string tar-uid-offset tar-gid-offset
)
283 (tar-parse-octal-integer string tar-gid-offset tar-size-offset
)
284 (tar-parse-octal-integer string tar-size-offset tar-time-offset
)
285 (tar-parse-octal-long-integer string tar-time-offset tar-chk-offset
)
286 (tar-parse-octal-integer string tar-chk-offset tar-linkp-offset
)
290 (and uname-valid-p
(substring string tar-uname-offset uname-end
))
291 (and uname-valid-p
(substring string tar-gname-offset gname-end
))
292 (tar-parse-octal-integer string tar-dmaj-offset tar-dmin-offset
)
293 (tar-parse-octal-integer string tar-dmin-offset tar-prefix-offset
)
295 (t 'empty-tar-block
)))
298 (defun tar-parse-octal-integer (string &optional start end
)
299 (if (null start
) (setq start
0))
300 (if (null end
) (setq end
(length string
)))
301 (if (= (aref string start
) 0)
305 (setq n
(if (< (aref string start
) ?
0) n
306 (+ (* n
8) (- (aref string start
) ?
0)))
310 (defun tar-parse-octal-long-integer (string &optional start end
)
311 (if (null start
) (setq start
0))
312 (if (null end
) (setq end
(length string
)))
313 (if (= (aref string start
) 0)
318 (if (>= (aref string start
) ?
0)
319 (setq lo
(+ (* lo
8) (- (aref string start
) ?
0))
320 hi
(+ (* hi
8) (ash lo -
16))
321 lo
(logand lo
65535)))
322 (setq start
(1+ start
)))
325 (defun tar-parse-octal-integer-safe (string)
326 (if (zerop (length string
)) (error "empty string"))
328 (if (or (< c ?
0) (> c ?
7))
329 (error "`%c' is not an octal digit" c
)))
331 (tar-parse-octal-integer string
))
334 (defun tar-header-block-checksum (string)
335 "Compute and return a tar-acceptable checksum for this block."
336 (setq string
(string-as-unibyte string
))
337 (let* ((chk-field-start tar-chk-offset
)
338 (chk-field-end (+ chk-field-start
8))
341 ;; Add up all of the characters except the ones in the checksum field.
342 ;; Add that field as if it were filled with spaces.
343 (while (< i chk-field-start
)
344 (setq sum
(+ sum
(aref string i
))
346 (setq i chk-field-end
)
348 (setq sum
(+ sum
(aref string i
))
352 (defun tar-header-block-check-checksum (hblock desired-checksum file-name
)
353 "Beep and print a warning if the checksum doesn't match."
354 (if (not (= desired-checksum
(tar-header-block-checksum hblock
)))
355 (progn (beep) (message "Invalid checksum for file %s!" file-name
))))
357 (defun tar-clip-time-string (time)
358 (let ((str (current-time-string time
)))
359 (concat " " (substring str
4 16) (substring str
19 24))))
361 (defun tar-grind-file-mode (mode)
362 "Construct a `-rw--r--r--' string indicating MODE.
363 MODE should be an integer which is a file mode value."
365 (if (zerop (logand 256 mode
)) ?- ?r
)
366 (if (zerop (logand 128 mode
)) ?- ?w
)
367 (if (zerop (logand 1024 mode
)) (if (zerop (logand 64 mode
)) ?- ?x
) ?s
)
368 (if (zerop (logand 32 mode
)) ?- ?r
)
369 (if (zerop (logand 16 mode
)) ?- ?w
)
370 (if (zerop (logand 2048 mode
)) (if (zerop (logand 8 mode
)) ?- ?x
) ?s
)
371 (if (zerop (logand 4 mode
)) ?- ?r
)
372 (if (zerop (logand 2 mode
)) ?- ?w
)
373 (if (zerop (logand 1 mode
)) ?- ?x
)))
375 (defun tar-header-block-summarize (tar-hblock &optional mod-p
)
376 "Return a line similar to the output of `tar -vtf'."
377 (let ((name (tar-header-name tar-hblock
))
378 (mode (tar-header-mode tar-hblock
))
379 (uid (tar-header-uid tar-hblock
))
380 (gid (tar-header-gid tar-hblock
))
381 (uname (tar-header-uname tar-hblock
))
382 (gname (tar-header-gname tar-hblock
))
383 (size (tar-header-size tar-hblock
))
384 (time (tar-header-date tar-hblock
))
385 ;; (ck (tar-header-checksum tar-hblock))
386 (type (tar-header-link-type tar-hblock
))
387 (link-name (tar-header-link-name tar-hblock
)))
388 (format "%c%c%s%8s/%-8s%7s%s %s%s"
390 (cond ((or (eq type nil
) (eq type
0)) ?-
)
391 ((eq type
1) ?h
) ; link
392 ((eq type
2) ?l
) ; symlink
393 ((eq type
3) ?c
) ; char special
394 ((eq type
4) ?b
) ; block special
395 ((eq type
5) ?d
) ; directory
396 ((eq type
6) ?p
) ; FIFO/pipe
397 ((eq type
20) ?
*) ; directory listing
398 ((eq type
28) ?L
) ; next has longname
399 ((eq type
29) ?M
) ; multivolume continuation
400 ((eq type
35) ?S
) ; sparse
401 ((eq type
38) ?V
) ; volume header
402 ((eq type
55) ?H
) ; extended pax header
405 (tar-grind-file-mode mode
)
406 (if (= 0 (length uname
)) uid uname
)
407 (if (= 0 (length gname
)) gid gname
)
409 (if tar-mode-show-date
(tar-clip-time-string time
) "")
411 'mouse-face
'highlight
412 'help-echo
"mouse-2: extract this file into a buffer")
413 (if (or (eq type
1) (eq type
2))
414 (concat (if (= type
1) " ==> " " --> ") link-name
)
417 (defun tar-untar-buffer ()
418 "Extract all archive members in the tar-file into the current directory."
420 ;; FIXME: make it work even if we're not in tar-mode.
421 (let ((descriptors tar-parse-info
)) ;Read the var in its buffer.
423 (if (tar-data-swapped-p) tar-data-buffer
(current-buffer))
424 (set-buffer-multibyte nil
) ;Hopefully, a no-op.
425 (dolist (descriptor descriptors
)
426 (let* ((tokens (tar-desc-tokens descriptor
))
427 (name (tar-header-name tokens
))
428 (dir (if (eq (tar-header-link-type tokens
) 5)
430 (file-name-directory name
)))
431 (start (tar-desc-data-start descriptor
))
432 (end (+ start
(tar-header-size tokens
))))
433 (unless (file-directory-p name
)
434 (message "Extracting %s" name
)
435 (if (and dir
(not (file-exists-p dir
)))
436 (make-directory dir t
))
437 (unless (file-directory-p name
)
438 (write-region start end name
))
439 (set-file-modes name
(tar-header-mode tokens
))))))))
441 (defun tar-summarize-buffer ()
442 "Parse the contents of the tar file in the current buffer.
443 Place a dired-like listing on the front;
444 then narrow to it, so that only that listing
445 is visible (and the real data of the buffer is hidden)."
446 (assert (tar-data-swapped-p))
447 (let* ((modified (buffer-modified-p))
451 (make-progress-reporter "Parsing tar file..."
452 (point-min) (max 1 (- (buffer-size) 1024))))
454 (with-current-buffer tar-data-buffer
455 (while (and (<= (+ pos
512) (point-max))
456 (not (eq 'empty-tar-block
458 (tar-header-block-tokenize
459 (buffer-substring pos
(+ pos
512)))))))
460 (setq pos
(+ pos
512))
461 (when (equal (tar-header-name tokens
) "././@LongLink")
462 ;; This is a GNU Tar long-file-name header.
463 (let* ((size (tar-header-size tokens
))
464 ;; -1 so as to strip the terminating 0 byte.
465 (name (buffer-substring pos
(+ pos size -
1))))
466 (setq pos
(+ pos
(ash (ash (+ 511 size
) -
9) 9)))
467 (setq tokens
(tar-header-block-tokenize
468 (buffer-substring pos
(+ pos
512))))
469 (tar-setf (tar-header-name tokens
) name
)
470 (setq pos
(+ pos
512))))
471 (progress-reporter-update progress-reporter pos
)
472 (if (memq (tar-header-link-type tokens
) '(20 55))
473 ;; Foo. There's an extra empty block after these.
474 (setq pos
(+ pos
512)))
475 (let ((size (tar-header-size tokens
)))
477 (error "%s has size %s - corrupted"
478 (tar-header-name tokens
) size
))
480 ;; This is just too slow. Don't really need it anyway....
481 ;;(tar-header-block-check-checksum
482 ;; hblock (tar-header-block-checksum hblock)
483 ;; (tar-header-name tokens))
485 (push (make-tar-desc pos tokens
) result
)
487 (and (null (tar-header-link-type tokens
))
489 ;; Round up to a multiple of 512.
490 (setq pos
(+ pos
(ash (ash (+ 511 size
) -
9) 9)))))))
491 (make-local-variable 'tar-parse-info
)
492 (setq tar-parse-info
(nreverse result
))
493 ;; A tar file should end with a block or two of nulls,
494 ;; but let's not get a fatal error if it doesn't.
495 (if (eq tokens
'empty-tar-block
)
496 (progress-reporter-done progress-reporter
)
497 (message "Warning: premature EOF parsing tar file"))
498 (goto-char (point-min))
499 (let ((inhibit-read-only t
)
503 (tar-header-block-summarize (tar-desc-tokens tar-desc
)))
506 (insert total-summaries
"\n"))
507 (goto-char (point-min))
508 (restore-buffer-modified-p modified
)))
511 (let ((map (make-keymap)))
512 (suppress-keymap map
)
513 (define-key map
" " 'tar-next-line
)
514 (define-key map
"C" 'tar-copy
)
515 (define-key map
"d" 'tar-flag-deleted
)
516 (define-key map
"\^D" 'tar-flag-deleted
)
517 (define-key map
"e" 'tar-extract
)
518 (define-key map
"f" 'tar-extract
)
519 (define-key map
"\C-m" 'tar-extract
)
520 (define-key map
[mouse-2
] 'tar-mouse-extract
)
521 (define-key map
"g" 'revert-buffer
)
522 (define-key map
"h" 'describe-mode
)
523 (define-key map
"n" 'tar-next-line
)
524 (define-key map
"\^N" 'tar-next-line
)
525 (define-key map
[down] 'tar-next-line)
526 (define-key map "o" 'tar-extract-other-window)
527 (define-key map "p" 'tar-previous-line)
528 (define-key map "q" 'quit-window)
529 (define-key map "\^P" 'tar-previous-line)
530 (define-key map [up] 'tar-previous-line)
531 (define-key map "R" 'tar-rename-entry)
532 (define-key map "u" 'tar-unflag)
533 (define-key map "v" 'tar-view)
534 (define-key map "x" 'tar-expunge)
535 (define-key map "\177" 'tar-unflag-backwards)
536 (define-key map "E" 'tar-extract-other-window)
537 (define-key map "M" 'tar-chmod-entry)
538 (define-key map "G" 'tar-chgrp-entry)
539 (define-key map "O" 'tar-chown-entry)
540 ;; Let mouse-1 follow the link.
541 (define-key map [follow-link] 'mouse-face)
543 ;; Make menu bar items.
545 ;; Get rid of the Edit menu bar item to save space.
546 (define-key map [menu-bar edit] 'undefined)
548 (define-key map [menu-bar immediate]
549 (cons "Immediate" (make-sparse-keymap "Immediate")))
551 (define-key map [menu-bar immediate view]
552 '("View This File" . tar-view))
553 (define-key map [menu-bar immediate display]
554 '("Display in Other Window" . tar-display-other-window))
555 (define-key map [menu-bar immediate find-file-other-window]
556 '("Find in Other Window" . tar-extract-other-window))
557 (define-key map [menu-bar immediate find-file]
558 '("Find This File" . tar-extract))
560 (define-key map [menu-bar mark]
561 (cons "Mark" (make-sparse-keymap "Mark")))
563 (define-key map [menu-bar mark unmark-all]
564 '("Unmark All" . tar-clear-modification-flags))
565 (define-key map [menu-bar mark deletion]
566 '("Flag" . tar-flag-deleted))
567 (define-key map [menu-bar mark unmark]
568 '("Unflag" . tar-unflag))
570 (define-key map [menu-bar operate]
571 (cons "Operate" (make-sparse-keymap "Operate")))
573 (define-key map [menu-bar operate chown]
574 '("Change Owner..." . tar-chown-entry))
575 (define-key map [menu-bar operate chgrp]
576 '("Change Group..." . tar-chgrp-entry))
577 (define-key map [menu-bar operate chmod]
578 '("Change Mode..." . tar-chmod-entry))
579 (define-key map [menu-bar operate rename]
580 '("Rename to..." . tar-rename-entry))
581 (define-key map [menu-bar operate copy]
582 '("Copy to..." . tar-copy))
583 (define-key map [menu-bar operate expunge]
584 '("Expunge Marked Files" . tar-expunge))
587 "Local keymap for Tar mode listings.")
590 ;; tar mode is suitable only for specially formatted data.
591 (put 'tar-mode 'mode-class 'special)
592 (put 'tar-subfile-mode 'mode-class 'special)
594 (defun tar-change-major-mode-hook ()
595 ;; Bring the actual Tar data back into the main buffer.
596 (when (tar-data-swapped-p) (buffer-swap-text tar-data-buffer))
597 ;; Throw away the summary.
598 (when (buffer-live-p tar-data-buffer) (kill-buffer tar-data-buffer)))
600 (defun tar-mode-kill-buffer-hook ()
601 (if (buffer-live-p tar-data-buffer) (kill-buffer tar-data-buffer)))
604 (define-derived-mode tar-mode nil "Tar"
605 "Major mode for viewing a tar file as a dired-like listing of its contents.
606 You can move around using the usual cursor motion commands.
607 Letters no longer insert themselves.
608 Type `e' to pull a file out of the tar file and into its own buffer;
609 or click mouse-2 on the file's line in the Tar mode buffer.
610 Type `c' to copy an entry from the tar file into another file on disk.
612 If you edit a sub-file of this archive (as with the `e' command) and
613 save it with \\[save-buffer], the contents of that buffer will be
614 saved back into the tar-file buffer; in this way you can edit a file
615 inside of a tar archive without extracting it and re-archiving it.
617 See also: variables `tar-update-datestamp' and `tar-anal-blocksize'.
619 ;; this is not interactive because you shouldn't be turning this
620 ;; mode on and off. You can corrupt things that way.
621 ;; rms: with permanent locals, it should now be possible to make this work
622 ;; interactively in some reasonable fashion.
623 (make-local-variable 'tar-parse-info)
624 (set (make-local-variable 'require-final-newline) nil) ; binary data, dude...
625 (set (make-local-variable 'local-enable-local-variables) nil)
626 (set (make-local-variable 'next-line-add-newlines) nil)
627 (set (make-local-variable 'tar-file-name-coding-system)
628 (or file-name-coding-system
629 default-file-name-coding-system
630 locale-coding-system))
631 ;; Prevent loss of data when saving the file.
632 (set (make-local-variable 'file-precious-flag) t)
634 (buffer-disable-undo)
636 ;; Now move the Tar data into an auxiliary buffer, so we can use the main
637 ;; buffer for the summary.
638 (assert (not (tar-data-swapped-p)))
639 (set (make-local-variable 'revert-buffer-function) 'tar-mode-revert)
640 (set (make-local-variable 'write-contents-functions) '(tar-mode-write-file))
641 (add-hook 'kill-buffer-hook 'tar-mode-kill-buffer-hook nil t)
642 (add-hook 'change-major-mode-hook 'tar-change-major-mode-hook nil t)
643 ;; Tar data is made of bytes, not chars.
644 (set-buffer-multibyte nil)
645 (set (make-local-variable 'tar-data-buffer)
646 (generate-new-buffer (format " *tar-data %s*"
647 (file-name-nondirectory
648 (or buffer-file-name (buffer-name))))))
649 (buffer-swap-text tar-data-buffer)
650 (tar-summarize-buffer)
654 (defun tar-subfile-mode (p)
655 "Minor mode for editing an element of a tar-file.
656 This mode arranges for \"saving\" this buffer to write the data
657 into the tar-file buffer that it came from. The changes will actually
658 appear on disk when you save the tar-file's buffer."
660 (or (and (boundp 'tar-superior-buffer) tar-superior-buffer)
661 (error "This buffer is not an element of a tar file"))
662 ;; Don't do this, because it is redundant and wastes mode line space.
663 ;; (or (assq 'tar-subfile-mode minor-mode-alist)
664 ;; (setq minor-mode-alist (append minor-mode-alist
665 ;; (list '(tar-subfile-mode " TarFile")))))
666 (make-local-variable 'tar-subfile-mode)
667 (setq tar-subfile-mode
669 (not tar-subfile-mode)
670 (> (prefix-numeric-value p) 0)))
671 (cond (tar-subfile-mode
672 (add-hook 'write-file-functions 'tar-subfile-save-buffer nil t)
673 ;; turn off auto-save.
675 (setq buffer-auto-save-file-name nil)
676 (run-hooks 'tar-subfile-mode-hook))
678 (remove-hook 'write-file-functions 'tar-subfile-save-buffer t))))
681 ;; Revert the buffer and recompute the dired-like listing.
682 (defun tar-mode-revert (&optional no-auto-save no-confirm)
684 (let ((revert-buffer-function nil))
685 (if (tar-data-swapped-p) (buffer-swap-text tar-data-buffer))
686 ;; FIXME: If we ask for confirmation, the user will be temporarily
687 ;; looking at the raw data.
688 (revert-buffer no-auto-save no-confirm 'preserve-modes)
689 ;; The new raw data may be smaller than the old summary, so let's
690 ;; make sure tar-data-swapped-p doesn't get confused.
691 (if (buffer-live-p tar-data-buffer) (kill-buffer tar-data-buffer))
692 ;; Recompute the summary.
694 (unless (tar-data-swapped-p) (buffer-swap-text tar-data-buffer))))
697 (defun tar-next-line (arg)
698 "Move cursor vertically down ARG lines and to the start of the filename."
701 (if (eobp) nil (forward-char (if tar-mode-show-date 54 36))))
703 (defun tar-previous-line (arg)
704 "Move cursor vertically up ARG lines and to the start of the filename."
706 (tar-next-line (- arg)))
708 (defun tar-current-descriptor (&optional noerror)
709 "Return the tar-descriptor of the current line, or signals an error."
710 ;; I wish lines had plists, like in ZMACS...
711 (or (nth (count-lines (point-min) (line-beginning-position))
715 (error "This line does not describe a tar-file entry"))))
717 (defun tar-get-descriptor ()
718 (let* ((descriptor (tar-current-descriptor))
719 (tokens (tar-desc-tokens descriptor))
720 (size (tar-header-size tokens))
721 (link-p (tar-header-link-type tokens)))
723 (error "This is %s, not a real file"
724 (cond ((eq link-p 5) "a directory")
725 ((eq link-p 20) "a tar directory header")
726 ((eq link-p 28) "a next has longname")
727 ((eq link-p 29) "a multivolume-continuation")
728 ((eq link-p 35) "a sparse entry")
729 ((eq link-p 38) "a volume header")
730 ((eq link-p 55) "an extended pax header")
732 (if (zerop size) (message "This is a zero-length file"))
735 (defun tar-mouse-extract (event)
736 "Extract a file whose tar directory line you click on."
738 (with-current-buffer (window-buffer (posn-window (event-end event)))
740 (goto-char (posn-point (event-end event)))
741 ;; Just make sure this doesn't get an error.
742 (tar-get-descriptor)))
743 (select-window (posn-window (event-end event)))
744 (goto-char (posn-point (event-end event)))
747 (defun tar-file-name-handler (op &rest args)
748 "Helper function for `tar-extract'."
749 (or (eq op 'file-exists-p)
750 (let ((file-name-handler-alist nil))
753 (defun tar-extract (&optional other-window-p)
754 "In Tar mode, extract this entry of the tar file into its own buffer."
756 (let* ((view-p (eq other-window-p 'view))
757 (descriptor (tar-get-descriptor))
758 (tokens (tar-desc-tokens descriptor))
759 (name (tar-header-name tokens))
760 (size (tar-header-size tokens))
761 (start (tar-desc-data-start descriptor))
762 (end (+ start size)))
763 (let* ((tar-buffer (current-buffer))
764 (tarname (buffer-name))
765 (bufname (concat (file-name-nondirectory name)
769 (read-only-p (or buffer-read-only view-p))
770 (new-buffer-file-name (expand-file-name
771 ;; `:' is not allowed on Windows
772 (concat tarname "!" name)))
773 (buffer (get-file-buffer new-buffer-file-name))
778 (setq buffer (generate-new-buffer bufname))
779 (with-current-buffer buffer
780 (setq undo-list buffer-undo-list
782 (setq bufname (buffer-name buffer))
783 (setq just-created t)
784 (with-current-buffer tar-data-buffer
786 (narrow-to-region start end)
788 (setq coding (or coding-system-for-read
789 (and set-auto-coding-function
790 (funcall set-auto-coding-function
792 ;; The following binding causes
793 ;; find-buffer-file-type-coding-system
794 ;; (defined on dos-w32.el) to act as if
795 ;; the file being extracted existed, so
796 ;; that the file's contents' encoding and
797 ;; EOL format are auto-detected.
798 (let ((file-name-handler-alist
799 '(("" . tar-file-name-handler))))
800 (car (find-operation-coding-system
801 'insert-file-contents
802 (cons name (current-buffer)) t)))))
804 (eq (coding-system-type coding) 'undecided))
805 (setq coding (detect-coding-region start end t)))
806 (if (and default-enable-multibyte-characters
807 (coding-system-get coding :for-unibyte))
808 (with-current-buffer buffer
809 (set-buffer-multibyte nil)))
811 (decode-coding-region start end coding buffer)))
812 (with-current-buffer buffer
813 (goto-char (point-min))
814 (setq buffer-file-name new-buffer-file-name)
815 (setq buffer-file-truename
816 (abbreviate-file-name buffer-file-name))
817 ;; Force buffer-file-coding-system to what
818 ;; decode-coding-region actually used.
819 (set-buffer-file-coding-system last-coding-system-used t)
820 ;; Set the default-directory to the dir of the
822 (setq default-directory
823 (with-current-buffer tar-buffer
825 (normal-mode) ; pick a mode.
826 (rename-buffer bufname)
827 (make-local-variable 'tar-superior-buffer)
828 (make-local-variable 'tar-superior-descriptor)
829 (setq tar-superior-buffer tar-buffer)
830 (setq tar-superior-descriptor descriptor)
831 (setq buffer-read-only read-only-p)
832 (set-buffer-modified-p nil)
833 (setq buffer-undo-list undo-list)
834 (tar-subfile-mode 1)))
837 buffer (and just-created 'kill-buffer-if-not-modified))
838 (if (eq other-window-p 'display)
839 (display-buffer buffer)
841 (switch-to-buffer-other-window buffer)
842 (switch-to-buffer buffer)))))))
845 (defun tar-extract-other-window ()
846 "In Tar mode, find this entry of the tar file in another window."
850 (defun tar-display-other-window ()
851 "In Tar mode, display this entry of the tar file in another window."
853 (tar-extract 'display))
856 "In Tar mode, view the tar file entry on this line."
861 (defun tar-read-file-name (&optional prompt)
862 "Read a file name with this line's entry as the default."
863 (or prompt (setq prompt "Copy to: "))
864 (let* ((default-file (expand-file-name
865 (tar-header-name (tar-desc-tokens
866 (tar-current-descriptor)))))
867 (target (expand-file-name
868 (read-file-name prompt
869 (file-name-directory default-file)
871 (if (or (string= "" (file-name-nondirectory target))
872 (file-directory-p target))
873 (setq target (concat (if (string-match "/$" target)
874 (substring target 0 (1- (match-end 0)))
877 (file-name-nondirectory default-file))))
881 (defun tar-copy (&optional to-file)
882 "In Tar mode, extract this entry of the tar file into a file on disk.
883 If TO-FILE is not supplied, it is prompted for, defaulting to the name of
884 the current tar-entry."
885 (interactive (list (tar-read-file-name)))
886 (let* ((descriptor (tar-get-descriptor))
887 (tokens (tar-desc-tokens descriptor))
888 (name (tar-header-name tokens))
889 (size (tar-header-size tokens))
890 (start (tar-desc-data-start descriptor))
892 (inhibit-file-name-handlers inhibit-file-name-handlers)
893 (inhibit-file-name-operation inhibit-file-name-operation))
896 ;; Inhibit compressing a subfile again if *both* name and
897 ;; to-file are handled by jka-compr
898 (if (and (eq (find-file-name-handler name 'write-region) 'jka-compr-handler)
899 (eq (find-file-name-handler to-file 'write-region) 'jka-compr-handler))
900 (setq inhibit-file-name-handlers
901 (cons 'jka-compr-handler
902 (and (eq inhibit-file-name-operation 'write-region)
903 inhibit-file-name-handlers))
904 inhibit-file-name-operation 'write-region))
905 (let ((coding-system-for-write 'no-conversion))
906 (write-region start end to-file nil nil nil t)))
907 (message "Copied tar entry %s to %s" name to-file)))
909 (defun tar-flag-deleted (p &optional unflag)
910 "In Tar mode, mark this sub-file to be deleted from the tar file.
911 With a prefix argument, mark that many files."
915 (if (tar-current-descriptor unflag) ; barf if we're not on an entry-line.
918 (insert (if unflag " " "D"))))
919 (forward-line (if (< p 0) -1 1)))
920 (if (eobp) nil (forward-char 36)))
922 (defun tar-unflag (p)
923 "In Tar mode, un-mark this sub-file if it is marked to be deleted.
924 With a prefix argument, un-mark that many files forward."
926 (tar-flag-deleted p t))
928 (defun tar-unflag-backwards (p)
929 "In Tar mode, un-mark this sub-file if it is marked to be deleted.
930 With a prefix argument, un-mark that many files backward."
932 (tar-flag-deleted (- p) t))
935 (defun tar-expunge-internal ()
936 "Expunge the tar-entry specified by the current line."
937 (let* ((descriptor (tar-current-descriptor))
938 (tokens (tar-desc-tokens descriptor))
939 ;; (line (tar-desc-data-start descriptor))
940 (name (tar-header-name tokens))
941 (size (tar-header-size tokens))
942 (link-p (tar-header-link-type tokens))
943 (start (tar-desc-data-start descriptor))
944 (following-descs (cdr (memq descriptor tar-parse-info))))
945 (if link-p (setq size 0)) ; size lies for hard-links.
947 ;; delete the current line...
948 (delete-region (line-beginning-position) (line-beginning-position 2))
950 ;; delete the data pointer...
951 (setq tar-parse-info (delq descriptor tar-parse-info))
953 ;; delete the data from inside the file...
954 (let* ((data-start (+ start -512))
955 (data-end (+ data-start 512 (ash (ash (+ size 511) -9) 9))))
956 (with-current-buffer tar-data-buffer
957 (delete-region data-start data-end))
959 ;; and finally, decrement the start-pointers of all following
960 ;; entries in the archive. This is a pig when deleting a bunch
961 ;; of files at once - we could optimize this to only do the
962 ;; iteration over the files that remain, or only iterate up to
963 ;; the next file to be deleted.
964 (let ((data-length (- data-end data-start)))
965 (dolist (desc following-descs)
966 (tar-setf (tar-desc-data-start desc)
967 (- (tar-desc-data-start desc) data-length))))
971 (defun tar-expunge (&optional noconfirm)
972 "In Tar mode, delete all the archived files flagged for deletion.
973 This does not modify the disk image; you must save the tar file itself
974 for this to be permanent."
977 (y-or-n-p "Expunge files marked for deletion? "))
980 (goto-char (point-min))
983 (progn (tar-expunge-internal)
986 ;; after doing the deletions, add any padding that may be necessary.
987 (tar-pad-to-blocksize))
989 (message "Nothing to expunge.")
990 (message "%s files expunged. Be sure to save this buffer." n)))))
993 (defun tar-clear-modification-flags ()
994 "Remove the stars at the beginning of each line."
997 (goto-char (point-min))
999 (if (not (eq (following-char) ?\s))
1000 (progn (delete-char 1) (insert " ")))
1004 (defun tar-chown-entry (new-uid)
1005 "Change the user-id associated with this entry in the tar file.
1006 If this tar file was written by GNU tar, then you will be able to edit
1007 the user id as a string; otherwise, you must edit it as a number.
1008 You can force editing as a number by calling this with a prefix arg.
1009 This does not modify the disk image; you must save the tar file itself
1010 for this to be permanent."
1012 (let ((tokens (tar-desc-tokens (tar-current-descriptor))))
1013 (if (or current-prefix-arg
1014 (not (tar-header-magic tokens)))
1016 (while (not (numberp (setq n (read-minibuffer
1018 (format "%s" (tar-header-uid tokens)))))))
1020 (read-string "New UID string: " (tar-header-uname tokens))))))
1021 (cond ((stringp new-uid)
1022 (tar-setf (tar-header-uname (tar-desc-tokens (tar-current-descriptor)))
1024 (tar-alter-one-field tar-uname-offset (concat new-uid "\000")))
1026 (tar-setf (tar-header-uid (tar-desc-tokens (tar-current-descriptor)))
1028 (tar-alter-one-field tar-uid-offset
1029 (concat (substring (format "%6o" new-uid) 0 6) "\000 ")))))
1032 (defun tar-chgrp-entry (new-gid)
1033 "Change the group-id associated with this entry in the tar file.
1034 If this tar file was written by GNU tar, then you will be able to edit
1035 the group id as a string; otherwise, you must edit it as a number.
1036 You can force editing as a number by calling this with a prefix arg.
1037 This does not modify the disk image; you must save the tar file itself
1038 for this to be permanent."
1040 (let ((tokens (tar-desc-tokens (tar-current-descriptor))))
1041 (if (or current-prefix-arg
1042 (not (tar-header-magic tokens)))
1044 (while (not (numberp (setq n (read-minibuffer
1046 (format "%s" (tar-header-gid tokens)))))))
1048 (read-string "New GID string: " (tar-header-gname tokens))))))
1049 (cond ((stringp new-gid)
1050 (tar-setf (tar-header-gname (tar-desc-tokens (tar-current-descriptor)))
1052 (tar-alter-one-field tar-gname-offset
1053 (concat new-gid "\000")))
1055 (tar-setf (tar-header-gid (tar-desc-tokens (tar-current-descriptor)))
1057 (tar-alter-one-field tar-gid-offset
1058 (concat (substring (format "%6o" new-gid) 0 6) "\000 ")))))
1060 (defun tar-rename-entry (new-name)
1061 "Change the name associated with this entry in the tar file.
1062 This does not modify the disk image; you must save the tar file itself
1063 for this to be permanent."
1065 (list (read-string "New name: "
1066 (tar-header-name (tar-desc-tokens (tar-current-descriptor))))))
1067 (if (string= "" new-name) (error "zero length name"))
1068 (let ((encoded-new-name (encode-coding-string new-name
1069 tar-file-name-coding-system)))
1070 (if (> (length encoded-new-name) 98) (error "name too long"))
1071 (tar-setf (tar-header-name (tar-desc-tokens (tar-current-descriptor)))
1073 (tar-alter-one-field 0
1074 (substring (concat encoded-new-name (make-string 99 0)) 0 99))))
1077 (defun tar-chmod-entry (new-mode)
1078 "Change the protection bits associated with this entry in the tar file.
1079 This does not modify the disk image; you must save the tar file itself
1080 for this to be permanent."
1081 (interactive (list (tar-parse-octal-integer-safe
1082 (read-string "New protection (octal): "))))
1083 (tar-setf (tar-header-mode (tar-desc-tokens (tar-current-descriptor)))
1085 (tar-alter-one-field tar-mode-offset
1086 (concat (substring (format "%6o" new-mode) 0 6) "\000 ")))
1089 (defun tar-alter-one-field (data-position new-data-string)
1090 (let* ((descriptor (tar-current-descriptor))
1091 (tokens (tar-desc-tokens descriptor)))
1093 ;; update the header-line.
1094 (let ((col (current-column)))
1095 (delete-region (line-beginning-position) (line-beginning-position 2))
1096 (insert (tar-header-block-summarize tokens) "\n")
1097 (forward-line -1) (move-to-column col))
1099 (with-current-buffer tar-data-buffer
1100 (let* ((start (+ (tar-desc-data-start descriptor)
1103 ;; delete the old field and insert a new one.
1104 (goto-char (+ start data-position))
1105 (delete-region (point) (+ (point) (length new-data-string))) ; <--
1107 (assert (not (or enable-multibyte-characters
1108 (multibyte-string-p new-data-string))))
1109 (insert new-data-string)
1111 ;; compute a new checksum and insert it.
1112 (let ((chk (tar-header-block-checksum
1113 (buffer-substring start (+ start 512)))))
1114 (goto-char (+ start tar-chk-offset))
1115 (delete-region (point) (+ (point) 8))
1116 (insert (format "%6o" chk))
1119 (tar-setf (tar-header-checksum tokens) chk)
1121 ;; ok, make sure we didn't botch it.
1122 (tar-header-block-check-checksum
1123 (buffer-substring start (+ start 512))
1124 chk (tar-header-name tokens))
1128 (defun tar-octal-time (timeval)
1129 ;; Format a timestamp as 11 octal digits. Ghod, I hope this works...
1130 (let ((hibits (car timeval)) (lobits (car (cdr timeval))))
1131 (format "%05o%01o%05o"
1133 (logior (lsh (logand 3 hibits) 1)
1134 (if (> (logand lobits 32768) 0) 1 0))
1135 (logand 32767 lobits)
1138 (defun tar-subfile-save-buffer ()
1139 "In tar subfile mode, save this buffer into its parent tar-file buffer.
1140 This doesn't write anything to disk; you must save the parent tar-file buffer
1141 to make your changes permanent."
1143 (if (not (and (boundp 'tar-superior-buffer) tar-superior-buffer))
1144 (error "This buffer has no superior tar file buffer"))
1145 (if (not (and (boundp 'tar-superior-descriptor) tar-superior-descriptor))
1146 (error "This buffer doesn't have an index into its superior tar file!"))
1147 (let ((subfile (current-buffer))
1148 (coding buffer-file-coding-system)
1149 (descriptor tar-superior-descriptor)
1151 (with-current-buffer tar-superior-buffer
1152 (let* ((tokens (tar-desc-tokens descriptor))
1153 (start (tar-desc-data-start descriptor))
1154 (name (tar-header-name tokens))
1155 (size (tar-header-size tokens))
1156 (size-pad (ash (ash (+ size 511) -9) 9))
1157 (head (memq descriptor tar-parse-info))
1158 (following-descs (cdr head)))
1160 (error "Can't find this tar file entry in its parent tar file!"))
1161 (with-current-buffer tar-data-buffer
1162 ;; delete the old data...
1163 (let* ((data-start start)
1164 (data-end (+ data-start (ash (ash (+ size 511) -9) 9))))
1165 (narrow-to-region data-start data-end)
1166 (delete-region (point-min) (point-max))
1167 ;; insert the new data...
1168 (goto-char data-start)
1169 (let ((dest (current-buffer)))
1170 (with-current-buffer subfile
1173 (encode-coding-region (point-min) (point-max) coding dest))))
1174 (setq subfile-size (- (point-max) (point-min)))
1176 ;; pad the new data out to a multiple of 512...
1177 (let ((subfile-size-pad (ash (ash (+ subfile-size 511) -9) 9)))
1178 (goto-char (point-max))
1179 (insert (make-string (- subfile-size-pad subfile-size) 0))
1181 ;; update the data pointer of this and all following files...
1182 (tar-setf (tar-header-size tokens) subfile-size)
1183 (let ((difference (- subfile-size-pad size-pad)))
1184 (dolist (desc following-descs)
1185 (tar-setf (tar-desc-data-start desc)
1186 (+ (tar-desc-data-start desc) difference))))
1188 ;; Update the size field in the header block.
1190 (let ((header-start (- data-start 512)))
1191 (goto-char (+ header-start tar-size-offset))
1192 (delete-region (point) (+ (point) 12))
1193 (insert (format "%11o" subfile-size))
1196 ;; Maybe update the datestamp.
1197 (if (not tar-update-datestamp)
1199 (goto-char (+ header-start tar-time-offset))
1200 (delete-region (point) (+ (point) 12))
1201 (insert (tar-octal-time (current-time)))
1204 ;; compute a new checksum and insert it.
1205 (let ((chk (tar-header-block-checksum
1206 (buffer-substring header-start data-start))))
1207 (goto-char (+ header-start tar-chk-offset))
1208 (delete-region (point) (+ (point) 8))
1209 (insert (format "%6o" chk))
1212 (tar-setf (tar-header-checksum tokens) chk))))))
1214 ;; alter the descriptor-line...
1216 (let ((position (- (length tar-parse-info) (length head))))
1217 (goto-char (point-min))
1218 (forward-line position)
1223 (setq after (point))
1224 ;; Insert the new text after the old, before deleting,
1225 ;; to preserve the window start.
1226 (let ((line (tar-header-block-summarize tokens t)))
1227 (insert-before-markers line "\n"))
1228 (delete-region p after)))
1229 ;; After doing the insertion, add any necessary final padding.
1230 (tar-pad-to-blocksize))
1231 (set-buffer-modified-p t) ; mark the tar file as modified
1233 (set-buffer-modified-p nil) ; mark the tar subfile as unmodified
1234 (message "Saved into tar-buffer `%s'. Be sure to save that buffer!"
1235 (buffer-name tar-superior-buffer))
1236 ;; Prevent basic-save-buffer from changing our coding-system.
1237 (setq last-coding-system-used buffer-file-coding-system)
1238 ;; Prevent ordinary saving from happening.
1242 ;; When this function is called, it is sure that the buffer is unibyte.
1243 (defun tar-pad-to-blocksize ()
1244 "If we are being anal about tar file blocksizes, fix up the current buffer.
1245 Leaves the region wide."
1246 (if (null tar-anal-blocksize)
1248 (let* ((last-desc (nth (1- (length tar-parse-info)) tar-parse-info))
1249 (start (tar-desc-data-start last-desc))
1250 (tokens (tar-desc-tokens last-desc))
1251 (link-p (tar-header-link-type tokens))
1252 (size (if link-p 0 (tar-header-size tokens)))
1253 (data-end (+ start size))
1254 (bbytes (ash tar-anal-blocksize 9))
1255 (pad-to (+ bbytes (* bbytes (/ (- data-end (point-min)) bbytes)))))
1256 ;; If the padding after the last data is too long, delete some;
1257 ;; else insert some until we are padded out to the right number of blocks.
1259 (with-current-buffer tar-data-buffer
1260 (let ((goal-end (+ (point-min) pad-to)))
1261 (if (> (point-max) goal-end)
1262 (delete-region goal-end (point-max))
1263 (goto-char (point-max))
1264 (insert (make-string (- goal-end (point-max)) ?\0))))))))
1267 ;; Used in write-file-hook to write tar-files out correctly.
1268 (defun tar-mode-write-file ()
1271 (if (tar-data-swapped-p) (buffer-swap-text tar-data-buffer))
1272 ;; Yuck: This is an internal function. We should improve the
1273 ;; write-content-functions hook to make it easier to DTRT.
1274 (prog1 (basic-save-buffer-1)
1275 (unless (tar-data-swapped-p) (buffer-swap-text tar-data-buffer))
1276 (tar-clear-modification-flags)
1277 (set-buffer-modified-p nil)))
1278 (unless (tar-data-swapped-p) (buffer-swap-text tar-data-buffer)))
1279 ;; Return t because we've written the file.
1284 ;; arch-tag: 8a585a4a-340e-42c2-89e7-d3b1013a4b78
1285 ;;; tar-mode.el ends here