tar-mode.el 48.9 KB
Newer Older
Eric S. Raymond's avatar
Eric S. Raymond committed
1
;;; tar-mode.el --- simple editing of tar files from GNU emacs
Richard M. Stallman's avatar
Richard M. Stallman committed
2

3
;; Copyright (C) 1990, 1991, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
Glenn Morris's avatar
Glenn Morris committed
4
;;   2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
Eric S. Raymond's avatar
Eric S. Raymond committed
5

Eric S. Raymond's avatar
Eric S. Raymond committed
6
;; Author: Jamie Zawinski <jwz@lucid.com>
Richard M. Stallman's avatar
Richard M. Stallman committed
7
;; Maintainer: FSF
Eric S. Raymond's avatar
Eric S. Raymond committed
8
;; Created: 04 Apr 1990
Eric S. Raymond's avatar
Eric S. Raymond committed
9
;; Keywords: unix
Richard M. Stallman's avatar
Richard M. Stallman committed
10

Erik Naggum's avatar
Erik Naggum committed
11 12
;; This file is part of GNU Emacs.

13
;; GNU Emacs is free software: you can redistribute it and/or modify
Erik Naggum's avatar
Erik Naggum committed
14
;; it under the terms of the GNU General Public License as published by
15 16
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Erik Naggum's avatar
Erik Naggum committed
17 18 19 20 21 22 23

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; 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/>.
Richard M. Stallman's avatar
Richard M. Stallman committed
25

Eric S. Raymond's avatar
Eric S. Raymond committed
26 27
;;; Commentary:

Erik Naggum's avatar
Erik Naggum committed
28 29 30 31 32 33 34 35 36 37 38 39 40 41
;; This package attempts to make dealing with Unix 'tar' archives easier.
;; When this code is loaded, visiting a file whose name ends in '.tar' will
;; cause the contents of that archive file to be displayed in a Dired-like
;; listing.  It is then possible to use the customary Dired keybindings to
;; extract sub-files from that archive, either by reading them into their own
;; editor buffers, or by copying them directly to arbitrary files on disk.
;; It is also possible to delete sub-files from within the tar file and write
;; the modified archive back to disk, or to edit sub-files within the archive
;; and re-insert the modified files into the archive.  See the documentation
;; string of tar-mode for more info.

;; This code now understands the extra fields that GNU tar adds to tar files.

