cgit.sxemacs.org Git - packages/blob - xemacs-packages/os-utils/tar-mode.el

   1 ;;; tar-mode.el --- simple editing of tar files from GNU emacs
   2
   3 ;; Copyright (C) 1990-1993, 1997 Free Software Foundation, Inc.
   4
   5 ;; Author: Jamie Zawinski <jwz@jwz.org>
   6 ;; Keywords: unix
   7 ;; Created: 4 Apr 1990
   8 ;; Version: 1.32
   9
  10 ;; This file is part of XEmacs.
  11
  12 ;; XEmacs is free software; you can redistribute it and/or modify it
  13 ;; under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; XEmacs is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with XEmacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Synched up with: partially synched with Emacs 20.
  28
  29 ;;; Commentary:
  30
  31 ;; This package attempts to make dealing with Unix 'tar' archives easier.
  32 ;; When this code is loaded, visiting a file whose name ends in '.tar' will
  33 ;; cause the contents of that archive file to be displayed in a Dired-like
  34 ;; listing.  It is then possible to use the customary Dired keybindings to
  35 ;; extract sub-files from that archive, either by reading them into their own
  36 ;; editor buffers, or by copying them directly to arbitrary files on disk.
  37 ;; It is also possible to delete sub-files from within the tar file and write
  38 ;; the modified archive back to disk, or to edit sub-files within the archive
  39 ;; and re-insert the modified files into the archive.  See the documentation
  40 ;; string of tar-mode for more info.
  41
  42 ;; To autoload, add this to your .emacs file:
  43 ;;
  44 ;;  (setq auto-mode-alist (cons '("\\.tar$" . tar-mode) auto-mode-alist))
  45 ;;  (autoload 'tar-mode "tar-mode")
  46 ;;
  47 ;; But beware: for certain tar files - those whose very first file has
  48 ;; a -*- property line - autoloading won't work.  See the function
  49 ;; "tar-normal-mode" to understand why.
  50
  51 ;; This code now understands the extra fields that GNU tar adds to tar files.
  52
  53 ;; This interacts correctly with "uncompress.el" in the Emacs library,
  54 ;; and with sufficiently recent versions of "crypt.el" by Kyle Jones.
  55
  56 ;;    ***************   TO DO   ***************
  57 ;;
  58 ;; o  chmod should understand "a+x,og-w".
  59 ;;
  60 ;; o  It's not possible to add a NEW file to a tar archive; not that
  61 ;;    important, but still...
  62 ;;
  63 ;; o  The code is less efficient that it could be - in a lot of places, I
  64 ;;    pull a 512-character string out of the buffer and parse it, when I could
  65 ;;    be parsing it in place, not garbaging a string.  Should redo that.
  66 ;;
  67 ;; o  I'd like a command that searches for a string/regexp in every subfile
  68 ;;    of an archive, where <esc> would leave you in a subfile-edit buffer.
  69 ;;    (Like M-s in VM and M-r in the Zmacs mail reader.)
  70 ;;
  71 ;; o  Sometimes (but not always) reverting the tar-file buffer does not
  72 ;;    re-grind the listing, and you are staring at the binary tar data.
  73 ;;    Typing 'g' again immediately after that will always revert and re-grind
  74 ;;    it, though.  I have no idea why this happens.
  75 ;;
  76 ;; o  Tar-mode interacts poorly with crypt.el and zcat.el because the tar
  77 ;;    write-file-hook actually writes the file.  Instead it should remove the
  78 ;;    header (and conspire to put it back afterwards) so that other write-file
  79 ;;    hooks which frob the buffer have a chance to do their dirty work.  There
  80 ;;    might be a problem if the tar write-file-hook does not come *first* on
  81 ;;    the list.
  82 ;;
  83 ;; o  Block files, sparse files, continuation files, and the various header
  84 ;;    types aren't editable.  Actually I don't know that they work at all.
  85 ;;    If you know that they work, or know that they don't, please let me know.
  86 ;;
  87 ;; o  Tar files inside of tar files don't work.
  88 ;;
  89 ;; o  When using crypt-mode, you can't save a compressed or encrypted subfile
  90 ;;    of a tar file back into the tar file: it is saved uncompressed.
  91
  92 ;;; Code:
  93
  94 (defgroup tar ()
  95   "Simple editing of tar files from GNU emacs."
  96   :group 'unix
  97   :group 'data)
  98
  99
 100 (defcustom tar-anal-blocksize 20
 101   "*The blocksize of tar files written by Emacs, or nil, meaning don't care.
 102 The blocksize of a tar file is not really the size of the blocks; rather, it is
 103 the number of blocks written with one system call.  When tarring to a tape,
 104 this is the size of the *tape* blocks, but when writing to a file, it doesn't
 105 matter much.  The only noticeable difference is that if a tar file does not
 106 have a blocksize of 20, the tar program will issue a warning; all this really
 107 controls is how many null padding bytes go on the end of the tar file."
 108   :type 'integer
 109   :group 'tar)
 110
 111 (defcustom tar-update-datestamp t
 112   "*Whether tar-mode should play fast and loose with sub-file datestamps;
 113 if this is true, then editing and saving a tar file entry back into its
 114 tar file will update its datestamp.  If false, the datestamp is unchanged.
 115 You may or may not want this - it is good in that you can tell when a file
 116 in a tar archive has been changed, but it is bad for the same reason that
 117 editing a file in the tar archive at all is bad - the changed version of
 118 the file never exists on disk.
 119
 120 This does not work in Emacs 18, because there's no way to get the current
 121 time as an integer - if this var is true, then editing a file sets its date
 122 to midnight, Jan 1 1970 GMT, which happens to be what 0 encodes."
 123   :type 'boolean
 124   :group 'tar)
 125
 126 \f
 127 ;;; First, duplicate some Common Lisp functions; I used to just (require 'cl)
 128 ;;; but "cl.el" was messing some people up (also it's really big).
 129
 130 ;; No need for that stuff anymore -- XEmacs preloads cl.el anyway.
 131
 132 \f
 133 ;;; down to business.
 134
 135 (defmacro tar-make-header (name mode uid git size date ck lt ln
 136                                 magic uname gname devmaj devmin)
 137   (list 'vector name mode uid git size date ck lt ln
 138         magic uname gname devmaj devmin))
 139
 140 (defmacro tar-header-name (x) (list 'aref x 0))
 141 (defmacro tar-header-mode (x) (list 'aref x 1))
 142 (defmacro tar-header-uid  (x) (list 'aref x 2))
 143 (defmacro tar-header-gid  (x) (list 'aref x 3))
 144 (defmacro tar-header-size (x) (list 'aref x 4))
 145 (defmacro tar-header-date (x) (list 'aref x 5))
 146 (defmacro tar-header-checksum  (x) (list 'aref x 6))
 147 (defmacro tar-header-link-type (x) (list 'aref x 7))
 148 (defmacro tar-header-link-name (x) (list 'aref x 8))
 149 (defmacro tar-header-magic (x) (list 'aref x 9))
 150 (defmacro tar-header-uname (x) (list 'aref x 10))
 151 (defmacro tar-header-gname (x) (list 'aref x 11))
 152 (defmacro tar-header-dmaj (x) (list 'aref x 12))
 153 (defmacro tar-header-dmin (x) (list 'aref x 13))
 154
 155 (defmacro tar-make-desc (data-start tokens)
 156   (list 'cons data-start tokens))
 157
 158 (defmacro tar-desc-data-start (x) (list 'car x))
 159 (defmacro tar-desc-tokens     (x) (list 'cdr x))
 160
 161 (defconst tar-name-offset 0)
 162 (defconst tar-mode-offset (+ tar-name-offset 100))
 163 (defconst tar-uid-offset  (+ tar-mode-offset 8))
 164 (defconst tar-gid-offset  (+ tar-uid-offset 8))
 165 (defconst tar-size-offset (+ tar-gid-offset 8))
 166 (defconst tar-time-offset (+ tar-size-offset 12))
 167 (defconst tar-chk-offset  (+ tar-time-offset 12))
 168 (defconst tar-linkp-offset (+ tar-chk-offset 8))
 169 (defconst tar-link-offset (+ tar-linkp-offset 1))
 170 ;;; GNU-tar specific slots.
 171 (defconst tar-magic-offset (+ tar-link-offset 100))
 172 (defconst tar-uname-offset (+ tar-magic-offset 8))
 173 (defconst tar-gname-offset (+ tar-uname-offset 32))
 174 (defconst tar-dmaj-offset (+ tar-gname-offset 32))
 175 (defconst tar-dmin-offset (+ tar-dmaj-offset 8))
 176 (defconst tar-end-offset (+ tar-dmin-offset 8))
 177
 178 (defun tar-tokenize-header-block (string)
 179   "Return a `tar-header' structure.
 180 This is a list of name, mode, uid, gid, size,
 181 write-date, checksum, link-type, and link-name."
 182   (cond ((< (length string) 512) nil)
 183         (;(some 'plusp string)           ; <-- oops, massive cycle hog!
 184          (or (not (= 0 (aref string 0))) ; This will do.
 185              (not (= 0 (aref string 101))))
 186          (let* ((name-end (1- tar-mode-offset))
 187                 (link-end (1- tar-magic-offset))
 188                 (uname-end (1- tar-gname-offset))
 189                 (gname-end (1- tar-dmaj-offset))
 190                 (link-p (aref string tar-linkp-offset))
 191                 (magic-str (substring string tar-magic-offset (1- tar-uname-offset)))
 192                 (uname-valid-p (or (string= "ustar  " magic-str) (string= "GNUtar " magic-str)))
 193                 name
 194                 (nulsexp   "[^\000]*\000"))
 195            (and (string-match nulsexp string tar-name-offset) (setq name-end (min name-end (1- (match-end 0)))))
 196            (and (string-match nulsexp string tar-link-offset) (setq link-end (min link-end (1- (match-end 0)))))
 197            (and (string-match nulsexp string tar-uname-offset) (setq uname-end (min uname-end (1- (match-end 0)))))
 198            (and (string-match nulsexp string tar-gname-offset) (setq gname-end (min gname-end (1- (match-end 0)))))
 199            (setq name (substring string tar-name-offset name-end)
 200                  link-p (if (or (= link-p 0) (= link-p ?0))
 201                             nil
 202                           (- link-p ?0)))
 203            (if (and (null link-p) (string-match "/$" name)) (setq link-p 5)) ; directory
 204            (tar-make-header
 205             name
 206             (tar-parse-octal-integer string tar-mode-offset (1- tar-uid-offset))
 207             (tar-parse-octal-integer string tar-uid-offset (1- tar-gid-offset))
 208             (tar-parse-octal-integer string tar-gid-offset (1- tar-size-offset))
 209             (tar-parse-octal-integer string tar-size-offset (1- tar-time-offset))
 210             (tar-parse-octal-integer-32 string tar-time-offset (1- tar-chk-offset))
 211             (tar-parse-octal-integer string tar-chk-offset (1- tar-linkp-offset))
 212             link-p
 213             (substring string tar-link-offset link-end)
 214             uname-valid-p
 215             (and uname-valid-p (substring string tar-uname-offset uname-end))
 216             (and uname-valid-p (substring string tar-gname-offset gname-end))
 217             (tar-parse-octal-integer string tar-dmaj-offset (1- tar-dmin-offset))
 218             (tar-parse-octal-integer string tar-dmin-offset (1- tar-end-offset))
 219             )))
 220         (t 'empty-tar-block)))
 221
 222
 223 (defun tar-parse-octal-integer (string &optional start end)
 224   (if (null start) (setq start 0))
 225   (if (null end) (setq end (length string)))
 226   (if (= (aref string start) 0)
 227       0
 228     (let ((n 0))
 229       (while (< start end)
 230         (setq n (if (< (aref string start) ?0) n
 231                   (+ (* n 8) (- (aref string start) 48)))
 232               start (1+ start)))
 233       n)))
 234
 235 (defun tar-parse-octal-integer-32 (string &optional start end)
 236   ;; like tar-parse-octal-integer, but returns a cons of two 16-bit numbers,
 237   ;; since elisp can't handle integers of that magnitude.
 238   (or start (setq start 0))
 239   (or end (setq end (length string)))
 240   (let ((top (tar-parse-octal-integer string start (- end 6)))
 241         (bot (tar-parse-octal-integer string (- end 6) end)))
 242     (setq top (logior (ash top 2) (ash bot -16)))
 243     (setq bot (logand bot 65535))
 244     (cons top bot)))
 245
 246 (defun tar-parse-octal-integer-safe (string)
 247   (let ((L (length string)))
 248     (if (= L 0) (error "empty string"))
 249     (dotimes (i L)
 250       (if (or (< (aref string i) ?0)
 251               (> (aref string i) ?7))
 252           (error "'%c' is not an octal digit."))))
 253   (tar-parse-octal-integer string))
 254
 255
 256 (defun tar-header-block-checksum (string)
 257   "Compute and return a tar-acceptable checksum for this block."
 258   (let* ((chk-field-start tar-chk-offset)
 259          (chk-field-end (+ chk-field-start 8))
 260          (sum 0)
 261          (i 0))
 262     ;; Add up all of the characters except the ones in the checksum field.
 263     ;; Add that field as if it were filled with spaces.
 264     (while (< i chk-field-start)
 265       (setq sum (+ sum (aref string i))
 266             i (1+ i)))
 267     (setq i chk-field-end)
 268     (while (< i 512)
 269       (setq sum (+ sum (aref string i))
 270             i (1+ i)))
 271     (+ sum (* 32 8))))
 272
 273 (defun tar-header-block-check-checksum (hblock desired-checksum file-name)
 274   "Beep and print a warning if the checksum doesn't match."
 275   (if (not (= desired-checksum (tar-header-block-checksum hblock)))
 276       (progn (beep) (message "Invalid checksum for file %s!" file-name))))
 277
 278 (defun tar-header-block-recompute-checksum (hblock)
 279   "Modifies the given string to have a valid checksum field."
 280   (let* ((chk (tar-header-block-checksum hblock))
 281          (chk-string (format "%6o" chk))
 282          (l (length chk-string)))
 283     (aset hblock 154 0)
 284     (aset hblock 155 32)
 285     (dotimes (i l) (aset hblock (- 153 i) (aref chk-string (- l i 1)))))
 286   hblock)
 287
 288
 289 (defun tar-grind-file-mode (mode string start)
 290   "Store `-rw--r--r--' indicating MODE into STRING beginning at START.
 291 MODE should be an integer which is a file mode value."
 292   (aset string start       (if (zerop (logand 256 mode)) ?- ?r))
 293   (aset string (+ start 1) (if (zerop (logand 128 mode)) ?- ?w))
 294   (aset string (+ start 2) (if (zerop (logand  64 mode)) ?- ?x))
 295   (aset string (+ start 3) (if (zerop (logand  32 mode)) ?- ?r))
 296   (aset string (+ start 4) (if (zerop (logand  16 mode)) ?- ?w))
 297   (aset string (+ start 5) (if (zerop (logand   8 mode)) ?- ?x))
 298   (aset string (+ start 6) (if (zerop (logand   4 mode)) ?- ?r))
 299   (aset string (+ start 7) (if (zerop (logand   2 mode)) ?- ?w))
 300   (aset string (+ start 8) (if (zerop (logand   1 mode)) ?- ?x))
 301   (if (zerop (logand 1024 mode)) nil (aset string (+ start 2) ?s))
 302   (if (zerop (logand 2048 mode)) nil (aset string (+ start 5) ?s))
 303   string)
 304
 305
 306 (defconst tar-can-print-dates (or (fboundp 'current-time)
 307                                   (fboundp 'current-time-seconds))
 308   "true if this emacs has been built with time-printing support")
 309
 310 (defun tar-summarize-header-block (tar-hblock &optional mod-p)
 311   "Returns a line similar to the output of `tar -vtf'."
 312   (let ((name (tar-header-name tar-hblock))
 313         (mode (tar-header-mode tar-hblock))
 314         (uid (tar-header-uid tar-hblock))
 315         (gid (tar-header-gid tar-hblock))
 316         (uname (tar-header-uname tar-hblock))
 317         (gname (tar-header-gname tar-hblock))
 318         (size (tar-header-size tar-hblock))
 319         (time (tar-header-date tar-hblock))
 320         (ck (tar-header-checksum tar-hblock))
 321         (link-p (tar-header-link-type tar-hblock))
 322         (link-name (tar-header-link-name tar-hblock))
 323         )
 324     (let* ((left 11)
 325            (namew 8)
 326            (groupw 8)
 327            (sizew 8)
 328            (datew (if tar-can-print-dates 15 2))
 329            (slash (1- (+ left namew)))
 330            (lastdigit (+ slash groupw sizew))
 331            (namestart (+ lastdigit datew))
 332            (string (make-string (+ namestart (length name) (if link-p (+ 5 (length link-name)) 0)) 32))
 333            (type (tar-header-link-type tar-hblock)))
 334       (aset string 0 (if mod-p ?* ? ))
 335       (aset string 1
 336             (cond ((or (eq type nil) (eq type 0)) ?-)
 337                   ((eq type 1) ?l)      ; link
 338                   ((eq type 2) ?s)      ; symlink
 339                   ((eq type 3) ?c)      ; char special
 340                   ((eq type 4) ?b)      ; block special
 341                   ((eq type 5) ?d)      ; directory
 342                   ((eq type 6) ?p)      ; FIFO/pipe
 343                   ((eq type 20) ?*)     ; directory listing
 344                   ((eq type 29) ?M)     ; multivolume continuation
 345                   ((eq type 35) ?S)     ; sparse
 346                   ((eq type 38) ?V)     ; volume header
 347                   ))
 348       (tar-grind-file-mode mode string 2)
 349       (setq uid (if (= 0 (length uname)) (int-to-string uid) uname))
 350       (setq gid (if (= 0 (length gname)) (int-to-string gid) gname))
 351       (setq size (int-to-string size))
 352       (dotimes (i (min (1- namew) (length uid))) (aset string (- slash i) (aref uid (- (length uid) i 1))))
 353       (aset string (1+ slash) ?/)
 354       (dotimes (i (min (1- groupw) (length gid))) (aset string (+ (+ slash 2) i) (aref gid i)))
 355       (dotimes (i (min sizew (length size))) (aset string (- lastdigit i) (aref size (- (length size) i 1))))
 356
 357       (if tar-can-print-dates
 358           (let* ((year (substring (current-time-string) -4))
 359                  ;; in v18, current-time-string doesn't take an argument
 360                  (file (current-time-string time))
 361                  (file-year (substring file -4))
 362                  (str (if (equal year file-year)
 363                           (substring file 4 16)
 364                         (concat (substring file 4 11) " " file-year))))
 365             (dotimes (i 12) (aset string (- namestart (- 13 i)) (aref str i)))))
 366
 367       (dotimes (i (length name)) (aset string (+ namestart i) (aref name i)))
 368       (if (or (eq link-p 1) (eq link-p 2))
 369           (progn
 370             (dotimes (i 3) (aset string (+ namestart 1 (length name) i) (aref (if (= link-p 1) "==>" "-->") i)))
 371             (dotimes (i (length link-name)) (aset string (+ namestart 5 (length name) i) (aref link-name i)))))
 372       string)))
 373
 374
 375 ;; buffer-local variables in the tar file's buffer:
 376 ;;
 377 (defvar tar-parse-info)                 ; the header structures
 378 (defvar tar-header-offset)              ; the end of the "pretty" data
 379
 380 (defun tar-summarize-buffer ()
 381   "Parse the contents of the tar file in the current buffer, and place a
 382 dired-like listing on the front; then narrow to it, so that only that listing
 383 is visible (and the real data of the buffer is hidden)."
 384   (message "parsing tar file...")
 385   (let* ((result '())
 386          (pos 1)
 387          (bs (max 1 (- (buffer-size) 1024))) ; always 2+ empty blocks at end.
 388          (bs100 (max 1 (/ bs 100)))
 389          (tokens nil))
 390     (while (not (eq tokens 'empty-tar-block))
 391       (if (> (+ pos 512) (point-max))
 392           (error "truncated tar file"))
 393       (let* ((hblock (buffer-substring pos (+ pos 512))))
 394         (setq tokens (tar-tokenize-header-block hblock))
 395         (setq pos (+ pos 512))
 396         (message "parsing tar file...%s%%"
 397                                 ;(/ (* pos 100) bs)   ; this gets round-off lossage
 398                  (/ pos bs100)          ; this doesn't
 399                  )
 400         (if (eq tokens 'empty-tar-block)
 401             nil
 402           (if (null tokens) (error "premature EOF parsing tar file."))
 403           (if (eq (tar-header-link-type tokens) 20)
 404               ;; Foo.  There's an extra empty block after these.
 405               (setq pos (+ pos 512)))
 406           (let ((size (tar-header-size tokens)))
 407             (if (< size 0)
 408                 (error "%s has size %s - corrupted."
 409                        (tar-header-name tokens) size))
 410                         ;
 411                         ; This is just too slow.  Don't really need it anyway....
 412                         ;(tar-check-header-block-checksum
 413                         ;  hblock (tar-checksum-header-block hblock)
 414                         ;  (tar-header-name tokens))
 415
 416             (setq result (cons (tar-make-desc pos tokens) result))
 417
 418             (if (and (null (tar-header-link-type tokens))
 419                      (> size 0))
 420                 (setq pos
 421                       (+ pos 512 (ash (ash (1- size) -9) 9)) ; this works
 422                         ;(+ pos (+ size (- 512 (rem (1- size) 512)))) ; this doesn't
 423                       ))
 424             ))))
 425     (make-local-variable 'tar-parse-info)
 426     (setq tar-parse-info (nreverse result)))
 427   (message "parsing tar file...formatting...")
 428   (save-excursion
 429     (goto-char (point-min))
 430     (let ((buffer-read-only nil))
 431       (dolist (tar-desc tar-parse-info)
 432         (insert
 433          (tar-summarize-header-block (tar-desc-tokens tar-desc))
 434          "\n"))
 435       (make-local-variable 'tar-header-offset)
 436       (setq tar-header-offset (point))
 437       (narrow-to-region 1 tar-header-offset)
 438       (set-buffer-modified-p nil)))
 439   (message "parsing tar file...done."))
 440
 441
 442 (defvar tar-mode-map nil "*Local keymap for tar-mode listings.")
 443
 444 (if tar-mode-map
 445     nil
 446   (setq tar-mode-map (make-keymap))
 447   (suppress-keymap tar-mode-map)
 448   ;; Commands to mark certain categories of files
 449   ;; Upper case keys for operating on the marked files
 450   (define-key tar-mode-map "C" 'tar-copy)
 451   (define-key tar-mode-map "R" 'tar-rename-entry)
 452   (define-key tar-mode-map "M" 'tar-chmod-entry)
 453   (define-key tar-mode-map "G" 'tar-chgrp-entry)
 454   (define-key tar-mode-map "O" 'tar-chown-entry)
 455   ;; Lower keys for commands not operating on all the marked files
 456   (define-key tar-mode-map "d" 'tar-flag-deleted)
 457   (define-key tar-mode-map "\^D" 'tar-flag-deleted)
 458   (define-key tar-mode-map "e" 'tar-extract)
 459   (define-key tar-mode-map "f" 'tar-extract)
 460   (define-key tar-mode-map [return] 'tar-extract)
 461   (define-key tar-mode-map "g" 'revert-buffer)
 462   (define-key tar-mode-map "h" 'describe-mode)
 463   (define-key tar-mode-map "o" 'tar-extract-other-window)
 464   (define-key tar-mode-map "q" 'tar-quit)
 465   (define-key tar-mode-map "u" 'tar-unflag)
 466   (define-key tar-mode-map "v" 'tar-view)
 467   (define-key tar-mode-map "x" 'tar-expunge)
 468   (define-key tar-mode-map 'backspace 'tar-unflag-backwards)
 469   (define-key tar-mode-map 'delete 'tar-unflag-backwards)
 470   (define-key tar-mode-map "E" 'tar-extract-other-window)
 471   ;; moving
 472   (define-key tar-mode-map " " 'tar-next-line)
 473   (define-key tar-mode-map "n" 'tar-next-line)
 474   (define-key tar-mode-map "\^N" 'tar-next-line)
 475   (define-key tar-mode-map [down] 'tar-next-line)
 476   (define-key tar-mode-map "p" 'tar-previous-line)
 477   (define-key tar-mode-map "\^P" 'tar-previous-line)
 478   (define-key tar-mode-map [up] 'tar-previous-line)
 479
 480   (cond ((and (featurep 'xemacs)
 481               (not (featurep 'infodock)))
 482          (define-key tar-mode-map 'button2 'tar-track-mouse-and-extract-file)
 483          (define-key tar-mode-map 'button3 'tar-popup-menu)))
 484   )
 485
 486
 487 ;; XEmacs menu mouse/support added by Heiko Muenkel
 488 ;; muenkel@tnt.uni-hannover.de
 489
 490 (autoload 'dired-mark-region "dired-xemacs-menu")
 491
 492 (defvar tar-menu
 493   '("Tar Mode Commands"
 494     ["Copy Subfile to Disk" tar-copy t]
 495     ["Rename Subfile" tar-rename-entry t]
 496     "----"
 497     ["Delete Flaged Subfiles" tar-expunge t]
 498     ["Flag Subfile for Deletion" tar-flag-deleted t]
 499     ["Flag Subfiles in Region for Deletion"
 500      (dired-mark-region '(tar-flag-deleted 1))
 501      (mark)]
 502     ["Unflag Subfile" tar-unflag t]
 503     ["Unflag Subfiles in Region"
 504      (dired-mark-region '(tar-flag-deleted 1 t))
 505      (mark)]
 506     "----"
 507     ["Change Permissions of Subfile..." tar-chmod-entry t]
 508     ["Change Group of Subfile..." tar-chgrp-entry t]
 509     ["Change Owner of Subfile..." tar-chown-entry t]
 510     "----"
 511     ["Edit Subfile Other Window" tar-extract-other-window t]
 512     ["Edit Subfile" tar-extract t]
 513     ["View Subfile" tar-view t]
 514     "----"
 515     ["Quit Tar Mode" tar-quit t]
 516     ))
 517
 518
 519 (defun tar-track-mouse-and-extract-file (event)
 520   "Visit the tar-file-entry upon which the mouse is clicked."
 521   (interactive "e")
 522   (mouse-set-point event)
 523   (tar-next-line 0)
 524   (let (buffer)
 525     (save-excursion
 526       (tar-extract)
 527       (setq buffer (current-buffer)))
 528     (switch-to-buffer buffer)))
 529
 530 (defun tar-popup-menu (event)
 531   "Display the tar-mode menu."
 532   (interactive "@e")
 533   (mouse-set-point event)
 534   (tar-next-line 0)
 535   (popup-menu tar-menu))
 536
 537
 538 ;; tar mode is suitable only for specially formatted data.
 539 (put 'tar-mode 'mode-class 'special)
 540 (put 'tar-subfile-mode 'mode-class 'special)
 541
 542 ;;;###autoload
 543 (defun tar-mode ()
 544   "Major mode for viewing a tar file as a dired-like listing of its contents.
 545 You can move around using the usual cursor motion commands.
 546 Letters no longer insert themselves.
 547 Type `e' to pull a file out of the tar file and into its own buffer;
 548 or click mouse-2 on the file's line in the Tar mode buffer.
 549 Type `c' to copy an entry from the tar file into another file on disk.
 550
 551 If you edit a sub-file of this archive (as with the `e' command) and
 552 save it with Control-x Control-s, the contents of that buffer will be
 553 saved back into the tar-file buffer; in this way you can edit a file
 554 inside of a tar archive without extracting it and re-archiving it.
 555
 556 See also: variables `tar-update-datestamp' and `tar-anal-blocksize'.
 557 \\{tar-mode-map}"
 558   ;; this is not interactive because you shouldn't be turning this
 559   ;; mode on and off.  You can corrupt things that way.
 560   (make-local-variable 'tar-header-offset)
 561   (make-local-variable 'tar-parse-info)
 562   (make-local-variable 'require-final-newline)
 563   (setq require-final-newline nil)      ; binary data, dude...
 564   (make-local-variable 'revert-buffer-function)
 565   (setq revert-buffer-function 'tar-mode-revert)
 566   (setq major-mode 'tar-mode)
 567   (setq mode-name "Tar")
 568   (use-local-map tar-mode-map)
 569   (auto-save-mode 0)
 570   (widen)
 571   (if (and (boundp 'tar-header-offset) tar-header-offset)
 572       (narrow-to-region 1 tar-header-offset)
 573     (tar-summarize-buffer))
 574   (cond ((string-match "XEmacs" emacs-version)
 575          (require 'mode-motion)
 576          (setq mode-motion-hook 'mode-motion-highlight-line)
 577          (when (and (boundp 'current-menubar)
 578                     current-menubar
 579                     (not (assoc "Tar" current-menubar)))
 580            (set-buffer-menubar (copy-sequence current-menubar))
 581            (add-menu nil "Tar" (cdr tar-menu)))
 582          ))
 583   (run-hooks 'tar-mode-hook))
 584
 585 ;; buffer-local variables in subfile mode.
 586 ;;
 587 (defvar tar-subfile-mode nil)           ; whether the minor-mode is on
 588 (defvar tar-superior-buffer)            ; parent buffer
 589 (defvar tar-superior-descriptor)        ; header object of this file
 590 (defvar tar-subfile-buffer-id)          ; pretty name-string
 591 (defvar subfile-orig-mlbid)             ; orig mode-line-buffer-identification
 592
 593 (defun tar-subfile-mode (p)
 594   "Minor mode for editing an element of a tar-file.
 595 This mode arranges for \"saving\" this buffer to write the data
 596 into the tar-file buffer that it came from.  The changes will actually
 597 appear on disk when you save the tar-file's buffer."
 598   (interactive "P")
 599   (or (and (boundp 'tar-superior-buffer) tar-superior-buffer)
 600       (error "This buffer is not an element of a tar file."))
 601   (or (assq 'tar-subfile-mode minor-mode-alist)
 602       (setq minor-mode-alist (append minor-mode-alist
 603                                      (list '(tar-subfile-mode " TarFile")))))
 604   (make-local-variable 'tar-subfile-mode)
 605   (setq tar-subfile-mode
 606         (if (null p)
 607             (not tar-subfile-mode)
 608           (> (prefix-numeric-value p) 0)))
 609   (cond (tar-subfile-mode
 610          ;; copy the local keymap so that we don't accidentally
 611          ;; alter a keymap like 'lisp-mode-map' which is shared
 612          ;; by all buffers in that mode.
 613          (let ((m (current-local-map)))
 614            (if m (use-local-map (copy-keymap m))))
 615          (local-set-key "\^X\^S" 'tar-subfile-save-buffer)
 616          ;; turn off auto-save.
 617          (setq buffer-auto-save-file-name nil)
 618          (auto-save-mode 0)
 619          (run-hooks 'tar-subfile-mode-hook))
 620         (t
 621          ;; remove the local binding for C-x C-s.
 622          (local-unset-key "\^X\^S")
 623          (if subfile-orig-mlbid
 624              (set (make-local-variable 'mode-line-buffer-identification)
 625                   subfile-orig-mlbid))
 626          (setq tar-superior-buffer nil
 627                tar-superior-descriptor nil
 628                subfile-orig-mlbid nil)
 629          ))
 630   )
 631
 632 (defun tar-subfile-after-write-file-hook ()
 633   ;; if the buffer has a filename, then it is no longer associated with
 634   ;; the tar file.  Turn off subfile mode.
 635   (if (and buffer-file-name tar-subfile-mode)
 636       (tar-subfile-mode -1)))
 637
 638 (defun tar-mode-revert (&optional no-autosave no-confirm)
 639   "Revert this buffer and turn on tar mode again, to re-compute the
 640 directory listing."
 641   (setq tar-header-offset nil)
 642   (let ((revert-buffer-function nil))
 643     (revert-buffer t no-confirm)
 644     (widen))
 645   (tar-mode))
 646
 647
 648 (defun tar-next-line (p)
 649   (interactive "p")
 650   (forward-line p)
 651   (if (eobp) nil (forward-char (if tar-can-print-dates 48 36))))
 652
 653 (defun tar-previous-line (p)
 654   (interactive "p")
 655   (tar-next-line (- p)))
 656
 657 (defun tar-current-descriptor (&optional noerror)
 658   "Returns the tar-descriptor of the current line, or signals an error."
 659   ;; I wish lines had plists, like in ZMACS...
 660   (or (nth (count-lines (point-min)
 661                         (save-excursion (beginning-of-line) (point)))
 662            tar-parse-info)
 663       (if noerror
 664           nil
 665         (error "This line does not describe a tar-file entry."))))
 666
 667
 668 (defun tar-extract (&optional other-window-p)
 669   "In tar-mode, extract this entry of the tar file into its own buffer."
 670   (interactive)
 671   (let* ((view-p (eq other-window-p 'view))
 672          (descriptor (tar-current-descriptor))
 673          (tokens (tar-desc-tokens descriptor))
 674          (name (tar-header-name tokens))
 675          (size (tar-header-size tokens))
 676          (link-p (tar-header-link-type tokens))
 677          (start (+ (tar-desc-data-start descriptor) tar-header-offset -1))
 678          (end (+ start size)))
 679     (if link-p
 680         (error "This is a %s, not a real file."
 681                (cond ((eq link-p 5) "directory")
 682                      ((eq link-p 20) "tar directory header")
 683                      ((eq link-p 29) "multivolume-continuation")
 684                      ((eq link-p 35) "sparse entry")
 685                      ((eq link-p 38) "volume header")
 686                      (t "link"))))
 687     (if (zerop size) (error "This is a zero-length file."))
 688     (let* ((tar-buffer (current-buffer))
 689            (bufname (file-name-nondirectory name))
 690            (bufid (concat               ;" (" name " in "
 691                    " (in "
 692                    (file-name-nondirectory (buffer-file-name))
 693                    ")"))
 694            (read-only-p (or buffer-read-only view-p))
 695            (buffer nil)
 696            (buffers (buffer-list))
 697            (just-created nil))
 698       ;; find a buffer visiting this subfile from this tar file.
 699       (while (and buffers (not buffer))
 700         (set-buffer (car buffers))
 701         (if (and (null (buffer-file-name (car buffers)))
 702                  (boundp 'tar-superior-descriptor)
 703                  (eq tar-superior-descriptor descriptor))
 704             (setq buffer (car buffers))
 705           (setq buffers (cdr buffers))))
 706       (set-buffer tar-buffer)
 707       (if buffer
 708           nil
 709         (setq buffer (generate-new-buffer bufname))
 710         (setq just-created t)
 711         (unwind-protect
 712             (progn
 713               (widen)
 714               (save-excursion
 715                 (set-buffer buffer)
 716                 (insert-buffer-substring tar-buffer start end)
 717                 (goto-char 0)
 718                 (let ((lock-directory nil)) ; disable locking
 719                   (set-visited-file-name name) ; give it a name to decide mode.
 720                   ;;              (normal-mode)  ; pick a mode.
 721                   ;;              (after-find-file nil nil)  ; pick a mode; works with crypt.el
 722                   ;; Ok, instead of running after-find-file, just invoke the
 723                   ;; find-file-hooks instead.  This does everything we want
 724                   ;; from after-find-file, without losing when visiting .tar
 725                   ;; files via ange-ftp: doesn't probe the ftp site for the
 726                   ;; name of the subfile.
 727                   (normal-mode t)
 728                   (run-hooks 'find-file-hooks)
 729                   (set-visited-file-name nil) ; nuke the name - not meaningful.
 730                   )
 731                 (make-local-variable 'tar-superior-buffer)
 732                 (make-local-variable 'tar-superior-descriptor)
 733                 (make-local-variable 'mode-line-buffer-identification)
 734                 (make-local-variable 'tar-subfile-buffer-id)
 735                 (make-local-variable 'subfile-orig-mlbid)
 736                 (setq tar-superior-buffer tar-buffer)
 737                 (setq tar-superior-descriptor descriptor)
 738                 (setq tar-subfile-buffer-id bufid)
 739                 (setq subfile-orig-mlbid mode-line-buffer-identification)
 740                 (cond ((stringp mode-line-buffer-identification)
 741                        (setq mode-line-buffer-identification
 742                              (list mode-line-buffer-identification))))
 743                 (let ((ms (car mode-line-buffer-identification))
 744                       n)
 745                   (cond ((and (stringp ms)
 746                               (string-match "%\\([0-9]+\\)b\\'" ms))
 747                          (setq mode-line-buffer-identification
 748                                (cons
 749                                 (concat (substring ms 0
 750                                                    (1- (match-beginning 1)))
 751                                         (substring ms (1+ (match-end 1))))
 752                                 (cons
 753                                  (list (car (read-from-string
 754                                              (substring ms (match-beginning 1)
 755                                                         (match-end 1))))
 756                                        (concat "%b" tar-subfile-buffer-id))
 757                                  (cdr mode-line-buffer-identification)))))
 758                         (t
 759                          (setq mode-line-buffer-identification
 760                                (list "Emacs: "
 761                                      (list 17
 762                                            (concat "%b"
 763                                                    tar-subfile-buffer-id)))))))
 764                 (tar-subfile-mode 1)
 765
 766                 (setq buffer-read-only read-only-p)
 767                 (set-buffer-modified-p nil))
 768               (set-buffer tar-buffer))
 769           (narrow-to-region 1 tar-header-offset)))
 770       (if view-p
 771           (progn
 772             (view-buffer-other-window buffer)
 773             (save-excursion
 774               (set-buffer buffer)
 775               ;; for view-less.el; view.el can't do this.
 776               (set (make-local-variable 'view-kill-on-exit) t)))
 777         (if other-window-p
 778             (switch-to-buffer-other-window buffer)
 779           (switch-to-buffer buffer))))))
 780
 781
 782 (defun tar-extract-other-window ()
 783   "In tar-mode, extract this entry of the tar file into its own buffer."
 784   (interactive)
 785   (tar-extract t))
 786
 787 (defun tar-view ()
 788   "In tar-mode, view the tar file entry on this line."
 789   (interactive)
 790   (tar-extract 'view))
 791
 792
 793 (defun tar-read-file-name (&optional prompt)
 794   "Read a file name with this line's entry as the default."
 795   (or prompt (setq prompt "Copy to: "))
 796   (let* ((default-file (expand-file-name
 797                         (tar-header-name (tar-desc-tokens
 798                                           (tar-current-descriptor)))))
 799          (target (expand-file-name
 800                   (read-file-name prompt
 801                                   (file-name-directory default-file)
 802                                   default-file nil))))
 803     (if (or (string= "" (file-name-nondirectory target))
 804             (file-directory-p target))
 805         (setq target (concat (if (string-match "/$" target)
 806                                  (substring target 0 (1- (match-end 0)))
 807                                target)
 808                              "/"
 809                              (file-name-nondirectory default-file))))
 810     target))
 811
 812
 813 (defun tar-copy (&optional to-file)
 814   "In tar-mode, extract this entry of the tar file into a file on disk.
 815 If TO-FILE is not supplied, it is prompted for, defaulting to the name of
 816 the current tar-entry."
 817   (interactive (list (tar-read-file-name)))
 818   (let* ((descriptor (tar-current-descriptor))
 819          (tokens (tar-desc-tokens descriptor))
 820          (name (tar-header-name tokens))
 821          (size (tar-header-size tokens))
 822          (link-p (tar-header-link-type tokens))
 823          (start (+ (tar-desc-data-start descriptor) tar-header-offset -1))
 824          (end (+ start size)))
 825     (if link-p (error "This is a link, not a real file."))
 826     (if (zerop size) (error "This is a zero-length file."))
 827     (let* ((tar-buffer (current-buffer))
 828            buffer)
 829       (unwind-protect
 830           (progn
 831             (setq buffer (generate-new-buffer "*tar-copy-tmp*"))
 832             (widen)
 833             (save-excursion
 834               (set-buffer buffer)
 835               (insert-buffer-substring tar-buffer start end)
 836               (set-buffer-modified-p nil) ; in case we abort
 837               (write-file to-file)
 838               (message "Copied tar entry %s to %s" name to-file)
 839               (set-buffer tar-buffer)))
 840         (narrow-to-region 1 tar-header-offset)
 841         (if buffer (kill-buffer buffer)))
 842       )))
 843
 844
 845 (defun tar-flag-deleted (p &optional unflag)
 846   "In tar-mode, mark this sub-file to be deleted from the tar file.
 847 With a prefix argument, mark that many files."
 848   (interactive "p")
 849   (beginning-of-line)
 850   (dotimes (i (if (< p 0) (- p) p))
 851     (if (tar-current-descriptor unflag) ; barf if we're not on an entry-line.
 852         (progn
 853           (delete-char 1)
 854           (insert (if unflag " " "D"))))
 855     (forward-line (if (< p 0) -1 1)))
 856   (if (eobp) nil (forward-char 36)))
 857
 858 (defun tar-unflag (p)
 859   "In tar-mode, un-mark this sub-file if it is marked to be deleted.
 860 With a prefix argument, un-mark that many files forward."
 861   (interactive "p")
 862   (tar-flag-deleted p t))
 863
 864 (defun tar-unflag-backwards (p)
 865   "In tar-mode, un-mark this sub-file if it is marked to be deleted.
 866 With a prefix argument, un-mark that many files backward."
 867   (interactive "p")
 868   (tar-flag-deleted (- p) t))
 869
 870
 871 (defun tar-expunge-internal ()
 872   "Expunge the tar-entry specified by the current line."
 873   (let* ((descriptor (tar-current-descriptor))
 874          (tokens (tar-desc-tokens descriptor))
 875          (line (tar-desc-data-start descriptor))
 876          (name (tar-header-name tokens))
 877          (size (tar-header-size tokens))
 878          (link-p (tar-header-link-type tokens))
 879          (start (tar-desc-data-start descriptor))
 880          (following-descs (cdr (memq descriptor tar-parse-info))))
 881     (if link-p (setq size 0))           ; size lies for hard-links.
 882     ;;
 883     ;; delete the current line...
 884     (beginning-of-line)
 885     (let ((line-start (point)))
 886       (end-of-line) (forward-char)
 887       (let ((line-len (- (point) line-start)))
 888         (delete-region line-start (point))
 889         ;;
 890         ;; decrement the header-pointer to be in synch...
 891         (setq tar-header-offset (- tar-header-offset line-len))))
 892     ;;
 893     ;; delete the data pointer...
 894     (setq tar-parse-info (delq descriptor tar-parse-info))
 895     ;;
 896     ;; delete the data from inside the file...
 897     (widen)
 898     (let* ((data-start (+ start tar-header-offset -513))
 899            (data-end (+ data-start 512 (ash (ash (+ size 511) -9) 9))))
 900       (delete-region data-start data-end)
 901       ;;
 902       ;; and finally, decrement the start-pointers of all following
 903       ;; entries in the archive.  This is a pig when deleting a bunch
 904       ;; of files at once - we could optimize this to only do the
 905       ;; iteration over the files that remain, or only iterate up to
 906       ;; the next file to be deleted.
 907       (let ((data-length (- data-end data-start)))
 908         (dolist (desc following-descs)
 909           (setf (tar-desc-data-start desc)
 910                 (- (tar-desc-data-start desc) data-length))))
 911       ))
 912   (narrow-to-region 1 tar-header-offset))
 913
 914
 915 (defun tar-expunge (&optional noconfirm)
 916   "In tar-mode, delete all the archived files flagged for deletion.
 917 This does not modify the disk image; you must save the tar file itself
 918 for this to be permanent."
 919   (interactive)
 920   (if (or noconfirm
 921           (y-or-n-p "Expunge files marked for deletion? "))
 922       (let ((n 0))
 923         (save-excursion
 924           (goto-char 0)
 925           (while (not (eobp))
 926             (if (looking-at "D")
 927                 (progn (tar-expunge-internal)
 928                        (setq n (1+ n)))
 929               (forward-line 1)))
 930           ;; after doing the deletions, add any padding that may be necessary.
 931           (tar-pad-to-blocksize)
 932           (narrow-to-region 1 tar-header-offset)
 933           )
 934         (if (zerop n)
 935             (message "Nothing to expunge.")
 936             (message "%s files expunged.  Be sure to save this buffer." n)))))
 937
 938
 939 (defun tar-clear-modification-flags ()
 940   "Remove the stars at the beginning of each line."
 941   (interactive)
 942   (save-excursion
 943     (goto-char 0)
 944     (while (< (point) tar-header-offset)
 945       (if (looking-at "*")
 946           (progn (delete-char 1) (insert " ")))
 947       (forward-line 1))))
 948
 949
 950 (defun tar-chown-entry (new-uid)
 951   "Change the user-id associated with this entry in the tar file.
 952 If this tar file was written by GNU tar, then you will be able to edit
 953 the user id as a string; otherwise, you must edit it as a number.
 954 You can force editing as a number by calling this with a prefix arg.
 955 This does not modify the disk image; you must save the tar file itself
 956 for this to be permanent."
 957   (interactive (list
 958                 (let ((tokens (tar-desc-tokens (tar-current-descriptor))))
 959                   (if (or current-prefix-arg
 960                           (not (tar-header-magic tokens)))
 961                       (let (n)
 962                         (while (not (numberp (setq n (read-minibuffer
 963                                                       "New UID number: "
 964                                                       (format "%s" (tar-header-uid tokens)))))))
 965                         n)
 966                     (read-string "New UID string: " (tar-header-uname tokens))))))
 967   (cond ((stringp new-uid)
 968          (setf (tar-header-uname (tar-desc-tokens (tar-current-descriptor)))
 969                new-uid)
 970          (tar-alter-one-field tar-uname-offset (concat new-uid "\000")))
 971         (t
 972          (setf (tar-header-uid (tar-desc-tokens (tar-current-descriptor)))
 973                new-uid)
 974          (tar-alter-one-field
 975           tar-uid-offset
 976           (concat (substring (format "%6o" new-uid) 0 6) "\000 ")))))
 977
 978
 979 (defun tar-chgrp-entry (new-gid)
 980   "Change the group-id associated with this entry in the tar file.
 981 If this tar file was written by GNU tar, then you will be able to edit
 982 the group id as a string; otherwise, you must edit it as a number.
 983 You can force editing as a number by calling this with a prefix arg.
 984 This does not modify the disk image; you must save the tar file itself
 985 for this to be permanent."
 986   (interactive (list
 987                 (let ((tokens (tar-desc-tokens (tar-current-descriptor))))
 988                   (if (or current-prefix-arg
 989                           (not (tar-header-magic tokens)))
 990                       (let (n)
 991                         (while (not (numberp (setq n (read-minibuffer
 992                                                       "New GID number: "
 993                                                       (format "%s" (tar-header-gid tokens)))))))
 994                         n)
 995                     (read-string "New GID string: " (tar-header-gname tokens))))))
 996   (cond ((stringp new-gid)
 997          (setf (tar-header-gname (tar-desc-tokens (tar-current-descriptor)))
 998                new-gid)
 999          (tar-alter-one-field tar-gname-offset
1000                               (concat new-gid "\000")))
1001         (t
1002          (setf (tar-header-gid (tar-desc-tokens (tar-current-descriptor)))
1003                new-gid)
1004          (tar-alter-one-field
1005           tar-gid-offset
1006           (concat (substring (format "%6o" new-gid) 0 6) "\000 ")))))
1007
1008 (defun tar-rename-entry (new-name)
1009   "Change the name associated with this entry in the tar file.
1010 This does not modify the disk image; you must save the tar file itself
1011 for this to be permanent."
1012   (interactive
1013    (list (read-string "New name: "
1014                       (tar-header-name
1015                        (tar-desc-tokens (tar-current-descriptor))))))
1016   (if (string= "" new-name) (error "zero length name"))
1017   (if (> (length new-name) 98) (error "name too long"))
1018   (setf (tar-header-name (tar-desc-tokens (tar-current-descriptor)))
1019         new-name)
1020   (tar-alter-one-field 0
1021                        (substring (concat new-name (make-string 99 0)) 0 99)))
1022
1023
1024 (defun tar-chmod-entry (new-mode)
1025   "Change the protection bits associated with this entry in the tar file.
1026 This does not modify the disk image; you must save the tar file itself
1027 for this to be permanent."
1028   (interactive (list (tar-parse-octal-integer-safe
1029                       (read-string "New protection (octal): "))))
1030   (setf (tar-header-mode (tar-desc-tokens (tar-current-descriptor)))
1031         new-mode)
1032   (tar-alter-one-field
1033    tar-mode-offset
1034    (concat (substring (format "%6o" new-mode) 0 6) "\000 ")))
1035
1036
1037 (defun tar-alter-one-field (data-position new-data-string)
1038   (let* ((descriptor (tar-current-descriptor))
1039          (tokens (tar-desc-tokens descriptor)))
1040     (unwind-protect
1041         (save-excursion
1042           ;;
1043           ;; update the header-line.
1044           (beginning-of-line)
1045           (let ((p (point)))
1046             (forward-line 1)
1047             (delete-region p (point))
1048             (insert (tar-summarize-header-block tokens) "\n")
1049             (setq tar-header-offset (point-max)))
1050
1051           (widen)
1052           (let* ((start (+ (tar-desc-data-start descriptor) tar-header-offset -513)))
1053             ;;
1054             ;; delete the old field and insert a new one.
1055             (goto-char (+ start data-position))
1056             (delete-region (point) (+ (point) (length new-data-string))) ; <--
1057             (insert new-data-string)    ; <--
1058             ;;
1059             ;; compute a new checksum and insert it.
1060             (let ((chk (tar-header-block-checksum
1061                         (buffer-substring start (+ start 512)))))
1062               (goto-char (+ start tar-chk-offset))
1063               (delete-region (point) (+ (point) 8))
1064               (insert (format "%6o" chk))
1065               (insert 0)
1066               (insert ? )
1067               (setf (tar-header-checksum tokens) chk)
1068               ;;
1069               ;; ok, make sure we didn't botch it.
1070               (tar-header-block-check-checksum
1071                (buffer-substring start (+ start 512))
1072                chk (tar-header-name tokens)))))
1073       (narrow-to-region 1 tar-header-offset))))
1074
1075
1076 (defun tar-subfile-save-buffer ()
1077   "In tar subfile mode, save this buffer into its parent tar-file buffer.
1078 This doesn't write anything to disk; you must save the parent tar-file buffer
1079 to make your changes permanent."
1080   (interactive)
1081   (cond (buffer-file-name
1082          ;; tar-subfile buffers should have nil as buffer-file-name.  If they
1083          ;; ever gain a buffer-file-name, that means they have been written to
1084          ;; a real disk file, as with ^X^W.  If this happens, behave just like
1085          ;; `save-buffer.'
1086          (call-interactively 'save-buffer))
1087         (t
1088          (tar-subfile-save-buffer-internal))))
1089
1090 (defun tar-subfile-save-buffer-internal ()
1091   (if (not (and (boundp 'tar-superior-buffer) tar-superior-buffer))
1092       (error "This buffer has no superior tar file buffer."))
1093   (or (buffer-name tar-superior-buffer)
1094       (error "The superior tar file's buffer has been killed."))
1095   (if (not (and (boundp 'tar-superior-descriptor) tar-superior-descriptor))
1096       (error "This buffer doesn't have an index into its superior tar file!"))
1097
1098   ;; Notice when crypt.el has uncompressed while reading the subfile, and
1099   ;; signal an error if the user tries to save back into the parent file
1100   ;; (because it won't work - the .Z subfile it writes won't really be
1101   ;; compressed.)
1102   ;;
1103                                         ;  ;; These are for the old crypt.el
1104                                         ;  (if (and (boundp 'buffer-save-encrypted) buffer-save-encrypted)
1105                                         ;      (error "Don't know how to encrypt back into a tar file."))
1106                                         ;  (if (and (boundp 'buffer-save-compacted) buffer-save-compacted)
1107                                         ;      (error "Don't know how to compact back into a tar file."))
1108                                         ;  (if (and (boundp 'buffer-save-compressed) buffer-save-compressed)
1109                                         ;      (error "Don't know how to compress back into a tar file."))
1110                                         ;  (if (and (boundp 'buffer-save-gzipped) buffer-save-gzipped)
1111                                         ;      (error "Don't know how to gzip back into a tar file."))
1112
1113   ;; These are for the new crypt++.el
1114   (if (and (boundp 'crypt-buffer-save-encrypted) crypt-buffer-save-encrypted)
1115       (error "Don't know how to encrypt back into a tar file."))
1116   (if (and (boundp 'crypt-buffer-save-compact) crypt-buffer-save-compact)
1117       (error "Don't know how to compact back into a tar file."))
1118   (if (and (boundp 'crypt-buffer-save-compress) crypt-buffer-save-compress)
1119       (error "Don't know how to compress back into a tar file."))
1120   (if (and (boundp 'crypt-buffer-save-gzip) crypt-buffer-save-gzip)
1121       (error "Don't know how to gzip back into a tar file."))
1122   (if (and (boundp 'crypt-buffer-save-freeze) crypt-buffer-save-freeze)
1123       (error "Don't know how to freeze back into a tar file."))
1124
1125   (save-excursion
1126     (let ((subfile (current-buffer))
1127           (subfile-size (buffer-size))
1128           (descriptor tar-superior-descriptor))
1129       (set-buffer tar-superior-buffer)
1130       (let* ((tokens (tar-desc-tokens descriptor))
1131              (start (tar-desc-data-start descriptor))
1132              (name (tar-header-name tokens))
1133              (size (tar-header-size tokens))
1134              (size-pad (ash (ash (+ size 511) -9) 9))
1135              (head (memq descriptor tar-parse-info))
1136              (following-descs (cdr head)))
1137         (if (not head)
1138             (error "Can't find this tar file entry in its parent tar file!"))
1139         (unwind-protect
1140             (save-excursion
1141               (widen)
1142               ;; delete the old data...
1143               (let* ((data-start (+ start tar-header-offset -1))
1144                      (data-end (+ data-start (ash (ash (+ size 511) -9) 9))))
1145                 (delete-region data-start data-end)
1146                 ;; insert the new data...
1147                 (goto-char data-start)
1148                 (insert-buffer subfile)
1149                 ;;
1150                 ;; pad the new data out to a multiple of 512...
1151                 (let ((subfile-size-pad (ash (ash (+ subfile-size 511) -9) 9)))
1152                   (goto-char (+ data-start subfile-size))
1153                   (insert (make-string (- subfile-size-pad subfile-size) 0))
1154                   ;;
1155                   ;; update the data pointer of this and all following files...
1156                   (setf (tar-header-size tokens) subfile-size)
1157                   (let ((difference (- subfile-size-pad size-pad)))
1158                     (dolist (desc following-descs)
1159                       (setf (tar-desc-data-start desc)
1160                             (+ (tar-desc-data-start desc) difference))))
1161                   ;;
1162                   ;; Update the size field in the header block.
1163                   (let ((header-start (- data-start 512)))
1164                     (goto-char (+ header-start tar-size-offset))
1165                     (delete-region (point) (+ (point) 12))
1166                     (insert (format "%11o" subfile-size))
1167                     (insert ? )
1168                     ;;
1169                     ;; Maybe update the datestamp.
1170                     (if (not tar-update-datestamp)
1171                         nil
1172                       (goto-char (+ header-start tar-time-offset))
1173                       (delete-region (point) (+ (point) 12))
1174                       (let (now top bot)
1175                         (cond ((fboundp 'current-time)
1176                                (setq now (current-time))
1177                                (setcdr now (car (cdr now))))
1178                                         ;                       ((fboundp 'current-time-seconds)
1179                                         ;                        (setq now (current-time-seconds)))
1180                               )
1181                         (setq top (car now)
1182                               bot (cdr now))
1183                         (cond
1184                          (now
1185                           (setf (tar-header-date tokens) now)
1186                           ;; hair to print two 16-bit numbers as one octal number.
1187                           (setq bot (logior (ash (logand top 3) 16) bot))
1188                           (setq top (ash top -2))
1189                           (insert (format "%5o" top))
1190                           (insert (format "%06o " bot)))
1191                          (t
1192                           ;; otherwise, set it to the epoch.
1193                           (insert (format "%11o " 0))
1194                           (setf (tar-header-date tokens) (cons 0 0))
1195                           ))))
1196                     ;;
1197                     ;; compute a new checksum and insert it.
1198                     (let ((chk (tar-header-block-checksum
1199                                 (buffer-substring header-start data-start))))
1200                       (goto-char (+ header-start tar-chk-offset))
1201                       (delete-region (point) (+ (point) 8))
1202                       (insert (format "%6o" chk))
1203                       (insert 0)
1204                       (insert ? )
1205                       (setf (tar-header-checksum tokens) chk)))
1206                   ;;
1207                   ;; alter the descriptor-line...
1208                   ;;
1209                   (let ((position (- (length tar-parse-info) (length head))))
1210                     (goto-char 1)
1211                     (next-line position)
1212                     (beginning-of-line)
1213                     (let ((p (point))
1214                           (m (set-marker (make-marker) tar-header-offset)))
1215                       (forward-line 1)
1216                       (delete-region p (point))
1217                       (insert-before-markers (tar-summarize-header-block tokens t) "\n")
1218                       (setq tar-header-offset (marker-position m)))
1219                     )))
1220               ;; after doing the insertion, add any final padding that may be necessary.
1221               (tar-pad-to-blocksize))
1222           (narrow-to-region 1 tar-header-offset)))
1223       (set-buffer-modified-p t)         ; mark the tar file as modified
1224       (set-buffer subfile)
1225       (set-buffer-modified-p nil)       ; mark the tar subfile as unmodified
1226       (message "saved into tar-buffer \"%s\" - remember to save that buffer!"
1227                (buffer-name tar-superior-buffer))
1228       )))
1229
1230
1231 (defun tar-pad-to-blocksize ()
1232   "If we are being anal about tar file blocksizes, fix up the current buffer.
1233 Leaves the region wide."
1234   (if (null tar-anal-blocksize)
1235       nil
1236     (widen)
1237     (let* ((last-desc (nth (1- (length tar-parse-info)) tar-parse-info))
1238            (start (tar-desc-data-start last-desc))
1239            (tokens (tar-desc-tokens last-desc))
1240            (link-p (tar-header-link-type tokens))
1241            (size (if link-p 0 (tar-header-size tokens)))
1242            (data-end (+ start size))
1243            (bbytes (ash tar-anal-blocksize 9))
1244            (pad-to (+ bbytes (* bbytes (/ (1- data-end) bbytes))))
1245            (buffer-read-only nil)       ; ##
1246            )
1247       ;; If the padding after the last data is too long, delete some;
1248       ;; else insert some until we are padded out to the right number of blocks.
1249       ;;
1250       (goto-char (+ (or tar-header-offset 0) data-end))
1251       (if (> (1+ (buffer-size)) (+ (or tar-header-offset 0) pad-to))
1252           (delete-region (+ (or tar-header-offset 0) pad-to) (1+ (buffer-size)))
1253         (insert (make-string (- (+ (or tar-header-offset 0) pad-to)
1254                                 (1+ (buffer-size)))
1255                              0)))
1256       )))
1257
1258
1259 (defun tar-maybe-write-file ()
1260   "Used as a write-file-hook to write tar-files out correctly."
1261   ;;
1262   ;; If the current buffer is in tar-mode and has its header-offset set,
1263   ;; remove the header from the file, call the remaining write-file hooks,
1264   ;; and then write out the buffer (if and only if one of the write-file
1265   ;; hooks didn't write it already).  Then put the header back on the
1266   ;; buffer.  Many thanks to Piet van Oostrum for this code, which causes
1267   ;; correct interaction with crypt.el (and probably anything like it.)
1268   ;;
1269   ;; Kludge: in XEmacs Emacs, write-file-hooks is bound to nil before the
1270   ;; write-file-hooks are run, to prevent them from being run recursively
1271   ;; (this is more of a danger in v19-vintage emacses, which have both
1272   ;; write-file-hooks and write-contents-hooks.)  So, we need to reference
1273   ;; an internal variable of basic-save-buffer to get the list of hooks
1274   ;; remaining to be run.
1275   ;;
1276   (and (eq major-mode 'tar-mode)
1277        (and (boundp 'tar-header-offset) tar-header-offset)
1278        (let* ((hooks (cond ((string-match "XEmacs" emacs-version)
1279                             ;; Internal to basic-save-buffer in XEmacs.
1280                             (symbol-value 'hooks))
1281                            ((string-lessp "19" emacs-version)
1282                             ;; I think this is what we need to do in fsfmacs.
1283                             (append write-contents-hooks write-file-hooks))
1284                            (t
1285                             write-file-hooks)))
1286               (remaining-hooks (cdr (memq 'tar-maybe-write-file hooks)))
1287               header-string
1288               done)
1289          (save-excursion
1290            (save-restriction
1291              (widen)
1292              (tar-clear-modification-flags)
1293              (setq header-string (buffer-substring 1 tar-header-offset))
1294              (delete-region 1 tar-header-offset)
1295              (unwind-protect
1296                  (progn
1297                    (while (and remaining-hooks
1298                                (not (setq done (funcall (car remaining-hooks)))))
1299                      (setq remaining-hooks (cdr remaining-hooks)))
1300                    (cond ((not done)
1301                           (write-region 1 (1+ (buffer-size))
1302                                         buffer-file-name nil t)
1303                           (setq done t))))
1304                (goto-char 1)
1305                (insert header-string)
1306                (set-buffer-modified-p nil))))
1307          done)))
1308
1309 \f
1310 ;;; Patch it in.
1311
1312 ;;;###autoload
1313 (defvar tar-regexp "\\.tar$"
1314   "The regular expression used to identify tar file names.
1315 Note that this regular expression must not match compressed tar file
1316 names; if it does, tar-mode will attempt to parse the compressed tar
1317 file as an uncompressed tar file, which will generate an error.  This
1318 is not a problem, as other modules that handle compression will
1319 uncompress the buffer and call `tar-mode' appropriately.")
1320
1321 ;;;###autoload
1322 (setq auto-mode-alist
1323       (cons (cons tar-regexp 'tar-mode) auto-mode-alist))
1324
1325 ;; Note: the tar write-file-hook should go on the list *before* any other
1326 ;; hooks which might write the file.  Since things like crypt-mode add things
1327 ;; to the end of the write-file-hooks, this will normally be the case.
1328
1329                                         ;(or (boundp 'write-file-hooks) (setq write-file-hooks nil))
1330                                         ;(or (listp write-file-hooks)
1331                                         ;    (setq write-file-hooks (list write-file-hooks)))
1332                                         ;(or (memq 'tar-maybe-write-file write-file-hooks)
1333                                         ;    (setq write-file-hooks
1334                                         ;         (cons 'tar-maybe-write-file write-file-hooks)))
1335
1336 (add-hook 'write-file-hooks 'tar-maybe-write-file) ; ####write-contents-hooks??
1337 (cond ((boundp 'after-save-hook)
1338        (add-hook 'after-save-hook 'tar-subfile-after-write-file-hook))
1339       ((boundp 'after-write-file-hooks)
1340        (add-hook 'after-write-file-hooks 'tar-subfile-after-write-file-hook))
1341       (t (error "neither after-save-hook nor after-write-file-hooks?")))
1342
1343 \f
1344 ;;; This is a hack.  For files ending in .tar, we want -*- lines to be
1345 ;;; completely ignored - if there is one, it applies to the first file
1346 ;;; in the archive, and not the archive itself!  Similarly for local
1347 ;;; variables specifications in the last file of the archive.
1348
1349 (defun tar-normal-mode (&optional find-file)
1350   "Choose the major mode for this buffer automatically.
1351 Also sets up any specified local variables of the file.
1352 Uses the visited file name, the -*- line, and the local variables spec.
1353
1354 This function is called automatically from `find-file'.  In that case,
1355 if `inhibit-local-variables' is non-`nil' we require confirmation before
1356 processing a local variables spec.  If you run `normal-mode' explicitly,
1357 confirmation is never required.
1358
1359 Note that this version of this function has been hacked to interact
1360 correctly with tar files - when visiting a file which matches
1361 'tar-regexp', the -*- line and local-variables are not examined,
1362 as they would apply to a file within the archive rather than the archive
1363 itself."
1364   (interactive)
1365   (if (and buffer-file-name
1366            (string-match tar-regexp buffer-file-name))
1367       (tar-mode)
1368     (tar-real-normal-mode find-file)))
1369
1370 ;; We have to shadow this as well to get along with crypt.el.
1371 ;; Shadowing this alone isn't enough, though; we need to shadow
1372 ;; tar-normal-mode in order to inhibit the local variables of the
1373 ;; last file in the tar archive.
1374 ;;
1375 (defun tar-set-auto-mode ()
1376   "Select major mode appropriate for current buffer.
1377 May base decision on visited file name (See variable  auto-mode-list)
1378 or on buffer contents (-*- line or local variables spec), but does not look
1379 for the \"mode:\" local variable.  For that, use  hack-local-variables.
1380
1381 Note that this version of this function has been hacked to interact
1382 correctly with tar files - when visiting a file which matches
1383 'tar-regexp', the -*- line and local-variables are not examined,
1384 as they would apply to a file within the archive rather than the archive
1385 itself."
1386   (interactive)
1387   (if (and buffer-file-name
1388            (string-match tar-regexp buffer-file-name))
1389       (tar-mode)
1390     (tar-real-set-auto-mode)))
1391
1392 (if (not (fboundp 'tar-real-normal-mode))
1393     (fset 'tar-real-normal-mode (symbol-function 'normal-mode)))
1394 (fset 'normal-mode 'tar-normal-mode)
1395
1396 (if (not (fboundp 'tar-real-set-auto-mode))
1397     (fset 'tar-real-set-auto-mode (symbol-function 'set-auto-mode)))
1398 (fset 'set-auto-mode 'tar-set-auto-mode)
1399
1400 (defun tar-quit ()
1401   "Kill the current tar buffer."
1402   (interactive)
1403   (kill-buffer nil))
1404
1405 (provide 'tar-mode)
1406
1407 ;;; tar-mode.el ends here