;; This interacts correctly with "uncompress.el" in the Emacs library,
42
;; which you get with
Erik Naggum's avatar
Erik Naggum committed
43 44 45 46 47 48 49
;;
;;  (autoload 'uncompress-while-visiting "uncompress")
;;  (setq auto-mode-alist (cons '("\\.Z$" . uncompress-while-visiting)
;;			   auto-mode-alist))
;;
;; Do not attempt to use tar-mode.el with crypt.el, you will lose.

50
;;    ***************   TO DO   ***************
Erik Naggum's avatar
Erik Naggum committed
51 52 53
;;
;; 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
Erik Naggum's avatar
Erik Naggum committed
55 56 57 58 59 60 61 62 63 64
;;    important, but still...
;;
;; o  The code is less efficient that it could be - in a lot of places, I
;;    pull a 512-character string out of the buffer and parse it, when I could
;;    be parsing it in place, not garbaging a string.  Should redo that.
;;
;; o  I'd like a command that searches for a string/regexp in every subfile
;;    of an archive, where <esc> would leave you in a subfile-edit buffer.
;;    (Like the Meta-R command of the Zmacs mail reader.)
;;
65
;; o  Sometimes (but not always) reverting the tar-file buffer does not
Erik Naggum's avatar
Erik Naggum committed
66 67 68 69 70 71 72 73 74 75 76
;;    re-grind the listing, and you are staring at the binary tar data.
;;    Typing 'g' again immediately after that will always revert and re-grind
;;    it, though.  I have no idea why this happens.
;;
;; o  Tar-mode interacts poorly with crypt.el and zcat.el because the tar
;;    write-file-hook actually writes the file.  Instead it should remove the
;;    header (and conspire to put it back afterwards) so that other write-file
;;    hooks which frob the buffer have a chance to do their dirty work.  There
;;    might be a problem if the tar write-file-hook does not come *first* on
;;    the list.
;;
77
;; o  Block files, sparse files, continuation files, and the various header
Erik Naggum's avatar
Erik Naggum committed
78 79 80 81 82 83 84 85 86 87 88 89 90 91 92
;;    types aren't editable.  Actually I don't know that they work at all.

;; Rationale:

;; Why does tar-mode edit the file itself instead of using tar?

;; That means that you can edit tar files which you don't have room for
;; on your local disk.

;; I don't know about recent features in gnu tar, but old versions of tar
;; can't replace a file in the middle of a tar file with a new version.
;; Tar-mode can.  I don't think tar can do things like chmod the subfiles.
;; An implementation which involved unpacking and repacking the file into
;; some scratch directory would be very wasteful, and wouldn't be able to
;; preserve the file owners.
Richard M. Stallman's avatar
Richard M. Stallman committed
93

94 95
;;; Bugs:

96
;; - Rename on ././@LongLink files
97 98
;; - Revert confirmation displays the raw data temporarily.

Eric S. Raymond's avatar
Eric S. Raymond committed
99 100
;;; Code:

101 102
(eval-when-compile (require 'cl))

Stephen Eglen's avatar
Stephen Eglen committed
103 104 105 106 107 108
(defgroup tar nil
  "Simple editing of tar files."
  :prefix "tar-"
  :group 'data)

(defcustom tar-anal-blocksize 20
109
  "The blocksize of tar files written by Emacs, or nil, meaning don't care.
Richard M. Stallman's avatar
Richard M. Stallman committed
110
The blocksize of a tar file is not really the size of the blocks; rather, it is
111
the number of blocks written with one system call.  When tarring to a tape,
Richard M. Stallman's avatar
Richard M. Stallman committed
112 113 114
this is the size of the *tape* blocks, but when writing to a file, it doesn't
matter much.  The only noticeable difference is that if a tar file does not
have a blocksize of 20, tar will tell you that; all this really controls is
Stephen Eglen's avatar
Stephen Eglen committed
115 116 117
how many null padding bytes go on the end of the tar file."
  :type '(choice integer (const nil))
  :group 'tar)
Richard M. Stallman's avatar
Richard M. Stallman committed
118

Stephen Eglen's avatar
Stephen Eglen committed
119
(defcustom tar-update-datestamp nil
120
  "Non-nil means Tar mode should play fast and loose with sub-file datestamps.
121
If this is true, then editing and saving a tar file entry back into its
Richard M. Stallman's avatar
Richard M. Stallman committed
122 123 124
tar file will update its datestamp.  If false, the datestamp is unchanged.
You may or may not want this - it is good in that you can tell when a file
in a tar archive has been changed, but it is bad for the same reason that
125
editing a file in the tar archive at all is bad - the changed version of
Stephen Eglen's avatar
Stephen Eglen committed
126 127 128
the file never exists on disk."
  :type 'boolean
  :group 'tar)
Richard M. Stallman's avatar
Richard M. Stallman committed
129

Stephen Eglen's avatar
Stephen Eglen committed
130
(defcustom tar-mode-show-date nil
131
  "Non-nil means Tar mode should show the date/time of each subfile.
Stephen Eglen's avatar
Stephen Eglen committed
132 133 134
This information is useful, but it takes screen space away from file names."
  :type 'boolean
  :group 'tar)
135

136 137 138 139
(defvar tar-parse-info nil)
(defvar tar-superior-buffer nil)
(defvar tar-superior-descriptor nil)
(defvar tar-subfile-mode nil)
140
(defvar tar-file-name-coding-system nil)
141 142 143

(put 'tar-superior-buffer 'permanent-local t)
(put 'tar-superior-descriptor 'permanent-local t)
144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171

;; The Tar data is made up of bytes and better manipulated as bytes
;; and can be very large, so insert/delete can be costly.  The summary we
;; want to display may contain non-ascci chars, of course, so we'd like it
;; to be multibyte.  We used to keep both in the same buffer and switch
;; from/to uni/multibyte.  But this had several downsides:
;; - set-buffer-multibyte has an O(N^2) worst case that tends to be triggered
;;   here, so it gets atrociously slow on large Tar files.
;; - need to widen/narrow the buffer to show/hide the raw data, and need to
;;   maintain a tar-header-offset that keeps track of the boundary between
;;   the two.
;; - can't use markers because they're not preserved by set-buffer-multibyte.
;; So instead, we now keep the two pieces of data in separate buffers, and
;; use the new buffer-swap-text primitive when we need to change which data
;; is associated with "the" buffer.
(defvar tar-data-buffer nil "Buffer that holds the actual raw tar bytes.")
(make-variable-buffer-local 'tar-data-buffer)

(defun tar-data-swapped-p ()
  "Return non-nil if the tar-data is in `tar-data-buffer'."
  ;; We need to be careful to keep track of which buffer holds the tar-data,
  ;; since we swap them back and forth.  Since the user may make the summary
  ;; buffer unibyte, we can't rely on the multibyteness of the buffers.
  ;; We could try and recognize the tar-format signature, but instead
  ;; I decided to go for something simpler.
  (and (buffer-live-p tar-data-buffer)
       (> (buffer-size tar-data-buffer) (buffer-size))))

Richard M. Stallman's avatar
Richard M. Stallman committed
172 173 174

;;; down to business.

Stefan Monnier's avatar
Stefan Monnier committed
175 176 177 178 179 180 181 182
(defstruct (tar-header
            (:constructor nil)
            (:type vector)
            :named
            (:constructor
             make-tar-header (data-start name mode uid gid size date checksum
                              link-type link-name magic uname gname dmaj dmin)))
  data-start name mode uid gid size date checksum link-type link-name
183 184 185 186
  magic uname gname dmaj dmin
  ;; Start of the header can be nil (meaning it's 512 bytes before data-start)
  ;; or a marker (in case the header uses LongLink thingies).
  header-start)
Richard M. Stallman's avatar
Richard M. Stallman committed
187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202

(defconst tar-name-offset 0)
(defconst tar-mode-offset (+ tar-name-offset 100))
(defconst tar-uid-offset  (+ tar-mode-offset 8))
(defconst tar-gid-offset  (+ tar-uid-offset 8))
(defconst tar-size-offset (+ tar-gid-offset 8))
(defconst tar-time-offset (+ tar-size-offset 12))
(defconst tar-chk-offset  (+ tar-time-offset 12))
(defconst tar-linkp-offset (+ tar-chk-offset 8))
(defconst tar-link-offset (+ tar-linkp-offset 1))
;;; GNU-tar specific slots.
(defconst tar-magic-offset (+ tar-link-offset 100))
(defconst tar-uname-offset (+ tar-magic-offset 8))
(defconst tar-gname-offset (+ tar-uname-offset 32))
(defconst tar-dmaj-offset (+ tar-gname-offset 32))
(defconst tar-dmin-offset (+ tar-dmaj-offset 8))
203 204
(defconst tar-prefix-offset (+ tar-dmin-offset 8))
(defconst tar-end-offset (+ tar-prefix-offset 155))
Richard M. Stallman's avatar
Richard M. Stallman committed
205

Stefan Monnier's avatar
Stefan Monnier committed
206 207 208 209 210
(defun tar-roundup-512 (s)
  "Round S up to the next multiple of 512."
  (ash (ash (+ s 511) -9) 9))
 
(defun tar-header-block-tokenize (pos)
211
  "Return a `tar-header' structure.
212
This is a list of name, mode, uid, gid, size,
213
write-date, checksum, link-type, and link-name."
Stefan Monnier's avatar
Stefan Monnier committed
214 215 216 217 218 219 220 221 222 223 224 225 226 227
  (assert (<= (+ pos 512) (point-max)))
  (assert (zerop (mod (- pos (point-min)) 512)))
  (assert (not enable-multibyte-characters))
  (let ((string (buffer-substring pos (setq pos (+ pos 512)))))
    (when      ;(some 'plusp string)		 ; <-- oops, massive cycle hog!
        (or (not (= 0 (aref string 0))) ; This will do.
            (not (= 0 (aref string 101))))
      (let* ((name-end tar-mode-offset)
             (link-end (1- tar-magic-offset))
             (uname-end (1- tar-gname-offset))
             (gname-end (1- tar-dmaj-offset))
             (link-p (aref string tar-linkp-offset))
             (magic-str (substring string tar-magic-offset
                                   (1- tar-uname-offset)))
228
             (uname-valid-p (car (member magic-str '("ustar  " "ustar\0\0"))))
Stefan Monnier's avatar
Stefan Monnier committed
229 230 231 232 233 234 235 236 237 238 239 240 241 242 243
             name linkname
             (nulsexp   "[^\000]*\000"))
        (when (string-match nulsexp string tar-name-offset)
          (setq name-end (min name-end (1- (match-end 0)))))
        (when (string-match nulsexp string tar-link-offset)
          (setq link-end (min link-end (1- (match-end 0)))))
        (when (string-match nulsexp string tar-uname-offset)
          (setq uname-end (min uname-end (1- (match-end 0)))))
        (when (string-match nulsexp string tar-gname-offset)
          (setq gname-end (min gname-end (1- (match-end 0)))))
        (setq name (substring string tar-name-offset name-end)
              link-p (if (or (= link-p 0) (= link-p ?0))
                         nil
                       (- link-p ?0)))
        (setq linkname (substring string tar-link-offset link-end))
244
        (when (and (equal uname-valid-p "ustar\0\0")
Stefan Monnier's avatar
Stefan Monnier committed
245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274
                   (string-match nulsexp string tar-prefix-offset)
                   (> (match-end 0) (1+ tar-prefix-offset)))
          (setq name (concat (substring string tar-prefix-offset
                                        (1- (match-end 0)))
                             "/" name)))
        (if default-enable-multibyte-characters
            (setq name
                  (decode-coding-string name tar-file-name-coding-system)
                  linkname
                  (decode-coding-string linkname
                                        tar-file-name-coding-system)))
        (if (and (null link-p) (string-match "/\\'" name))
            (setq link-p 5))            ; directory

        (if (and (equal name "././@LongLink")
                 (equal magic-str "ustar  ")) ;OLDGNU_MAGIC.
            ;; This is a GNU Tar long-file-name header.
            (let* ((size (tar-parse-octal-integer
                          string tar-size-offset tar-time-offset))
                   ;; -1 so as to strip the terminating 0 byte.
                   (name (buffer-substring pos (+ pos size -1)))
                   (descriptor (tar-header-block-tokenize
                                (+ pos (tar-roundup-512 size)))))
              (cond
               ((eq link-p (- ?L ?0))      ;GNUTYPE_LONGNAME.
                (setf (tar-header-name descriptor) name))
               ((eq link-p (- ?K ?0))      ;GNUTYPE_LONGLINK.
                (setf (tar-header-link-name descriptor) name))
               (t
                (message "Unrecognized GNU Tar @LongLink format")))
275 276
              (setf (tar-header-header-start descriptor)
                    (copy-marker (- pos 512) t))
Stefan Monnier's avatar
Stefan Monnier committed
277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295
              descriptor)
        
          (make-tar-header
           (copy-marker pos nil)
           name
           (tar-parse-octal-integer string tar-mode-offset tar-uid-offset)
           (tar-parse-octal-integer string tar-uid-offset tar-gid-offset)
           (tar-parse-octal-integer string tar-gid-offset tar-size-offset)
           (tar-parse-octal-integer string tar-size-offset tar-time-offset)
           (tar-parse-octal-long-integer string tar-time-offset tar-chk-offset)
           (tar-parse-octal-integer string tar-chk-offset tar-linkp-offset)
           link-p
           linkname
           uname-valid-p
           (and uname-valid-p (substring string tar-uname-offset uname-end))
           (and uname-valid-p (substring string tar-gname-offset gname-end))
           (tar-parse-octal-integer string tar-dmaj-offset tar-dmin-offset)
           (tar-parse-octal-integer string tar-dmin-offset tar-prefix-offset)
           ))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
296

297 298 299 300 301 302 303 304 305 306 307 308 309
;; Pseudo-field.
(defun tar-header-data-end (descriptor)
  (let* ((data-start (tar-header-data-start descriptor))
         (link-type (tar-header-link-type descriptor))
         (size (tar-header-size descriptor))
         (fudge (cond
                 ;; Foo.  There's an extra empty block after these.
                 ((memq link-type '(20 55)) 512)
                 (t 0))))
    (+ data-start fudge
       (if (and (null link-type) (> size 0))
           (tar-roundup-512 size)
         0))))
Richard M. Stallman's avatar
Richard M. Stallman committed
310 311 312 313 314 315 316 317 318

(defun tar-parse-octal-integer (string &optional start end)
  (if (null start) (setq start 0))
  (if (null end) (setq end (length string)))
  (if (= (aref string start) 0)
      0
    (let ((n 0))
      (while (< start end)
	(setq n (if (< (aref string start) ?0) n
319
		  (+ (* n 8) (- (aref string start) ?0)))
Richard M. Stallman's avatar
Richard M. Stallman committed
320 321 322
	      start (1+ start)))
      n)))

323 324 325 326
(defun tar-parse-octal-long-integer (string &optional start end)
  (if (null start) (setq start 0))
  (if (null end) (setq end (length string)))
  (if (= (aref string start) 0)
327
      (list 0 0)
328 329 330 331 332 333 334 335 336 337
    (let ((lo 0)
	  (hi 0))
      (while (< start end)
	(if (>= (aref string start) ?0)
	    (setq lo (+ (* lo 8) (- (aref string start) ?0))
		  hi (+ (* hi 8) (ash lo -16))
		  lo (logand lo 65535)))
	(setq start (1+ start)))
      (list hi lo))))

Richard M. Stallman's avatar
Richard M. Stallman committed
338
(defun tar-parse-octal-integer-safe (string)
339 340 341 342 343
  (if (zerop (length string)) (error "empty string"))
  (mapc (lambda (c)
	  (if (or (< c ?0) (> c ?7))
	      (error "`%c' is not an octal digit" c)))
	string)
Richard M. Stallman's avatar
Richard M. Stallman committed
344 345 346
  (tar-parse-octal-integer string))


347
(defun tar-header-block-checksum (string)
348
  "Compute and return a tar-acceptable checksum for this block."
Stefan Monnier's avatar
Stefan Monnier committed
349
  (assert (not (multibyte-string-p string)))
Richard M. Stallman's avatar
Richard M. Stallman committed
350 351 352 353 354 355 356 357 358 359 360 361 362 363 364
  (let* ((chk-field-start tar-chk-offset)
	 (chk-field-end (+ chk-field-start 8))
	 (sum 0)
	 (i 0))
    ;; Add up all of the characters except the ones in the checksum field.
    ;; Add that field as if it were filled with spaces.
    (while (< i chk-field-start)
      (setq sum (+ sum (aref string i))
	    i (1+ i)))
    (setq i chk-field-end)
    (while (< i 512)
      (setq sum (+ sum (aref string i))
	    i (1+ i)))
    (+ sum (* 32 8))))

365
(defun tar-header-block-check-checksum (hblock desired-checksum file-name)
Richard M. Stallman's avatar
Richard M. Stallman committed
366
  "Beep and print a warning if the checksum doesn't match."
367
  (if (not (= desired-checksum (tar-header-block-checksum hblock)))
Richard M. Stallman's avatar
Richard M. Stallman committed
368 369
      (progn (beep) (message "Invalid checksum for file %s!" file-name))))

370 371
(defun tar-clip-time-string (time)
  (let ((str (current-time-string time)))
372
    (concat " " (substring str 4 16) (substring str 19 24))))
Richard M. Stallman's avatar
Richard M. Stallman committed
373

374 375
(defun tar-grind-file-mode (mode)
  "Construct a `-rw--r--r--' string indicating MODE.
376
MODE should be an integer which is a file mode value."
377 378 379 380 381 382 383 384 385 386
  (string
   (if (zerop (logand 256 mode)) ?- ?r)
   (if (zerop (logand 128 mode)) ?- ?w)
   (if (zerop (logand 1024 mode)) (if (zerop (logand  64 mode)) ?- ?x) ?s)
   (if (zerop (logand  32 mode)) ?- ?r)
   (if (zerop (logand  16 mode)) ?- ?w)
   (if (zerop (logand 2048 mode)) (if (zerop (logand   8 mode)) ?- ?x) ?s)
   (if (zerop (logand   4 mode)) ?- ?r)
   (if (zerop (logand   2 mode)) ?- ?w)
   (if (zerop (logand   1 mode)) ?- ?x)))
Richard M. Stallman's avatar
Richard M. Stallman committed
387

388
(defun tar-header-block-summarize (tar-hblock &optional mod-p)
389
  "Return a line similar to the output of `tar -vtf'."
Richard M. Stallman's avatar
Richard M. Stallman committed
390 391 392 393 394 395 396 397
  (let ((name (tar-header-name tar-hblock))
	(mode (tar-header-mode tar-hblock))
	(uid (tar-header-uid tar-hblock))
	(gid (tar-header-gid tar-hblock))
	(uname (tar-header-uname tar-hblock))
	(gname (tar-header-gname tar-hblock))
	(size (tar-header-size tar-hblock))
	(time (tar-header-date tar-hblock))
398
	;; (ck (tar-header-checksum tar-hblock))
399 400
	(type (tar-header-link-type tar-hblock))
	(link-name (tar-header-link-name tar-hblock)))
401
    (format "%c%c%s %7s/%-7s %7s%s %s%s"
402
	    (if mod-p ?* ? )
Richard M. Stallman's avatar
Richard M. Stallman committed
403
	    (cond ((or (eq type nil) (eq type 0)) ?-)
404 405
		  ((eq type 1) ?h)	; link
		  ((eq type 2) ?l)	; symlink
406 407 408 409 410
		  ((eq type 3) ?c)	; char special
		  ((eq type 4) ?b)	; block special
		  ((eq type 5) ?d)	; directory
		  ((eq type 6) ?p)	; FIFO/pipe
		  ((eq type 20) ?*)	; directory listing
411
		  ((eq type 28) ?L)	; next has longname
412 413 414
		  ((eq type 29) ?M)	; multivolume continuation
		  ((eq type 35) ?S)	; sparse
		  ((eq type 38) ?V)	; volume header
415
		  ((eq type 55) ?H)	; extended pax header
416
		  (t ?\s)
417 418 419 420 421 422
		  )
	    (tar-grind-file-mode mode)
	    (if (= 0 (length uname)) uid uname)
	    (if (= 0 (length gname)) gid gname)
	    size
	    (if tar-mode-show-date (tar-clip-time-string time) "")
423 424 425
	    (propertize name
			'mouse-face 'highlight
			'help-echo "mouse-2: extract this file into a buffer")
426 427 428
	    (if (or (eq type 1) (eq type 2))
		(concat (if (= type 1) " ==> " " --> ") link-name)
	      ""))))
Richard M. Stallman's avatar
Richard M. Stallman committed
429

430
(defun tar-untar-buffer ()
431
  "Extract all archive members in the tar-file into the current directory."
432
  (interactive)
433 434 435 436 437 438
  ;; FIXME: make it work even if we're not in tar-mode.
  (let ((descriptors tar-parse-info))   ;Read the var in its buffer.
    (with-current-buffer
        (if (tar-data-swapped-p) tar-data-buffer (current-buffer))
      (set-buffer-multibyte nil)          ;Hopefully, a no-op.
      (dolist (descriptor descriptors)
Stefan Monnier's avatar
Stefan Monnier committed
439 440
        (let* ((name (tar-header-name descriptor))
               (dir (if (eq (tar-header-link-type descriptor) 5)
441 442
                        name
                      (file-name-directory name)))
Stefan Monnier's avatar
Stefan Monnier committed
443 444
               (start (tar-header-data-start descriptor))
               (end (+ start (tar-header-size descriptor))))
445 446 447 448 449 450
          (unless (file-directory-p name)
            (message "Extracting %s" name)
            (if (and dir (not (file-exists-p dir)))
                (make-directory dir t))
            (unless (file-directory-p name)
              (write-region start end name))
Stefan Monnier's avatar
Stefan Monnier committed
451
            (set-file-modes name (tar-header-mode descriptor))))))))
452

Richard M. Stallman's avatar
Richard M. Stallman committed
453
(defun tar-summarize-buffer ()
Stefan Monnier's avatar
Stefan Monnier committed
454
  "Parse the contents of the tar file in the current buffer."
455 456 457 458 459
  (assert (tar-data-swapped-p))
  (let* ((modified (buffer-modified-p))
         (result '())
         (pos (point-min))
         (progress-reporter
460 461 462
          (with-current-buffer tar-data-buffer
            (make-progress-reporter "Parsing tar file..."
                                    (point-min) (point-max))))
Stefan Monnier's avatar
Stefan Monnier committed
463
         descriptor)
464
    (with-current-buffer tar-data-buffer
465
      (while (and (<= (+ pos 512) (point-max))
Stefan Monnier's avatar
Stefan Monnier committed
466 467
                  (setq descriptor (tar-header-block-tokenize pos)))
        (let ((size (tar-header-size descriptor)))
468 469
          (if (< size 0)
              (error "%s has size %s - corrupted"
470 471 472 473 474 475 476 477 478 479 480
                     (tar-header-name descriptor) size)))
        ;;
        ;; This is just too slow.  Don't really need it anyway....
        ;;(tar-header-block-check-checksum
        ;;  hblock (tar-header-block-checksum hblock)
        ;;  (tar-header-name descriptor))
        
        (push descriptor result)
        (setq pos (tar-header-data-end descriptor))
        (progress-reporter-update progress-reporter pos)))

Stefan Monnier's avatar
Stefan Monnier committed
481
    (set (make-local-variable 'tar-parse-info) (nreverse result))
482 483
    ;; A tar file should end with a block or two of nulls,
    ;; but let's not get a fatal error if it doesn't.
Stefan Monnier's avatar
Stefan Monnier committed
484
    (if (null descriptor)
485 486
        (progress-reporter-done progress-reporter)
      (message "Warning: premature EOF parsing tar file"))
Richard M. Stallman's avatar
Richard M. Stallman committed
487
    (goto-char (point-min))
488 489
    (let ((inhibit-read-only t)
          (total-summaries
Stefan Monnier's avatar
Stefan Monnier committed
490
           (mapconcat 'tar-header-block-summarize tar-parse-info "\n")))
491 492 493
      (insert total-summaries "\n"))
    (goto-char (point-min))
    (restore-buffer-modified-p modified)))
494

495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524
(defvar tar-mode-map
  (let ((map (make-keymap)))
    (suppress-keymap map)
    (define-key map " " 'tar-next-line)
    (define-key map "C" 'tar-copy)
    (define-key map "d" 'tar-flag-deleted)
    (define-key map "\^D" 'tar-flag-deleted)
    (define-key map "e" 'tar-extract)
    (define-key map "f" 'tar-extract)
    (define-key map "\C-m" 'tar-extract)
    (define-key map [mouse-2] 'tar-mouse-extract)
    (define-key map "g" 'revert-buffer)
    (define-key map "h" 'describe-mode)
    (define-key map "n" 'tar-next-line)
    (define-key map "\^N" 'tar-next-line)
    (define-key map [down] 'tar-next-line)
    (define-key map "o" 'tar-extract-other-window)
    (define-key map "p" 'tar-previous-line)
    (define-key map "q" 'quit-window)
    (define-key map "\^P" 'tar-previous-line)
    (define-key map [up] 'tar-previous-line)
    (define-key map "R" 'tar-rename-entry)
    (define-key map "u" 'tar-unflag)
    (define-key map "v" 'tar-view)
    (define-key map "x" 'tar-expunge)
    (define-key map "\177" 'tar-unflag-backwards)
    (define-key map "E" 'tar-extract-other-window)
    (define-key map "M" 'tar-chmod-entry)
    (define-key map "G" 'tar-chgrp-entry)
    (define-key map "O" 'tar-chown-entry)
525 526
    ;; Let mouse-1 follow the link.
    (define-key map [follow-link] 'mouse-face)
Stefan Monnier's avatar
Stefan Monnier committed
527

528
    ;; Make menu bar items.
529

530 531
    ;; Get rid of the Edit menu bar item to save space.
    (define-key map [menu-bar edit] 'undefined)
532

533
    (define-key map [menu-bar immediate]
Stefan Monnier's avatar
Stefan Monnier committed
534
      (cons "Immediate" (make-sparse-keymap "Immediate")))
535

536
    (define-key map [menu-bar immediate view]
Stefan Monnier's avatar
Stefan Monnier committed
537
      '("View This File" . tar-view))
538
    (define-key map [menu-bar immediate display]
Stefan Monnier's avatar
Stefan Monnier committed
539
      '("Display in Other Window" . tar-display-other-window))
540
    (define-key map [menu-bar immediate find-file-other-window]
Stefan Monnier's avatar
Stefan Monnier committed
541
      '("Find in Other Window" . tar-extract-other-window))
542
    (define-key map [menu-bar immediate find-file]
Stefan Monnier's avatar
Stefan Monnier committed
543
      '("Find This File" . tar-extract))
544

545
    (define-key map [menu-bar mark]
Stefan Monnier's avatar
Stefan Monnier committed
546
      (cons "Mark" (make-sparse-keymap "Mark")))
547

548
    (define-key map [menu-bar mark unmark-all]
Stefan Monnier's avatar
Stefan Monnier committed
549
      '("Unmark All" . tar-clear-modification-flags))
550
    (define-key map [menu-bar mark deletion]
Stefan Monnier's avatar
Stefan Monnier committed
551
      '("Flag" . tar-flag-deleted))
552
    (define-key map [menu-bar mark unmark]
Stefan Monnier's avatar
Stefan Monnier committed
553
      '("Unflag" . tar-unflag))
554

555
    (define-key map [menu-bar operate]
Stefan Monnier's avatar
Stefan Monnier committed
556
      (cons "Operate" (make-sparse-keymap "Operate")))
557

558
    (define-key map [menu-bar operate chown]
Stefan Monnier's avatar
Stefan Monnier committed
559
      '("Change Owner..." . tar-chown-entry))
560
    (define-key map [menu-bar operate chgrp]
Stefan Monnier's avatar
Stefan Monnier committed
561
      '("Change Group..." . tar-chgrp-entry))
562
    (define-key map [menu-bar operate chmod]
Stefan Monnier's avatar
Stefan Monnier committed
563
      '("Change Mode..." . tar-chmod-entry))
564
    (define-key map [menu-bar operate rename]
Stefan Monnier's avatar
Stefan Monnier committed
565
      '("Rename to..." . tar-rename-entry))
566
    (define-key map [menu-bar operate copy]
Stefan Monnier's avatar
Stefan Monnier committed
567
      '("Copy to..." . tar-copy))
568
    (define-key map [menu-bar operate expunge]
Stefan Monnier's avatar
Stefan Monnier committed
569 570
      '("Expunge Marked Files" . tar-expunge))
    
571 572 573
    map)
  "Local keymap for Tar mode listings.")

574

Richard M. Stallman's avatar
Richard M. Stallman committed
575 576 577 578
;; tar mode is suitable only for specially formatted data.
(put 'tar-mode 'mode-class 'special)
(put 'tar-subfile-mode 'mode-class 'special)

579 580 581 582 583 584 585 586 587
(defun tar-change-major-mode-hook ()
  ;; Bring the actual Tar data back into the main buffer.
  (when (tar-data-swapped-p) (buffer-swap-text tar-data-buffer))
  ;; Throw away the summary.
  (when (buffer-live-p tar-data-buffer) (kill-buffer tar-data-buffer)))

(defun tar-mode-kill-buffer-hook ()
  (if (buffer-live-p tar-data-buffer) (kill-buffer tar-data-buffer)))

Richard M. Stallman's avatar
Richard M. Stallman committed
588
;;;###autoload
589
(define-derived-mode tar-mode nil "Tar"
Richard M. Stallman's avatar
Richard M. Stallman committed
590
  "Major mode for viewing a tar file as a dired-like listing of its contents.
591
You can move around using the usual cursor motion commands.
Richard M. Stallman's avatar
Richard M. Stallman committed
592
Letters no longer insert themselves.
593 594
Type `e' to pull a file out of the tar file and into its own buffer;
or click mouse-2 on the file's line in the Tar mode buffer.
595
Type `c' to copy an entry from the tar file into another file on disk.
Richard M. Stallman's avatar
Richard M. Stallman committed
596

597
If you edit a sub-file of this archive (as with the `e' command) and
598
save it with \\[save-buffer], the contents of that buffer will be
599
saved back into the tar-file buffer; in this way you can edit a file
Richard M. Stallman's avatar
Richard M. Stallman committed
600 601
inside of a tar archive without extracting it and re-archiving it.

602
See also: variables `tar-update-datestamp' and `tar-anal-blocksize'.
Richard M. Stallman's avatar
Richard M. Stallman committed
603 604 605
\\{tar-mode-map}"
  ;; this is not interactive because you shouldn't be turning this
  ;; mode on and off.  You can corrupt things that way.
606 607
  ;; rms: with permanent locals, it should now be possible to make this work
  ;; interactively in some reasonable fashion.
Richard M. Stallman's avatar
Richard M. Stallman committed
608
  (make-local-variable 'tar-parse-info)
609 610 611
  (set (make-local-variable 'require-final-newline) nil) ; binary data, dude...
  (set (make-local-variable 'local-enable-local-variables) nil)
  (set (make-local-variable 'next-line-add-newlines) nil)
612 613 614 615
  (set (make-local-variable 'tar-file-name-coding-system)
       (or file-name-coding-system
	   default-file-name-coding-system
	   locale-coding-system))
616
  ;; Prevent loss of data when saving the file.
617
  (set (make-local-variable 'file-precious-flag) t)
618
  (buffer-disable-undo)
Richard M. Stallman's avatar
Richard M. Stallman committed
619
  (widen)
620 621 622 623
  ;; Now move the Tar data into an auxiliary buffer, so we can use the main
  ;; buffer for the summary.
  (assert (not (tar-data-swapped-p)))
  (set (make-local-variable 'revert-buffer-function) 'tar-mode-revert)
624
  (add-hook 'write-region-annotate-functions 'tar-write-region-annotate nil t)
625 626 627
  (add-hook 'kill-buffer-hook 'tar-mode-kill-buffer-hook nil t)
  (add-hook 'change-major-mode-hook 'tar-change-major-mode-hook nil t)
  ;; Tar data is made of bytes, not chars.
628
  (set-buffer-multibyte nil)            ;Hopefully a no-op.
629 630 631 632 633 634 635
  (set (make-local-variable 'tar-data-buffer)
       (generate-new-buffer (format " *tar-data %s*"
                                    (file-name-nondirectory
                                     (or buffer-file-name (buffer-name))))))
  (buffer-swap-text tar-data-buffer)
  (tar-summarize-buffer)
  (tar-next-line 0))
Richard M. Stallman's avatar
Richard M. Stallman committed
636 637 638 639


(defun tar-subfile-mode (p)
  "Minor mode for editing an element of a tar-file.
640 641 642
This mode arranges for \"saving\" this buffer to write the data
into the tar-file buffer that it came from.  The changes will actually
appear on disk when you save the tar-file's buffer."
Richard M. Stallman's avatar
Richard M. Stallman committed
643
  (interactive "P")
644
  (or (and (boundp 'tar-superior-buffer) tar-superior-buffer)
645
      (error "This buffer is not an element of a tar file"))
646 647 648 649
  ;; Don't do this, because it is redundant and wastes mode line space.
  ;;  (or (assq 'tar-subfile-mode minor-mode-alist)
  ;;      (setq minor-mode-alist (append minor-mode-alist
  ;;				     (list '(tar-subfile-mode " TarFile")))))
Richard M. Stallman's avatar
Richard M. Stallman committed
650 651 652 653 654 655
  (make-local-variable 'tar-subfile-mode)
  (setq tar-subfile-mode
	(if (null p)
	    (not tar-subfile-mode)
	    (> (prefix-numeric-value p) 0)))
  (cond (tar-subfile-mode
656
	 (add-hook 'write-file-functions 'tar-subfile-save-buffer nil t)
Richard M. Stallman's avatar
Richard M. Stallman committed
657
	 ;; turn off auto-save.
658
	 (auto-save-mode -1)
Richard M. Stallman's avatar
Richard M. Stallman committed
659 660
	 (setq buffer-auto-save-file-name nil)
	 (run-hooks 'tar-subfile-mode-hook))
661
	(t
662
	 (remove-hook 'write-file-functions 'tar-subfile-save-buffer t))))
Richard M. Stallman's avatar
Richard M. Stallman committed
663 664


665
;; Revert the buffer and recompute the dired-like listing.
666
(defun tar-mode-revert (&optional no-auto-save no-confirm)
667 668 669 670 671 672 673 674 675 676 677 678
  (unwind-protect
      (let ((revert-buffer-function nil))
        (if (tar-data-swapped-p) (buffer-swap-text tar-data-buffer))
        ;; FIXME: If we ask for confirmation, the user will be temporarily
        ;; looking at the raw data.
        (revert-buffer no-auto-save no-confirm 'preserve-modes)
        ;; The new raw data may be smaller than the old summary, so let's
        ;; make sure tar-data-swapped-p doesn't get confused.
        (if (buffer-live-p tar-data-buffer) (kill-buffer tar-data-buffer))
        ;; Recompute the summary.
        (tar-mode))
    (unless (tar-data-swapped-p) (buffer-swap-text tar-data-buffer))))
Richard M. Stallman's avatar
Richard M. Stallman committed
679 680


681 682
(defun tar-next-line (arg)
  "Move cursor vertically down ARG lines and to the start of the filename."
Richard M. Stallman's avatar
Richard M. Stallman committed
683
  (interactive "p")
684
  (forward-line arg)
685
  (goto-char (or (next-single-property-change (point) 'mouse-face) (point))))
Richard M. Stallman's avatar
Richard M. Stallman committed
686

687 688
(defun tar-previous-line (arg)
  "Move cursor vertically up ARG lines and to the start of the filename."
Richard M. Stallman's avatar
Richard M. Stallman committed
689
  (interactive "p")
690
  (tar-next-line (- arg)))
Richard M. Stallman's avatar
Richard M. Stallman committed
691 692

(defun tar-current-descriptor (&optional noerror)
693
  "Return the tar-descriptor of the current line, or signals an error."
Richard M. Stallman's avatar
Richard M. Stallman committed
694
  ;; I wish lines had plists, like in ZMACS...
695
  (or (nth (count-lines (point-min) (line-beginning-position))
Richard M. Stallman's avatar
Richard M. Stallman committed
696 697 698
	   tar-parse-info)
      (if noerror
	  nil
699
	  (error "This line does not describe a tar-file entry"))))
Richard M. Stallman's avatar
Richard M. Stallman committed
700

701 702
(defun tar-get-descriptor ()
  (let* ((descriptor (tar-current-descriptor))
Stefan Monnier's avatar
Stefan Monnier committed
703 704
	 (size (tar-header-size descriptor))
	 (link-p (tar-header-link-type descriptor)))
705
    (if link-p
706 707 708 709 710 711 712 713 714
	(error "This is %s, not a real file"
	       (cond ((eq link-p 5) "a directory")
		     ((eq link-p 20) "a tar directory header")
		     ((eq link-p 28) "a next has longname")
		     ((eq link-p 29) "a multivolume-continuation")
		     ((eq link-p 35) "a sparse entry")
		     ((eq link-p 38) "a volume header")
		     ((eq link-p 55) "an extended pax header")
		     (t "a link"))))
715
    (if (zerop size) (message "This is a zero-length file"))
716 717 718 719 720
    descriptor))

(defun tar-mouse-extract (event)
  "Extract a file whose tar directory line you click on."
  (interactive "e")
Stefan Monnier's avatar
Stefan Monnier committed
721
  (with-current-buffer (window-buffer (posn-window (event-end event)))
722 723 724 725 726 727 728
    (save-excursion
      (goto-char (posn-point (event-end event)))
      ;; Just make sure this doesn't get an error.
      (tar-get-descriptor)))
  (select-window (posn-window (event-end event)))
  (goto-char (posn-point (event-end event)))
  (tar-extract))
Richard M. Stallman's avatar
Richard M. Stallman committed
729

730 731 732 733 734 735
(defun tar-file-name-handler (op &rest args)
  "Helper function for `tar-extract'."
  (or (eq op 'file-exists-p)
      (let ((file-name-handler-alist nil))
	(apply op args))))

Richard M. Stallman's avatar
Richard M. Stallman committed
736
(defun tar-extract (&optional other-window-p)
737
  "In Tar mode, extract this entry of the tar file into its own buffer."
Richard M. Stallman's avatar
Richard M. Stallman committed
738 739
  (interactive)
  (let* ((view-p (eq other-window-p 'view))
740
	 (descriptor (tar-get-descriptor))
Stefan Monnier's avatar
Stefan Monnier committed
741 742 743
	 (name (tar-header-name descriptor))
	 (size (tar-header-size descriptor))
	 (start (tar-header-data-start descriptor))
Richard M. Stallman's avatar
Richard M. Stallman committed
744 745
	 (end (+ start size)))
    (let* ((tar-buffer (current-buffer))
746
	   (tarname (buffer-name))
747 748
	   (bufname (concat (file-name-nondirectory name)
			    " ("
749
			     tarname
750
			     ")"))
Richard M. Stallman's avatar
Richard M. Stallman committed
751
	   (read-only-p (or buffer-read-only view-p))
752 753
	   (new-buffer-file-name (expand-file-name
				  ;; `:' is not allowed on Windows
754 755
				  (concat tarname "!" name)))
	   (buffer (get-file-buffer new-buffer-file-name))
756
	   (just-created nil)
757
	   undo-list)
758
      (unless buffer
759
	(setq buffer (generate-new-buffer bufname))
Stefan Monnier's avatar
Stefan Monnier committed
760
	(with-current-buffer buffer
761 762
	  (setq undo-list buffer-undo-list
		buffer-undo-list t))
763
	(setq bufname (buffer-name buffer))
Richard M. Stallman's avatar
Richard M. Stallman committed
764
	(setq just-created t)
765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815
	(with-current-buffer tar-data-buffer
          (let (coding)
            (narrow-to-region start end)
            (goto-char start)
            (setq coding (or coding-system-for-read
                             (and set-auto-coding-function
                                  (funcall set-auto-coding-function
                                           name (- end start)))
                             ;; The following binding causes
                             ;; find-buffer-file-type-coding-system
                             ;; (defined on dos-w32.el) to act as if
                             ;; the file being extracted existed, so
                             ;; that the file's contents' encoding and
                             ;; EOL format are auto-detected.
                             (let ((file-name-handler-alist
                                    '(("" . tar-file-name-handler))))
                               (car (find-operation-coding-system
                                     'insert-file-contents
                                     (cons name (current-buffer)) t)))))
            (if (or (not coding)
                    (eq (coding-system-type coding) 'undecided))
                (setq coding (detect-coding-region start end t)))
            (if (and default-enable-multibyte-characters
                     (coding-system-get coding :for-unibyte))
                (with-current-buffer buffer
                  (set-buffer-multibyte nil)))
            (widen)
            (decode-coding-region start end coding buffer)))
        (with-current-buffer buffer
          (goto-char (point-min))
          (setq buffer-file-name new-buffer-file-name)
          (setq buffer-file-truename
                (abbreviate-file-name buffer-file-name))
          ;; Force buffer-file-coding-system to what
          ;; decode-coding-region actually used.
          (set-buffer-file-coding-system last-coding-system-used t)
          ;; Set the default-directory to the dir of the
          ;; superior buffer.
          (setq default-directory
                (with-current-buffer tar-buffer
                  default-directory))
          (normal-mode)  ; pick a mode.
          (rename-buffer bufname)
          (make-local-variable 'tar-superior-buffer)
          (make-local-variable 'tar-superior-descriptor)
          (setq tar-superior-buffer tar-buffer)
          (setq tar-superior-descriptor descriptor)
          (setq buffer-read-only read-only-p)
          (set-buffer-modified-p nil)
          (setq buffer-undo-list undo-list)
          (tar-subfile-mode 1)))
Richard M. Stallman's avatar
Richard M. Stallman committed
816
      (if view-p
817 818
	  (view-buffer
	   buffer (and just-created 'kill-buffer-if-not-modified))
819 820 821 822 823
	(if (eq other-window-p 'display)
	    (display-buffer buffer)
	  (if other-window-p
	      (switch-to-buffer-other-window buffer)
	    (switch-to-buffer buffer)))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
824 825 826


(defun tar-extract-other-window ()
827
  "In Tar mode, find this entry of the tar file in another window."
Richard M. Stallman's avatar
Richard M. Stallman committed
828 829 830
  (interactive)
  (tar-extract t))

831
(defun tar-display-other-window ()
832
  "In Tar mode, display this entry of the tar file in another window."
833 834 835
  (interactive)
  (tar-extract 'display))

Richard M. Stallman's avatar
Richard M. Stallman committed
836
(defun tar-view ()
837
  "In Tar mode, view the tar file entry on this line."
Richard M. Stallman's avatar
Richard M. Stallman committed
838 839 840 841 842
  (interactive)
  (tar-extract 'view))


(defun tar-read-file-name (&optional prompt)
843
  "Read a file name with this line's entry as the default."
Richard M. Stallman's avatar
Richard M. Stallman committed
844 845
  (or prompt (setq prompt "Copy to: "))
  (let* ((default-file (expand-file-name
Stefan Monnier's avatar
Stefan Monnier committed
846
			(tar-header-name (tar-current-descriptor))))
Richard M. Stallman's avatar
Richard M. Stallman committed
847 848 849 850 851 852 853 854 855 856 857 858 859 860 861
	 (target (expand-file-name
		  (read-file-name prompt
				  (file-name-directory default-file)
				  default-file nil))))
    (if (or (string= "" (file-name-nondirectory target))
	    (file-directory-p target))
	(setq target (concat (if (string-match "/$" target)
				 (substring target 0 (1- (match-end 0)))
				 target)
			     "/"
			     (file-name-nondirectory default-file))))
    target))


(defun tar-copy (&optional to-file)
862
  "In Tar mode, extract this entry of the tar file into a file on disk.
Richard M. Stallman's avatar
Richard M. Stallman committed
863 864 865
If TO-FILE is not supplied, it is prompted for, defaulting to the name of
the current tar-entry."
  (interactive (list (tar-read-file-name)))
866
  (let* ((descriptor (tar-get-descriptor))
Stefan Monnier's avatar
Stefan Monnier committed
867 868 869
	 (name (tar-header-name descriptor))
	 (size (tar-header-size descriptor))
	 (start (tar-header-data-start descriptor))
870 871 872
	 (end (+ start size))
	 (inhibit-file-name-handlers inhibit-file-name-handlers)
	 (inhibit-file-name-operation inhibit-file-name-operation))
873 874
    (save-restriction
      (widen)
875 876 877 878 879 880 881 882 883
      ;; Inhibit compressing a subfile again if *both* name and
      ;; to-file are handled by jka-compr
      (if (and (eq (find-file-name-handler name 'write-region) 'jka-compr-handler)
	       (eq (find-file-name-handler to-file 'write-region) 'jka-compr-handler))
	  (setq inhibit-file-name-handlers
		(cons 'jka-compr-handler
		      (and (eq inhibit-file-name-operation 'write-region)
			   inhibit-file-name-handlers))
		inhibit-file-name-operation 'write-region))
884 885
      (let ((coding-system-for-write 'no-conversion))
	(write-region start end to-file nil nil nil t)))
886
    (message "Copied tar entry %s to %s" name to-file)))
Richard M. Stallman's avatar
Richard M. Stallman committed
887 888

(defun tar-flag-deleted (p &optional unflag)
889
  "In Tar mode, mark this sub-file to be deleted from the tar file.
Richard M. Stallman's avatar
Richard M. Stallman committed
890 891 892
With a prefix argument, mark that many files."
  (interactive "p")
  (beginning-of-line)
893
  (dotimes (i (abs p))
Richard M. Stallman's avatar
Richard M. Stallman committed
894 895 896 897 898 899 900 901
    (if (tar-current-descriptor unflag) ; barf if we're not on an entry-line.
	(progn
	  (delete-char 1)
	  (insert (if unflag " " "D"))))
    (forward-line (if (< p 0) -1 1)))
  (if (eobp) nil (forward-char 36)))

(defun tar-unflag (p)
902
  "In Tar mode, un-mark this sub-file if it is marked to be deleted.
Richard M. Stallman's avatar
Richard M. Stallman committed
903 904 905 906 907
With a prefix argument, un-mark that many files forward."
  (interactive "p")
  (tar-flag-deleted p t))

(defun tar-unflag-backwards (p)
908
  "In Tar mode, un-mark this sub-file if it is marked to be deleted.
Richard M. Stallman's avatar
Richard M. Stallman committed
909 910 911 912 913 914 915
With a prefix argument, un-mark that many files backward."
  (interactive "p")
  (tar-flag-deleted (- p) t))


(defun tar-expunge-internal ()
  "Expunge the tar-entry specified by the current line."
916
  (let ((descriptor (tar-current-descriptor)))
Richard M. Stallman's avatar
Richard M. Stallman committed
917 918
    ;;
    ;; delete the current line...
919
    (delete-region (line-beginning-position) (line-beginning-position 2))
Richard M. Stallman's avatar
Richard M. Stallman committed
920 921 922 923 924
    ;;
    ;; delete the data pointer...
    (setq tar-parse-info (delq descriptor tar-parse-info))
    ;;
    ;; delete the data from inside the file...
925 926 927 928
    (with-current-buffer tar-data-buffer
      (delete-region (or (tar-header-header-start descriptor)
                         (- (tar-header-data-start descriptor) 512))
                     (tar-header-data-end descriptor)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
929 930 931


(defun tar-expunge (&optional noconfirm)
932
  "In Tar mode, delete all the archived files flagged for deletion.
Richard M. Stallman's avatar
Richard M. Stallman committed
933 934 935 936
This does not modify the disk image; you must save the tar file itself
for this to be permanent."
  (interactive)
  (if (or noconfirm
937
	  (y-or-n-p "Expunge files marked for deletion? "))
938
      (let ((n 0))
Richard M. Stallman's avatar
Richard M. Stallman committed
939
	(save-excursion
940
	  (goto-char (point-min))
Richard M. Stallman's avatar
Richard M. Stallman committed
941 942 943 944 945 946
	  (while (not (eobp))
	    (if (looking-at "D")
		(progn (tar-expunge-internal)
		       (setq n (1+ n)))
		(forward-line 1)))
	  ;; after doing the deletions, add any padding that may be necessary.
947
	  (tar-pad-to-blocksize))
Richard M. Stallman's avatar
Richard M. Stallman committed
948
	(if (zerop n)
949 950
	    (message "Nothing to expunge.")
	    (message "%s files expunged.  Be sure to save this buffer." n)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
951 952 953


(defun tar-clear-modification-flags ()
954
  "Remove the stars at the beginning of each line."
955
  (interactive)
Richard M. Stallman's avatar
Richard M. Stallman committed
956
  (save-excursion
957
    (goto-char (point-min))
958
    (while (not (eobp))
959
      (if (not (eq (following-char) ?\s))
Richard M. Stallman's avatar
Richard M. Stallman committed
960 961 962 963 964
	  (progn (delete-char 1) (insert " ")))
      (forward-line 1))))


(defun tar-chown-entry (new-uid)
965
  "Change the user-id associated with this entry in the tar file.
Richard M. Stallman's avatar
Richard M. Stallman committed
966 967 968 969 970
If this tar file was written by GNU tar, then you will be able to edit
the user id as a string; otherwise, you must edit it as a number.
You can force editing as a number by calling this with a prefix arg.
This does not modify the disk image; you must save the tar file itself
for this to be permanent."
Stefan Monnier's avatar
Stefan Monnier committed
971 972 973 974 975 976 977 978 979
  (interactive
   (list
    (let ((descriptor (tar-current-descriptor)))
      (if (or current-prefix-arg
              (not (tar-header-magic descriptor)))
          (read-number
           "New UID number: "
           (format "%s" (tar-header-uid descriptor)))
        (read-string "New UID string: " (tar-header-uname descriptor))))))