| 1 | ;;; tar-mode.el --- simple editing of tar files from GNU emacs |
| 2 | |
| 3 | ;; Copyright (C) 1990,91,93,94,95,96,97,98,99,2000,01,2004 |
| 4 | ;; Free Software Foundation, Inc. |
| 5 | |
| 6 | ;; Author: Jamie Zawinski <jwz@lucid.com> |
| 7 | ;; Maintainer: FSF |
| 8 | ;; Created: 04 Apr 1990 |
| 9 | ;; Keywords: unix |
| 10 | |
| 11 | ;; This file is part of GNU Emacs. |
| 12 | |
| 13 | ;; GNU Emacs is free software; you can redistribute it and/or modify |
| 14 | ;; it under the terms of the GNU General Public License as published by |
| 15 | ;; the Free Software Foundation; either version 2, or (at your option) |
| 16 | ;; any later version. |
| 17 | |
| 18 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 19 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 21 | ;; GNU General Public License for more details. |
| 22 | |
| 23 | ;; You should have received a copy of the GNU General Public License |
| 24 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
| 25 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
| 26 | ;; Boston, MA 02111-1307, USA. |
| 27 | |
| 28 | ;;; Commentary: |
| 29 | |
| 30 | ;; This package attempts to make dealing with Unix 'tar' archives easier. |
| 31 | ;; When this code is loaded, visiting a file whose name ends in '.tar' will |
| 32 | ;; cause the contents of that archive file to be displayed in a Dired-like |
| 33 | ;; listing. It is then possible to use the customary Dired keybindings to |
| 34 | ;; extract sub-files from that archive, either by reading them into their own |
| 35 | ;; editor buffers, or by copying them directly to arbitrary files on disk. |
| 36 | ;; It is also possible to delete sub-files from within the tar file and write |
| 37 | ;; the modified archive back to disk, or to edit sub-files within the archive |
| 38 | ;; and re-insert the modified files into the archive. See the documentation |
| 39 | ;; string of tar-mode for more info. |
| 40 | |
| 41 | ;; This code now understands the extra fields that GNU tar adds to tar files. |
| 42 | |
| 43 | ;; This interacts correctly with "uncompress.el" in the Emacs library, |
| 44 | ;; which you get with |
| 45 | ;; |
| 46 | ;; (autoload 'uncompress-while-visiting "uncompress") |
| 47 | ;; (setq auto-mode-alist (cons '("\\.Z$" . uncompress-while-visiting) |
| 48 | ;; auto-mode-alist)) |
| 49 | ;; |
| 50 | ;; Do not attempt to use tar-mode.el with crypt.el, you will lose. |
| 51 | |
| 52 | ;; *************** TO DO *************** |
| 53 | ;; |
| 54 | ;; o chmod should understand "a+x,og-w". |
| 55 | ;; |
| 56 | ;; o It's not possible to add a NEW file to a tar archive; not that |
| 57 | ;; important, but still... |
| 58 | ;; |
| 59 | ;; o The code is less efficient that it could be - in a lot of places, I |
| 60 | ;; pull a 512-character string out of the buffer and parse it, when I could |
| 61 | ;; be parsing it in place, not garbaging a string. Should redo that. |
| 62 | ;; |
| 63 | ;; o I'd like a command that searches for a string/regexp in every subfile |
| 64 | ;; of an archive, where <esc> would leave you in a subfile-edit buffer. |
| 65 | ;; (Like the Meta-R command of the Zmacs mail reader.) |
| 66 | ;; |
| 67 | ;; o Sometimes (but not always) reverting the tar-file buffer does not |
| 68 | ;; re-grind the listing, and you are staring at the binary tar data. |
| 69 | ;; Typing 'g' again immediately after that will always revert and re-grind |
| 70 | ;; it, though. I have no idea why this happens. |
| 71 | ;; |
| 72 | ;; o Tar-mode interacts poorly with crypt.el and zcat.el because the tar |
| 73 | ;; write-file-hook actually writes the file. Instead it should remove the |
| 74 | ;; header (and conspire to put it back afterwards) so that other write-file |
| 75 | ;; hooks which frob the buffer have a chance to do their dirty work. There |
| 76 | ;; might be a problem if the tar write-file-hook does not come *first* on |
| 77 | ;; the list. |
| 78 | ;; |
| 79 | ;; o Block files, sparse files, continuation files, and the various header |
| 80 | ;; types aren't editable. Actually I don't know that they work at all. |
| 81 | |
| 82 | ;; Rationale: |
| 83 | |
| 84 | ;; Why does tar-mode edit the file itself instead of using tar? |
| 85 | |
| 86 | ;; That means that you can edit tar files which you don't have room for |
| 87 | ;; on your local disk. |
| 88 | |
| 89 | ;; I don't know about recent features in gnu tar, but old versions of tar |
| 90 | ;; can't replace a file in the middle of a tar file with a new version. |
| 91 | ;; Tar-mode can. I don't think tar can do things like chmod the subfiles. |
| 92 | ;; An implementation which involved unpacking and repacking the file into |
| 93 | ;; some scratch directory would be very wasteful, and wouldn't be able to |
| 94 | ;; preserve the file owners. |
| 95 | |
| 96 | ;;; Code: |
| 97 | |
| 98 | (defgroup tar nil |
| 99 | "Simple editing of tar files." |
| 100 | :prefix "tar-" |
| 101 | :group 'data) |
| 102 | |
| 103 | (defcustom tar-anal-blocksize 20 |
| 104 | "*The blocksize of tar files written by Emacs, or nil, meaning don't care. |
| 105 | The blocksize of a tar file is not really the size of the blocks; rather, it is |
| 106 | the number of blocks written with one system call. When tarring to a tape, |
| 107 | this is the size of the *tape* blocks, but when writing to a file, it doesn't |
| 108 | matter much. The only noticeable difference is that if a tar file does not |
| 109 | have a blocksize of 20, tar will tell you that; all this really controls is |
| 110 | how many null padding bytes go on the end of the tar file." |
| 111 | :type '(choice integer (const nil)) |
| 112 | :group 'tar) |
| 113 | |
| 114 | (defcustom tar-update-datestamp nil |
| 115 | "*Non-nil means Tar mode should play fast and loose with sub-file datestamps. |
| 116 | If this is true, then editing and saving a tar file entry back into its |
| 117 | tar file will update its datestamp. If false, the datestamp is unchanged. |
| 118 | You may or may not want this - it is good in that you can tell when a file |
| 119 | in a tar archive has been changed, but it is bad for the same reason that |
| 120 | editing a file in the tar archive at all is bad - the changed version of |
| 121 | the file never exists on disk." |
| 122 | :type 'boolean |
| 123 | :group 'tar) |
| 124 | |
| 125 | (defcustom tar-mode-show-date nil |
| 126 | "*Non-nil means Tar mode should show the date/time of each subfile. |
| 127 | This information is useful, but it takes screen space away from file names." |
| 128 | :type 'boolean |
| 129 | :group 'tar) |
| 130 | |
| 131 | (defvar tar-parse-info nil) |
| 132 | ;; Be sure that this variable holds byte position, not char position. |
| 133 | (defvar tar-header-offset nil) |
| 134 | (defvar tar-superior-buffer nil) |
| 135 | (defvar tar-superior-descriptor nil) |
| 136 | (defvar tar-subfile-mode nil) |
| 137 | |
| 138 | (put 'tar-parse-info 'permanent-local t) |
| 139 | (put 'tar-header-offset 'permanent-local t) |
| 140 | (put 'tar-superior-buffer 'permanent-local t) |
| 141 | (put 'tar-superior-descriptor 'permanent-local t) |
| 142 | \f |
| 143 | (defmacro tar-setf (form val) |
| 144 | "A mind-numbingly simple implementation of setf." |
| 145 | (let ((mform (macroexpand form (and (boundp 'byte-compile-macro-environment) |
| 146 | byte-compile-macro-environment)))) |
| 147 | (cond ((symbolp mform) (list 'setq mform val)) |
| 148 | ((not (consp mform)) (error "can't setf %s" form)) |
| 149 | ((eq (car mform) 'aref) |
| 150 | (list 'aset (nth 1 mform) (nth 2 mform) val)) |
| 151 | ((eq (car mform) 'car) |
| 152 | (list 'setcar (nth 1 mform) val)) |
| 153 | ((eq (car mform) 'cdr) |
| 154 | (list 'setcdr (nth 1 mform) val)) |
| 155 | (t (error "don't know how to setf %s" form))))) |
| 156 | \f |
| 157 | ;;; down to business. |
| 158 | |
| 159 | (defmacro make-tar-header (name mode uid git size date ck lt ln |
| 160 | magic uname gname devmaj devmin) |
| 161 | (list 'vector name mode uid git size date ck lt ln |
| 162 | magic uname gname devmaj devmin)) |
| 163 | |
| 164 | (defmacro tar-header-name (x) (list 'aref x 0)) |
| 165 | (defmacro tar-header-mode (x) (list 'aref x 1)) |
| 166 | (defmacro tar-header-uid (x) (list 'aref x 2)) |
| 167 | (defmacro tar-header-gid (x) (list 'aref x 3)) |
| 168 | (defmacro tar-header-size (x) (list 'aref x 4)) |
| 169 | (defmacro tar-header-date (x) (list 'aref x 5)) |
| 170 | (defmacro tar-header-checksum (x) (list 'aref x 6)) |
| 171 | (defmacro tar-header-link-type (x) (list 'aref x 7)) |
| 172 | (defmacro tar-header-link-name (x) (list 'aref x 8)) |
| 173 | (defmacro tar-header-magic (x) (list 'aref x 9)) |
| 174 | (defmacro tar-header-uname (x) (list 'aref x 10)) |
| 175 | (defmacro tar-header-gname (x) (list 'aref x 11)) |
| 176 | (defmacro tar-header-dmaj (x) (list 'aref x 12)) |
| 177 | (defmacro tar-header-dmin (x) (list 'aref x 13)) |
| 178 | |
| 179 | (defmacro make-tar-desc (data-start tokens) |
| 180 | (list 'cons data-start tokens)) |
| 181 | |
| 182 | (defmacro tar-desc-data-start (x) (list 'car x)) |
| 183 | (defmacro tar-desc-tokens (x) (list 'cdr x)) |
| 184 | |
| 185 | (defconst tar-name-offset 0) |
| 186 | (defconst tar-mode-offset (+ tar-name-offset 100)) |
| 187 | (defconst tar-uid-offset (+ tar-mode-offset 8)) |
| 188 | (defconst tar-gid-offset (+ tar-uid-offset 8)) |
| 189 | (defconst tar-size-offset (+ tar-gid-offset 8)) |
| 190 | (defconst tar-time-offset (+ tar-size-offset 12)) |
| 191 | (defconst tar-chk-offset (+ tar-time-offset 12)) |
| 192 | (defconst tar-linkp-offset (+ tar-chk-offset 8)) |
| 193 | (defconst tar-link-offset (+ tar-linkp-offset 1)) |
| 194 | ;;; GNU-tar specific slots. |
| 195 | (defconst tar-magic-offset (+ tar-link-offset 100)) |
| 196 | (defconst tar-uname-offset (+ tar-magic-offset 8)) |
| 197 | (defconst tar-gname-offset (+ tar-uname-offset 32)) |
| 198 | (defconst tar-dmaj-offset (+ tar-gname-offset 32)) |
| 199 | (defconst tar-dmin-offset (+ tar-dmaj-offset 8)) |
| 200 | (defconst tar-end-offset (+ tar-dmin-offset 8)) |
| 201 | |
| 202 | (defun tar-header-block-tokenize (string) |
| 203 | "Return a `tar-header' structure. |
| 204 | This is a list of name, mode, uid, gid, size, |
| 205 | write-date, checksum, link-type, and link-name." |
| 206 | (cond ((< (length string) 512) nil) |
| 207 | (;(some 'plusp string) ; <-- oops, massive cycle hog! |
| 208 | (or (not (= 0 (aref string 0))) ; This will do. |
| 209 | (not (= 0 (aref string 101)))) |
| 210 | (let* ((name-end (1- tar-mode-offset)) |
| 211 | (link-end (1- tar-magic-offset)) |
| 212 | (uname-end (1- tar-gname-offset)) |
| 213 | (gname-end (1- tar-dmaj-offset)) |
| 214 | (link-p (aref string tar-linkp-offset)) |
| 215 | (magic-str (substring string tar-magic-offset (1- tar-uname-offset))) |
| 216 | (uname-valid-p (or (string= "ustar " magic-str) (string= "GNUtar " magic-str))) |
| 217 | name linkname |
| 218 | (nulsexp "[^\000]*\000")) |
| 219 | (when (string-match nulsexp string tar-name-offset) |
| 220 | (setq name-end (min name-end (1- (match-end 0))))) |
| 221 | (when (string-match nulsexp string tar-link-offset) |
| 222 | (setq link-end (min link-end (1- (match-end 0))))) |
| 223 | (when (string-match nulsexp string tar-uname-offset) |
| 224 | (setq uname-end (min uname-end (1- (match-end 0))))) |
| 225 | (when (string-match nulsexp string tar-gname-offset) |
| 226 | (setq gname-end (min gname-end (1- (match-end 0))))) |
| 227 | (setq name (substring string tar-name-offset name-end) |
| 228 | link-p (if (or (= link-p 0) (= link-p ?0)) |
| 229 | nil |
| 230 | (- link-p ?0))) |
| 231 | (setq linkname (substring string tar-link-offset link-end)) |
| 232 | (if default-enable-multibyte-characters |
| 233 | (setq name |
| 234 | (decode-coding-string name (or file-name-coding-system |
| 235 | 'undecided)) |
| 236 | linkname |
| 237 | (decode-coding-string linkname (or file-name-coding-system |
| 238 | 'undecided)))) |
| 239 | (if (and (null link-p) (string-match "/$" name)) (setq link-p 5)) ; directory |
| 240 | (make-tar-header |
| 241 | name |
| 242 | (tar-parse-octal-integer string tar-mode-offset tar-uid-offset) |
| 243 | (tar-parse-octal-integer string tar-uid-offset tar-gid-offset) |
| 244 | (tar-parse-octal-integer string tar-gid-offset tar-size-offset) |
| 245 | (tar-parse-octal-integer string tar-size-offset tar-time-offset) |
| 246 | (tar-parse-octal-long-integer string tar-time-offset tar-chk-offset) |
| 247 | (tar-parse-octal-integer string tar-chk-offset tar-linkp-offset) |
| 248 | link-p |
| 249 | linkname |
| 250 | uname-valid-p |
| 251 | (and uname-valid-p (substring string tar-uname-offset uname-end)) |
| 252 | (and uname-valid-p (substring string tar-gname-offset gname-end)) |
| 253 | (tar-parse-octal-integer string tar-dmaj-offset tar-dmin-offset) |
| 254 | (tar-parse-octal-integer string tar-dmin-offset tar-end-offset) |
| 255 | ))) |
| 256 | (t 'empty-tar-block))) |
| 257 | |
| 258 | |
| 259 | (defun tar-parse-octal-integer (string &optional start end) |
| 260 | (if (null start) (setq start 0)) |
| 261 | (if (null end) (setq end (length string))) |
| 262 | (if (= (aref string start) 0) |
| 263 | 0 |
| 264 | (let ((n 0)) |
| 265 | (while (< start end) |
| 266 | (setq n (if (< (aref string start) ?0) n |
| 267 | (+ (* n 8) (- (aref string start) ?0))) |
| 268 | start (1+ start))) |
| 269 | n))) |
| 270 | |
| 271 | (defun tar-parse-octal-long-integer (string &optional start end) |
| 272 | (if (null start) (setq start 0)) |
| 273 | (if (null end) (setq end (length string))) |
| 274 | (if (= (aref string start) 0) |
| 275 | (list 0 0) |
| 276 | (let ((lo 0) |
| 277 | (hi 0)) |
| 278 | (while (< start end) |
| 279 | (if (>= (aref string start) ?0) |
| 280 | (setq lo (+ (* lo 8) (- (aref string start) ?0)) |
| 281 | hi (+ (* hi 8) (ash lo -16)) |
| 282 | lo (logand lo 65535))) |
| 283 | (setq start (1+ start))) |
| 284 | (list hi lo)))) |
| 285 | |
| 286 | (defun tar-parse-octal-integer-safe (string) |
| 287 | (let ((L (length string))) |
| 288 | (if (= L 0) (error "empty string")) |
| 289 | (dotimes (i L) |
| 290 | (if (or (< (aref string i) ?0) |
| 291 | (> (aref string i) ?7)) |
| 292 | (error "`%c' is not an octal digit" (aref string i))))) |
| 293 | (tar-parse-octal-integer string)) |
| 294 | |
| 295 | |
| 296 | (defun tar-header-block-checksum (string) |
| 297 | "Compute and return a tar-acceptable checksum for this block." |
| 298 | (let* ((chk-field-start tar-chk-offset) |
| 299 | (chk-field-end (+ chk-field-start 8)) |
| 300 | (sum 0) |
| 301 | (i 0)) |
| 302 | ;; Add up all of the characters except the ones in the checksum field. |
| 303 | ;; Add that field as if it were filled with spaces. |
| 304 | (while (< i chk-field-start) |
| 305 | (setq sum (+ sum (aref string i)) |
| 306 | i (1+ i))) |
| 307 | (setq i chk-field-end) |
| 308 | (while (< i 512) |
| 309 | (setq sum (+ sum (aref string i)) |
| 310 | i (1+ i))) |
| 311 | (+ sum (* 32 8)))) |
| 312 | |
| 313 | (defun tar-header-block-check-checksum (hblock desired-checksum file-name) |
| 314 | "Beep and print a warning if the checksum doesn't match." |
| 315 | (if (not (= desired-checksum (tar-header-block-checksum hblock))) |
| 316 | (progn (beep) (message "Invalid checksum for file %s!" file-name)))) |
| 317 | |
| 318 | (defun tar-clip-time-string (time) |
| 319 | (let ((str (current-time-string time))) |
| 320 | (concat " " (substring str 4 16) (substring str 19 24)))) |
| 321 | |
| 322 | (defun tar-grind-file-mode (mode) |
| 323 | "Construct a `-rw--r--r--' string indicating MODE. |
| 324 | MODE should be an integer which is a file mode value." |
| 325 | (string |
| 326 | (if (zerop (logand 256 mode)) ?- ?r) |
| 327 | (if (zerop (logand 128 mode)) ?- ?w) |
| 328 | (if (zerop (logand 1024 mode)) (if (zerop (logand 64 mode)) ?- ?x) ?s) |
| 329 | (if (zerop (logand 32 mode)) ?- ?r) |
| 330 | (if (zerop (logand 16 mode)) ?- ?w) |
| 331 | (if (zerop (logand 2048 mode)) (if (zerop (logand 8 mode)) ?- ?x) ?s) |
| 332 | (if (zerop (logand 4 mode)) ?- ?r) |
| 333 | (if (zerop (logand 2 mode)) ?- ?w) |
| 334 | (if (zerop (logand 1 mode)) ?- ?x))) |
| 335 | |
| 336 | (defun tar-header-block-summarize (tar-hblock &optional mod-p) |
| 337 | "Return a line similar to the output of `tar -vtf'." |
| 338 | (let ((name (tar-header-name tar-hblock)) |
| 339 | (mode (tar-header-mode tar-hblock)) |
| 340 | (uid (tar-header-uid tar-hblock)) |
| 341 | (gid (tar-header-gid tar-hblock)) |
| 342 | (uname (tar-header-uname tar-hblock)) |
| 343 | (gname (tar-header-gname tar-hblock)) |
| 344 | (size (tar-header-size tar-hblock)) |
| 345 | (time (tar-header-date tar-hblock)) |
| 346 | (ck (tar-header-checksum tar-hblock)) |
| 347 | (type (tar-header-link-type tar-hblock)) |
| 348 | (link-name (tar-header-link-name tar-hblock))) |
| 349 | (format "%c%c%s%8s/%-8s%7s%s %s%s" |
| 350 | (if mod-p ?* ? ) |
| 351 | (cond ((or (eq type nil) (eq type 0)) ?-) |
| 352 | ((eq type 1) ?h) ; link |
| 353 | ((eq type 2) ?l) ; symlink |
| 354 | ((eq type 3) ?c) ; char special |
| 355 | ((eq type 4) ?b) ; block special |
| 356 | ((eq type 5) ?d) ; directory |
| 357 | ((eq type 6) ?p) ; FIFO/pipe |
| 358 | ((eq type 20) ?*) ; directory listing |
| 359 | ((eq type 28) ?L) ; next has longname |
| 360 | ((eq type 29) ?M) ; multivolume continuation |
| 361 | ((eq type 35) ?S) ; sparse |
| 362 | ((eq type 38) ?V) ; volume header |
| 363 | (t ?\ ) |
| 364 | ) |
| 365 | (tar-grind-file-mode mode) |
| 366 | (if (= 0 (length uname)) uid uname) |
| 367 | (if (= 0 (length gname)) gid gname) |
| 368 | size |
| 369 | (if tar-mode-show-date (tar-clip-time-string time) "") |
| 370 | (propertize name |
| 371 | 'mouse-face 'highlight |
| 372 | 'help-echo "mouse-2: extract this file into a buffer") |
| 373 | (if (or (eq type 1) (eq type 2)) |
| 374 | (concat (if (= type 1) " ==> " " --> ") link-name) |
| 375 | "")))) |
| 376 | |
| 377 | (defun tar-untar-buffer () |
| 378 | "Extract all archive members in the tar-file into the current directory." |
| 379 | (interactive) |
| 380 | (let ((multibyte enable-multibyte-characters)) |
| 381 | (unwind-protect |
| 382 | (save-restriction |
| 383 | (widen) |
| 384 | (set-buffer-multibyte nil) |
| 385 | (dolist (descriptor tar-parse-info) |
| 386 | (let* ((tokens (tar-desc-tokens descriptor)) |
| 387 | (name (tar-header-name tokens)) |
| 388 | (dir (file-name-directory name)) |
| 389 | (start (+ (tar-desc-data-start descriptor) |
| 390 | (- tar-header-offset (point-min)))) |
| 391 | (end (+ start (tar-header-size tokens)))) |
| 392 | (unless (file-directory-p name) |
| 393 | (message "Extracting %s" name) |
| 394 | (if (and dir (not (file-exists-p dir))) |
| 395 | (make-directory dir t)) |
| 396 | (unless (file-directory-p name) |
| 397 | (write-region start end name)) |
| 398 | (set-file-modes name (tar-header-mode tokens)))))) |
| 399 | (set-buffer-multibyte multibyte)))) |
| 400 | |
| 401 | (defun tar-summarize-buffer () |
| 402 | "Parse the contents of the tar file in the current buffer. |
| 403 | Place a dired-like listing on the front; |
| 404 | then narrow to it, so that only that listing |
| 405 | is visible (and the real data of the buffer is hidden)." |
| 406 | (set-buffer-multibyte nil) |
| 407 | (message "Parsing tar file...") |
| 408 | (let* ((result '()) |
| 409 | (pos (point-min)) |
| 410 | (bs (max 1 (- (buffer-size) 1024))) ; always 2+ empty blocks at end. |
| 411 | (bs100 (max 1 (/ bs 100))) |
| 412 | tokens) |
| 413 | (while (and (<= (+ pos 512) (point-max)) |
| 414 | (not (eq 'empty-tar-block |
| 415 | (setq tokens |
| 416 | (tar-header-block-tokenize |
| 417 | (buffer-substring pos (+ pos 512))))))) |
| 418 | (setq pos (+ pos 512)) |
| 419 | (message "Parsing tar file...%d%%" |
| 420 | ;(/ (* pos 100) bs) ; this gets round-off lossage |
| 421 | (/ pos bs100) ; this doesn't |
| 422 | ) |
| 423 | (if (eq (tar-header-link-type tokens) 20) |
| 424 | ;; Foo. There's an extra empty block after these. |
| 425 | (setq pos (+ pos 512))) |
| 426 | (let ((size (tar-header-size tokens))) |
| 427 | (if (< size 0) |
| 428 | (error "%s has size %s - corrupted" |
| 429 | (tar-header-name tokens) size)) |
| 430 | ; |
| 431 | ; This is just too slow. Don't really need it anyway.... |
| 432 | ;(tar-header-block-check-checksum |
| 433 | ; hblock (tar-header-block-checksum hblock) |
| 434 | ; (tar-header-name tokens)) |
| 435 | |
| 436 | (setq result (cons (make-tar-desc pos tokens) result)) |
| 437 | |
| 438 | (and (null (tar-header-link-type tokens)) |
| 439 | (> size 0) |
| 440 | (setq pos |
| 441 | (+ pos 512 (ash (ash (1- size) -9) 9)) ; this works |
| 442 | ;(+ pos (+ size (- 512 (rem (1- size) 512)))) ; this doesn't |
| 443 | )))) |
| 444 | (make-local-variable 'tar-parse-info) |
| 445 | (setq tar-parse-info (nreverse result)) |
| 446 | ;; A tar file should end with a block or two of nulls, |
| 447 | ;; but let's not get a fatal error if it doesn't. |
| 448 | (if (eq tokens 'empty-tar-block) |
| 449 | (message "Parsing tar file...done") |
| 450 | (message "Warning: premature EOF parsing tar file"))) |
| 451 | (save-excursion |
| 452 | (goto-char (point-min)) |
| 453 | (let ((buffer-read-only nil) |
| 454 | (summaries nil)) |
| 455 | ;; Collect summary lines and insert them all at once since tar files |
| 456 | ;; can be pretty big. |
| 457 | (dolist (tar-desc (reverse tar-parse-info)) |
| 458 | (setq summaries |
| 459 | (cons (tar-header-block-summarize (tar-desc-tokens tar-desc)) |
| 460 | (cons "\n" |
| 461 | summaries)))) |
| 462 | (let ((total-summaries (apply 'concat summaries))) |
| 463 | (if (multibyte-string-p total-summaries) |
| 464 | (set-buffer-multibyte t)) |
| 465 | (insert total-summaries)) |
| 466 | (make-local-variable 'tar-header-offset) |
| 467 | (setq tar-header-offset (point)) |
| 468 | (narrow-to-region (point-min) tar-header-offset) |
| 469 | (if enable-multibyte-characters |
| 470 | (setq tar-header-offset (position-bytes tar-header-offset))) |
| 471 | (set-buffer-modified-p nil)))) |
| 472 | \f |
| 473 | (defvar tar-mode-map nil "*Local keymap for Tar mode listings.") |
| 474 | |
| 475 | (if tar-mode-map |
| 476 | nil |
| 477 | (setq tar-mode-map (make-keymap)) |
| 478 | (suppress-keymap tar-mode-map) |
| 479 | (define-key tar-mode-map " " 'tar-next-line) |
| 480 | (define-key tar-mode-map "C" 'tar-copy) |
| 481 | (define-key tar-mode-map "d" 'tar-flag-deleted) |
| 482 | (define-key tar-mode-map "\^D" 'tar-flag-deleted) |
| 483 | (define-key tar-mode-map "e" 'tar-extract) |
| 484 | (define-key tar-mode-map "f" 'tar-extract) |
| 485 | (define-key tar-mode-map "\C-m" 'tar-extract) |
| 486 | (define-key tar-mode-map [mouse-2] 'tar-mouse-extract) |
| 487 | (define-key tar-mode-map "g" 'revert-buffer) |
| 488 | (define-key tar-mode-map "h" 'describe-mode) |
| 489 | (define-key tar-mode-map "n" 'tar-next-line) |
| 490 | (define-key tar-mode-map "\^N" 'tar-next-line) |
| 491 | (define-key tar-mode-map [down] 'tar-next-line) |
| 492 | (define-key tar-mode-map "o" 'tar-extract-other-window) |
| 493 | (define-key tar-mode-map "p" 'tar-previous-line) |
| 494 | (define-key tar-mode-map "q" 'quit-window) |
| 495 | (define-key tar-mode-map "\^P" 'tar-previous-line) |
| 496 | (define-key tar-mode-map [up] 'tar-previous-line) |
| 497 | (define-key tar-mode-map "R" 'tar-rename-entry) |
| 498 | (define-key tar-mode-map "u" 'tar-unflag) |
| 499 | (define-key tar-mode-map "v" 'tar-view) |
| 500 | (define-key tar-mode-map "x" 'tar-expunge) |
| 501 | (define-key tar-mode-map "\177" 'tar-unflag-backwards) |
| 502 | (define-key tar-mode-map "E" 'tar-extract-other-window) |
| 503 | (define-key tar-mode-map "M" 'tar-chmod-entry) |
| 504 | (define-key tar-mode-map "G" 'tar-chgrp-entry) |
| 505 | (define-key tar-mode-map "O" 'tar-chown-entry) |
| 506 | ) |
| 507 | \f |
| 508 | ;; Make menu bar items. |
| 509 | |
| 510 | ;; Get rid of the Edit menu bar item to save space. |
| 511 | (define-key tar-mode-map [menu-bar edit] 'undefined) |
| 512 | |
| 513 | (define-key tar-mode-map [menu-bar immediate] |
| 514 | (cons "Immediate" (make-sparse-keymap "Immediate"))) |
| 515 | |
| 516 | (define-key tar-mode-map [menu-bar immediate view] |
| 517 | '("View This File" . tar-view)) |
| 518 | (define-key tar-mode-map [menu-bar immediate display] |
| 519 | '("Display in Other Window" . tar-display-other-window)) |
| 520 | (define-key tar-mode-map [menu-bar immediate find-file-other-window] |
| 521 | '("Find in Other Window" . tar-extract-other-window)) |
| 522 | (define-key tar-mode-map [menu-bar immediate find-file] |
| 523 | '("Find This File" . tar-extract)) |
| 524 | |
| 525 | (define-key tar-mode-map [menu-bar mark] |
| 526 | (cons "Mark" (make-sparse-keymap "Mark"))) |
| 527 | |
| 528 | (define-key tar-mode-map [menu-bar mark unmark-all] |
| 529 | '("Unmark All" . tar-clear-modification-flags)) |
| 530 | (define-key tar-mode-map [menu-bar mark deletion] |
| 531 | '("Flag" . tar-flag-deleted)) |
| 532 | (define-key tar-mode-map [menu-bar mark unmark] |
| 533 | '("Unflag" . tar-unflag)) |
| 534 | |
| 535 | (define-key tar-mode-map [menu-bar operate] |
| 536 | (cons "Operate" (make-sparse-keymap "Operate"))) |
| 537 | |
| 538 | (define-key tar-mode-map [menu-bar operate chown] |
| 539 | '("Change Owner..." . tar-chown-entry)) |
| 540 | (define-key tar-mode-map [menu-bar operate chgrp] |
| 541 | '("Change Group..." . tar-chgrp-entry)) |
| 542 | (define-key tar-mode-map [menu-bar operate chmod] |
| 543 | '("Change Mode..." . tar-chmod-entry)) |
| 544 | (define-key tar-mode-map [menu-bar operate rename] |
| 545 | '("Rename to..." . tar-rename-entry)) |
| 546 | (define-key tar-mode-map [menu-bar operate copy] |
| 547 | '("Copy to..." . tar-copy)) |
| 548 | (define-key tar-mode-map [menu-bar operate expunge] |
| 549 | '("Expunge Marked Files" . tar-expunge)) |
| 550 | \f |
| 551 | ;; tar mode is suitable only for specially formatted data. |
| 552 | (put 'tar-mode 'mode-class 'special) |
| 553 | (put 'tar-subfile-mode 'mode-class 'special) |
| 554 | |
| 555 | ;;;###autoload |
| 556 | (define-derived-mode tar-mode nil "Tar" |
| 557 | "Major mode for viewing a tar file as a dired-like listing of its contents. |
| 558 | You can move around using the usual cursor motion commands. |
| 559 | Letters no longer insert themselves. |
| 560 | Type `e' to pull a file out of the tar file and into its own buffer; |
| 561 | or click mouse-2 on the file's line in the Tar mode buffer. |
| 562 | Type `c' to copy an entry from the tar file into another file on disk. |
| 563 | |
| 564 | If you edit a sub-file of this archive (as with the `e' command) and |
| 565 | save it with Control-x Control-s, the contents of that buffer will be |
| 566 | saved back into the tar-file buffer; in this way you can edit a file |
| 567 | inside of a tar archive without extracting it and re-archiving it. |
| 568 | |
| 569 | See also: variables `tar-update-datestamp' and `tar-anal-blocksize'. |
| 570 | \\{tar-mode-map}" |
| 571 | ;; this is not interactive because you shouldn't be turning this |
| 572 | ;; mode on and off. You can corrupt things that way. |
| 573 | ;; rms: with permanent locals, it should now be possible to make this work |
| 574 | ;; interactively in some reasonable fashion. |
| 575 | (make-local-variable 'tar-header-offset) |
| 576 | (make-local-variable 'tar-parse-info) |
| 577 | (set (make-local-variable 'require-final-newline) nil) ; binary data, dude... |
| 578 | (set (make-local-variable 'revert-buffer-function) 'tar-mode-revert) |
| 579 | (set (make-local-variable 'local-enable-local-variables) nil) |
| 580 | (set (make-local-variable 'next-line-add-newlines) nil) |
| 581 | ;; Prevent loss of data when saving the file. |
| 582 | (set (make-local-variable 'file-precious-flag) t) |
| 583 | (auto-save-mode 0) |
| 584 | (set (make-local-variable 'write-contents-hooks) '(tar-mode-write-file)) |
| 585 | (widen) |
| 586 | (if (and (boundp 'tar-header-offset) tar-header-offset) |
| 587 | (narrow-to-region (point-min) (byte-to-position tar-header-offset)) |
| 588 | (tar-summarize-buffer) |
| 589 | (tar-next-line 0))) |
| 590 | |
| 591 | |
| 592 | (defun tar-subfile-mode (p) |
| 593 | "Minor mode for editing an element of a tar-file. |
| 594 | This mode arranges for \"saving\" this buffer to write the data |
| 595 | into the tar-file buffer that it came from. The changes will actually |
| 596 | appear on disk when you save the tar-file's buffer." |
| 597 | (interactive "P") |
| 598 | (or (and (boundp 'tar-superior-buffer) tar-superior-buffer) |
| 599 | (error "This buffer is not an element of a tar file")) |
| 600 | ;; Don't do this, because it is redundant and wastes mode line space. |
| 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 | (add-hook 'write-file-functions 'tar-subfile-save-buffer nil t) |
| 611 | ;; turn off auto-save. |
| 612 | (auto-save-mode -1) |
| 613 | (setq buffer-auto-save-file-name nil) |
| 614 | (run-hooks 'tar-subfile-mode-hook)) |
| 615 | (t |
| 616 | (remove-hook 'write-file-functions 'tar-subfile-save-buffer t)))) |
| 617 | |
| 618 | |
| 619 | ;; Revert the buffer and recompute the dired-like listing. |
| 620 | (defun tar-mode-revert (&optional no-auto-save no-confirm) |
| 621 | (let ((revert-buffer-function nil) |
| 622 | (old-offset tar-header-offset) |
| 623 | success) |
| 624 | (setq tar-header-offset nil) |
| 625 | (unwind-protect |
| 626 | (and (revert-buffer t no-confirm) |
| 627 | (progn (widen) |
| 628 | (setq success t) |
| 629 | (tar-mode))) |
| 630 | ;; If the revert was canceled, |
| 631 | ;; put back the old value of tar-header-offset. |
| 632 | (or success |
| 633 | (setq tar-header-offset old-offset))))) |
| 634 | |
| 635 | |
| 636 | (defun tar-next-line (arg) |
| 637 | "Move cursor vertically down ARG lines and to the start of the filename." |
| 638 | (interactive "p") |
| 639 | (forward-line arg) |
| 640 | (if (eobp) nil (forward-char (if tar-mode-show-date 54 36)))) |
| 641 | |
| 642 | (defun tar-previous-line (arg) |
| 643 | "Move cursor vertically up ARG lines and to the start of the filename." |
| 644 | (interactive "p") |
| 645 | (tar-next-line (- arg))) |
| 646 | |
| 647 | (defun tar-current-descriptor (&optional noerror) |
| 648 | "Return the tar-descriptor of the current line, or signals an error." |
| 649 | ;; I wish lines had plists, like in ZMACS... |
| 650 | (or (nth (count-lines (point-min) |
| 651 | (save-excursion (beginning-of-line) (point))) |
| 652 | tar-parse-info) |
| 653 | (if noerror |
| 654 | nil |
| 655 | (error "This line does not describe a tar-file entry")))) |
| 656 | |
| 657 | (defun tar-get-descriptor () |
| 658 | (let* ((descriptor (tar-current-descriptor)) |
| 659 | (tokens (tar-desc-tokens descriptor)) |
| 660 | (size (tar-header-size tokens)) |
| 661 | (link-p (tar-header-link-type tokens))) |
| 662 | (if link-p |
| 663 | (error "This is a %s, not a real file" |
| 664 | (cond ((eq link-p 5) "directory") |
| 665 | ((eq link-p 20) "tar directory header") |
| 666 | ((eq link-p 28) "next has longname") |
| 667 | ((eq link-p 29) "multivolume-continuation") |
| 668 | ((eq link-p 35) "sparse entry") |
| 669 | ((eq link-p 38) "volume header") |
| 670 | (t "link")))) |
| 671 | (if (zerop size) (error "This is a zero-length file")) |
| 672 | descriptor)) |
| 673 | |
| 674 | (defun tar-mouse-extract (event) |
| 675 | "Extract a file whose tar directory line you click on." |
| 676 | (interactive "e") |
| 677 | (save-excursion |
| 678 | (set-buffer (window-buffer (posn-window (event-end event)))) |
| 679 | (save-excursion |
| 680 | (goto-char (posn-point (event-end event))) |
| 681 | ;; Just make sure this doesn't get an error. |
| 682 | (tar-get-descriptor))) |
| 683 | (select-window (posn-window (event-end event))) |
| 684 | (goto-char (posn-point (event-end event))) |
| 685 | (tar-extract)) |
| 686 | |
| 687 | (defun tar-extract (&optional other-window-p) |
| 688 | "In Tar mode, extract this entry of the tar file into its own buffer." |
| 689 | (interactive) |
| 690 | (let* ((view-p (eq other-window-p 'view)) |
| 691 | (descriptor (tar-get-descriptor)) |
| 692 | (tokens (tar-desc-tokens descriptor)) |
| 693 | (name (tar-header-name tokens)) |
| 694 | (size (tar-header-size tokens)) |
| 695 | (start (+ (tar-desc-data-start descriptor) |
| 696 | (- tar-header-offset (point-min)))) |
| 697 | (end (+ start size))) |
| 698 | (let* ((tar-buffer (current-buffer)) |
| 699 | (tar-buffer-multibyte enable-multibyte-characters) |
| 700 | (tarname (buffer-name)) |
| 701 | (bufname (concat (file-name-nondirectory name) |
| 702 | " (" |
| 703 | tarname |
| 704 | ")")) |
| 705 | (read-only-p (or buffer-read-only view-p)) |
| 706 | (new-buffer-file-name (expand-file-name |
| 707 | ;; `:' is not allowed on Windows |
| 708 | (concat tarname "!" name))) |
| 709 | (buffer (get-file-buffer new-buffer-file-name)) |
| 710 | (just-created nil)) |
| 711 | (unless buffer |
| 712 | (setq buffer (generate-new-buffer bufname)) |
| 713 | (setq bufname (buffer-name buffer)) |
| 714 | (setq just-created t) |
| 715 | (unwind-protect |
| 716 | (progn |
| 717 | (widen) |
| 718 | (set-buffer-multibyte nil) |
| 719 | (save-excursion |
| 720 | (set-buffer buffer) |
| 721 | (if enable-multibyte-characters |
| 722 | (progn |
| 723 | ;; We must avoid unibyte->multibyte conversion. |
| 724 | (set-buffer-multibyte nil) |
| 725 | (insert-buffer-substring tar-buffer start end) |
| 726 | (set-buffer-multibyte t)) |
| 727 | (insert-buffer-substring tar-buffer start end)) |
| 728 | (goto-char (point-min)) |
| 729 | (setq buffer-file-name new-buffer-file-name) |
| 730 | (setq buffer-file-truename |
| 731 | (abbreviate-file-name buffer-file-name)) |
| 732 | ;; We need to mimic the parts of insert-file-contents |
| 733 | ;; which determine the coding-system and decode the text. |
| 734 | (let ((coding |
| 735 | (or coding-system-for-read |
| 736 | (and set-auto-coding-function |
| 737 | (save-excursion |
| 738 | (funcall set-auto-coding-function |
| 739 | name (- (point-max) (point))))))) |
| 740 | (multibyte enable-multibyte-characters) |
| 741 | (detected (detect-coding-region |
| 742 | (point-min) |
| 743 | (min (+ (point-min) 16384) (point-max)) t))) |
| 744 | (if coding |
| 745 | (or (numberp (coding-system-eol-type coding)) |
| 746 | (vectorp (coding-system-eol-type detected)) |
| 747 | (setq coding (coding-system-change-eol-conversion |
| 748 | coding |
| 749 | (coding-system-eol-type detected)))) |
| 750 | (setq coding |
| 751 | (or (find-new-buffer-file-coding-system detected) |
| 752 | (let ((file-coding |
| 753 | (find-operation-coding-system |
| 754 | 'insert-file-contents buffer-file-name))) |
| 755 | (if (consp file-coding) |
| 756 | (setq file-coding (car file-coding)) |
| 757 | file-coding))))) |
| 758 | (if (or (eq coding 'no-conversion) |
| 759 | (eq (coding-system-type coding) 5)) |
| 760 | (setq multibyte (set-buffer-multibyte nil))) |
| 761 | (or multibyte |
| 762 | (setq coding |
| 763 | (coding-system-change-text-conversion |
| 764 | coding 'raw-text))) |
| 765 | (decode-coding-region (point-min) (point-max) coding) |
| 766 | (set-buffer-file-coding-system coding)) |
| 767 | ;; Set the default-directory to the dir of the |
| 768 | ;; superior buffer. |
| 769 | (setq default-directory |
| 770 | (save-excursion |
| 771 | (set-buffer tar-buffer) |
| 772 | default-directory)) |
| 773 | (normal-mode) ; pick a mode. |
| 774 | (rename-buffer bufname) |
| 775 | (make-local-variable 'tar-superior-buffer) |
| 776 | (make-local-variable 'tar-superior-descriptor) |
| 777 | (setq tar-superior-buffer tar-buffer) |
| 778 | (setq tar-superior-descriptor descriptor) |
| 779 | (setq buffer-read-only read-only-p) |
| 780 | (set-buffer-modified-p nil) |
| 781 | (tar-subfile-mode 1)) |
| 782 | (set-buffer tar-buffer)) |
| 783 | (narrow-to-region (point-min) tar-header-offset) |
| 784 | (set-buffer-multibyte tar-buffer-multibyte))) |
| 785 | (if view-p |
| 786 | (view-buffer buffer (and just-created 'kill-buffer)) |
| 787 | (if (eq other-window-p 'display) |
| 788 | (display-buffer buffer) |
| 789 | (if other-window-p |
| 790 | (switch-to-buffer-other-window buffer) |
| 791 | (switch-to-buffer buffer))))))) |
| 792 | |
| 793 | |
| 794 | (defun tar-extract-other-window () |
| 795 | "*In Tar mode, find this entry of the tar file in another window." |
| 796 | (interactive) |
| 797 | (tar-extract t)) |
| 798 | |
| 799 | (defun tar-display-other-window () |
| 800 | "*In Tar mode, display this entry of the tar file in another window." |
| 801 | (interactive) |
| 802 | (tar-extract 'display)) |
| 803 | |
| 804 | (defun tar-view () |
| 805 | "*In Tar mode, view the tar file entry on this line." |
| 806 | (interactive) |
| 807 | (tar-extract 'view)) |
| 808 | |
| 809 | |
| 810 | (defun tar-read-file-name (&optional prompt) |
| 811 | "Read a file name with this line's entry as the default." |
| 812 | (or prompt (setq prompt "Copy to: ")) |
| 813 | (let* ((default-file (expand-file-name |
| 814 | (tar-header-name (tar-desc-tokens |
| 815 | (tar-current-descriptor))))) |
| 816 | (target (expand-file-name |
| 817 | (read-file-name prompt |
| 818 | (file-name-directory default-file) |
| 819 | default-file nil)))) |
| 820 | (if (or (string= "" (file-name-nondirectory target)) |
| 821 | (file-directory-p target)) |
| 822 | (setq target (concat (if (string-match "/$" target) |
| 823 | (substring target 0 (1- (match-end 0))) |
| 824 | target) |
| 825 | "/" |
| 826 | (file-name-nondirectory default-file)))) |
| 827 | target)) |
| 828 | |
| 829 | |
| 830 | (defun tar-copy (&optional to-file) |
| 831 | "*In Tar mode, extract this entry of the tar file into a file on disk. |
| 832 | If TO-FILE is not supplied, it is prompted for, defaulting to the name of |
| 833 | the current tar-entry." |
| 834 | (interactive (list (tar-read-file-name))) |
| 835 | (let* ((descriptor (tar-get-descriptor)) |
| 836 | (tokens (tar-desc-tokens descriptor)) |
| 837 | (name (tar-header-name tokens)) |
| 838 | (size (tar-header-size tokens)) |
| 839 | (start (+ (tar-desc-data-start descriptor) |
| 840 | (- tar-header-offset (point-min)))) |
| 841 | (end (+ start size)) |
| 842 | (multibyte enable-multibyte-characters) |
| 843 | (inhibit-file-name-handlers inhibit-file-name-handlers) |
| 844 | (inhibit-file-name-operation inhibit-file-name-operation)) |
| 845 | (save-restriction |
| 846 | (widen) |
| 847 | ;; Inhibit compressing a subfile again if *both* name and |
| 848 | ;; to-file are handled by jka-compr |
| 849 | (if (and (eq (find-file-name-handler name 'write-region) 'jka-compr-handler) |
| 850 | (eq (find-file-name-handler to-file 'write-region) 'jka-compr-handler)) |
| 851 | (setq inhibit-file-name-handlers |
| 852 | (cons 'jka-compr-handler |
| 853 | (and (eq inhibit-file-name-operation 'write-region) |
| 854 | inhibit-file-name-handlers)) |
| 855 | inhibit-file-name-operation 'write-region)) |
| 856 | (unwind-protect |
| 857 | (let ((coding-system-for-write 'no-conversion)) |
| 858 | (set-buffer-multibyte nil) |
| 859 | (write-region start end to-file nil nil nil t)) |
| 860 | (set-buffer-multibyte multibyte))) |
| 861 | (message "Copied tar entry %s to %s" name to-file))) |
| 862 | |
| 863 | (defun tar-flag-deleted (p &optional unflag) |
| 864 | "*In Tar mode, mark this sub-file to be deleted from the tar file. |
| 865 | With a prefix argument, mark that many files." |
| 866 | (interactive "p") |
| 867 | (beginning-of-line) |
| 868 | (dotimes (i (if (< p 0) (- p) p)) |
| 869 | (if (tar-current-descriptor unflag) ; barf if we're not on an entry-line. |
| 870 | (progn |
| 871 | (delete-char 1) |
| 872 | (insert (if unflag " " "D")))) |
| 873 | (forward-line (if (< p 0) -1 1))) |
| 874 | (if (eobp) nil (forward-char 36))) |
| 875 | |
| 876 | (defun tar-unflag (p) |
| 877 | "*In Tar mode, un-mark this sub-file if it is marked to be deleted. |
| 878 | With a prefix argument, un-mark that many files forward." |
| 879 | (interactive "p") |
| 880 | (tar-flag-deleted p t)) |
| 881 | |
| 882 | (defun tar-unflag-backwards (p) |
| 883 | "*In Tar mode, un-mark this sub-file if it is marked to be deleted. |
| 884 | With a prefix argument, un-mark that many files backward." |
| 885 | (interactive "p") |
| 886 | (tar-flag-deleted (- p) t)) |
| 887 | |
| 888 | |
| 889 | ;; When this function is called, it is sure that the buffer is unibyte. |
| 890 | (defun tar-expunge-internal () |
| 891 | "Expunge the tar-entry specified by the current line." |
| 892 | (let* ((descriptor (tar-current-descriptor)) |
| 893 | (tokens (tar-desc-tokens descriptor)) |
| 894 | (line (tar-desc-data-start descriptor)) |
| 895 | (name (tar-header-name tokens)) |
| 896 | (size (tar-header-size tokens)) |
| 897 | (link-p (tar-header-link-type tokens)) |
| 898 | (start (tar-desc-data-start descriptor)) |
| 899 | (following-descs (cdr (memq descriptor tar-parse-info)))) |
| 900 | (if link-p (setq size 0)) ; size lies for hard-links. |
| 901 | ;; |
| 902 | ;; delete the current line... |
| 903 | (beginning-of-line) |
| 904 | (let ((line-start (point))) |
| 905 | (end-of-line) (forward-char) |
| 906 | (let ((line-len (- (point) line-start))) |
| 907 | (delete-region line-start (point)) |
| 908 | ;; |
| 909 | ;; decrement the header-pointer to be in sync... |
| 910 | (setq tar-header-offset (- tar-header-offset line-len)))) |
| 911 | ;; |
| 912 | ;; delete the data pointer... |
| 913 | (setq tar-parse-info (delq descriptor tar-parse-info)) |
| 914 | ;; |
| 915 | ;; delete the data from inside the file... |
| 916 | (widen) |
| 917 | (let* ((data-start (+ start tar-header-offset -513)) |
| 918 | (data-end (+ data-start 512 (ash (ash (+ size 511) -9) 9)))) |
| 919 | (delete-region data-start data-end) |
| 920 | ;; |
| 921 | ;; and finally, decrement the start-pointers of all following |
| 922 | ;; entries in the archive. This is a pig when deleting a bunch |
| 923 | ;; of files at once - we could optimize this to only do the |
| 924 | ;; iteration over the files that remain, or only iterate up to |
| 925 | ;; the next file to be deleted. |
| 926 | (let ((data-length (- data-end data-start))) |
| 927 | (dolist (desc following-descs) |
| 928 | (tar-setf (tar-desc-data-start desc) |
| 929 | (- (tar-desc-data-start desc) data-length)))) |
| 930 | )) |
| 931 | (narrow-to-region (point-min) tar-header-offset)) |
| 932 | |
| 933 | |
| 934 | (defun tar-expunge (&optional noconfirm) |
| 935 | "*In Tar mode, delete all the archived files flagged for deletion. |
| 936 | This does not modify the disk image; you must save the tar file itself |
| 937 | for this to be permanent." |
| 938 | (interactive) |
| 939 | (if (or noconfirm |
| 940 | (y-or-n-p "Expunge files marked for deletion? ")) |
| 941 | (let ((n 0) |
| 942 | (multibyte enable-multibyte-characters)) |
| 943 | (set-buffer-multibyte nil) |
| 944 | (save-excursion |
| 945 | (goto-char (point-min)) |
| 946 | (while (not (eobp)) |
| 947 | (if (looking-at "D") |
| 948 | (progn (tar-expunge-internal) |
| 949 | (setq n (1+ n))) |
| 950 | (forward-line 1))) |
| 951 | ;; after doing the deletions, add any padding that may be necessary. |
| 952 | (tar-pad-to-blocksize) |
| 953 | (narrow-to-region (point-min) tar-header-offset)) |
| 954 | (set-buffer-multibyte multibyte) |
| 955 | (if (zerop n) |
| 956 | (message "Nothing to expunge.") |
| 957 | (message "%s files expunged. Be sure to save this buffer." n))))) |
| 958 | |
| 959 | |
| 960 | (defun tar-clear-modification-flags () |
| 961 | "Remove the stars at the beginning of each line." |
| 962 | (interactive) |
| 963 | (save-excursion |
| 964 | (goto-char (point-min)) |
| 965 | (while (< (position-bytes (point)) tar-header-offset) |
| 966 | (if (not (eq (following-char) ?\ )) |
| 967 | (progn (delete-char 1) (insert " "))) |
| 968 | (forward-line 1)))) |
| 969 | |
| 970 | |
| 971 | (defun tar-chown-entry (new-uid) |
| 972 | "*Change the user-id associated with this entry in the tar file. |
| 973 | If this tar file was written by GNU tar, then you will be able to edit |
| 974 | the user id as a string; otherwise, you must edit it as a number. |
| 975 | You can force editing as a number by calling this with a prefix arg. |
| 976 | This does not modify the disk image; you must save the tar file itself |
| 977 | for this to be permanent." |
| 978 | (interactive (list |
| 979 | (let ((tokens (tar-desc-tokens (tar-current-descriptor)))) |
| 980 | (if (or current-prefix-arg |
| 981 | (not (tar-header-magic tokens))) |
| 982 | (let (n) |
| 983 | (while (not (numberp (setq n (read-minibuffer |
| 984 | "New UID number: " |
| 985 | (format "%s" (tar-header-uid tokens))))))) |
| 986 | n) |
| 987 | (read-string "New UID string: " (tar-header-uname tokens)))))) |
| 988 | (cond ((stringp new-uid) |
| 989 | (tar-setf (tar-header-uname (tar-desc-tokens (tar-current-descriptor))) |
| 990 | new-uid) |
| 991 | (tar-alter-one-field tar-uname-offset (concat new-uid "\000"))) |
| 992 | (t |
| 993 | (tar-setf (tar-header-uid (tar-desc-tokens (tar-current-descriptor))) |
| 994 | new-uid) |
| 995 | (tar-alter-one-field tar-uid-offset |
| 996 | (concat (substring (format "%6o" new-uid) 0 6) "\000 "))))) |
| 997 | |
| 998 | |
| 999 | (defun tar-chgrp-entry (new-gid) |
| 1000 | "*Change the group-id associated with this entry in the tar file. |
| 1001 | If this tar file was written by GNU tar, then you will be able to edit |
| 1002 | the group id as a string; otherwise, you must edit it as a number. |
| 1003 | You can force editing as a number by calling this with a prefix arg. |
| 1004 | This does not modify the disk image; you must save the tar file itself |
| 1005 | for this to be permanent." |
| 1006 | (interactive (list |
| 1007 | (let ((tokens (tar-desc-tokens (tar-current-descriptor)))) |
| 1008 | (if (or current-prefix-arg |
| 1009 | (not (tar-header-magic tokens))) |
| 1010 | (let (n) |
| 1011 | (while (not (numberp (setq n (read-minibuffer |
| 1012 | "New GID number: " |
| 1013 | (format "%s" (tar-header-gid tokens))))))) |
| 1014 | n) |
| 1015 | (read-string "New GID string: " (tar-header-gname tokens)))))) |
| 1016 | (cond ((stringp new-gid) |
| 1017 | (tar-setf (tar-header-gname (tar-desc-tokens (tar-current-descriptor))) |
| 1018 | new-gid) |
| 1019 | (tar-alter-one-field tar-gname-offset |
| 1020 | (concat new-gid "\000"))) |
| 1021 | (t |
| 1022 | (tar-setf (tar-header-gid (tar-desc-tokens (tar-current-descriptor))) |
| 1023 | new-gid) |
| 1024 | (tar-alter-one-field tar-gid-offset |
| 1025 | (concat (substring (format "%6o" new-gid) 0 6) "\000 "))))) |
| 1026 | |
| 1027 | (defun tar-rename-entry (new-name) |
| 1028 | "*Change the name associated with this entry in the tar file. |
| 1029 | This does not modify the disk image; you must save the tar file itself |
| 1030 | for this to be permanent." |
| 1031 | (interactive |
| 1032 | (list (read-string "New name: " |
| 1033 | (tar-header-name (tar-desc-tokens (tar-current-descriptor)))))) |
| 1034 | (if (string= "" new-name) (error "zero length name")) |
| 1035 | (if (> (length new-name) 98) (error "name too long")) |
| 1036 | (tar-setf (tar-header-name (tar-desc-tokens (tar-current-descriptor))) |
| 1037 | new-name) |
| 1038 | (tar-alter-one-field 0 |
| 1039 | (substring (concat new-name (make-string 99 0)) 0 99))) |
| 1040 | |
| 1041 | |
| 1042 | (defun tar-chmod-entry (new-mode) |
| 1043 | "*Change the protection bits associated with this entry in the tar file. |
| 1044 | This does not modify the disk image; you must save the tar file itself |
| 1045 | for this to be permanent." |
| 1046 | (interactive (list (tar-parse-octal-integer-safe |
| 1047 | (read-string "New protection (octal): ")))) |
| 1048 | (tar-setf (tar-header-mode (tar-desc-tokens (tar-current-descriptor))) |
| 1049 | new-mode) |
| 1050 | (tar-alter-one-field tar-mode-offset |
| 1051 | (concat (substring (format "%6o" new-mode) 0 6) "\000 "))) |
| 1052 | |
| 1053 | |
| 1054 | (defun tar-alter-one-field (data-position new-data-string) |
| 1055 | (let* ((descriptor (tar-current-descriptor)) |
| 1056 | (tokens (tar-desc-tokens descriptor)) |
| 1057 | (multibyte enable-multibyte-characters)) |
| 1058 | (unwind-protect |
| 1059 | (save-excursion |
| 1060 | ;; |
| 1061 | ;; update the header-line. |
| 1062 | (beginning-of-line) |
| 1063 | (let ((p (point))) |
| 1064 | (forward-line 1) |
| 1065 | (delete-region p (point)) |
| 1066 | (insert (tar-header-block-summarize tokens) "\n") |
| 1067 | (setq tar-header-offset (position-bytes (point-max)))) |
| 1068 | |
| 1069 | (widen) |
| 1070 | (set-buffer-multibyte nil) |
| 1071 | (let* ((start (+ (tar-desc-data-start descriptor) tar-header-offset -513))) |
| 1072 | ;; |
| 1073 | ;; delete the old field and insert a new one. |
| 1074 | (goto-char (+ start data-position)) |
| 1075 | (delete-region (point) (+ (point) (length new-data-string))) ; <-- |
| 1076 | (insert new-data-string) ; <-- |
| 1077 | ;; |
| 1078 | ;; compute a new checksum and insert it. |
| 1079 | (let ((chk (tar-header-block-checksum |
| 1080 | (buffer-substring start (+ start 512))))) |
| 1081 | (goto-char (+ start tar-chk-offset)) |
| 1082 | (delete-region (point) (+ (point) 8)) |
| 1083 | (insert (format "%6o" chk)) |
| 1084 | (insert 0) |
| 1085 | (insert ? ) |
| 1086 | (tar-setf (tar-header-checksum tokens) chk) |
| 1087 | ;; |
| 1088 | ;; ok, make sure we didn't botch it. |
| 1089 | (tar-header-block-check-checksum |
| 1090 | (buffer-substring start (+ start 512)) |
| 1091 | chk (tar-header-name tokens)) |
| 1092 | ))) |
| 1093 | (narrow-to-region (point-min) tar-header-offset) |
| 1094 | (set-buffer-multibyte multibyte) |
| 1095 | (tar-next-line 0)))) |
| 1096 | |
| 1097 | |
| 1098 | (defun tar-octal-time (timeval) |
| 1099 | ;; Format a timestamp as 11 octal digits. Ghod, I hope this works... |
| 1100 | (let ((hibits (car timeval)) (lobits (car (cdr timeval)))) |
| 1101 | (format "%05o%01o%05o" |
| 1102 | (lsh hibits -2) |
| 1103 | (logior (lsh (logand 3 hibits) 1) |
| 1104 | (if (> (logand lobits 32768) 0) 1 0)) |
| 1105 | (logand 32767 lobits) |
| 1106 | ))) |
| 1107 | |
| 1108 | (defun tar-subfile-save-buffer () |
| 1109 | "In tar subfile mode, save this buffer into its parent tar-file buffer. |
| 1110 | This doesn't write anything to disk; you must save the parent tar-file buffer |
| 1111 | to make your changes permanent." |
| 1112 | (interactive) |
| 1113 | (if (not (and (boundp 'tar-superior-buffer) tar-superior-buffer)) |
| 1114 | (error "This buffer has no superior tar file buffer")) |
| 1115 | (if (not (and (boundp 'tar-superior-descriptor) tar-superior-descriptor)) |
| 1116 | (error "This buffer doesn't have an index into its superior tar file!")) |
| 1117 | (save-excursion |
| 1118 | (let ((subfile (current-buffer)) |
| 1119 | (subfile-multibyte enable-multibyte-characters) |
| 1120 | (coding buffer-file-coding-system) |
| 1121 | (descriptor tar-superior-descriptor) |
| 1122 | subfile-size) |
| 1123 | ;; We must make the current buffer unibyte temporarily to avoid |
| 1124 | ;; multibyte->unibyte conversion in `insert-buffer'. |
| 1125 | (set-buffer-multibyte nil) |
| 1126 | (setq subfile-size (buffer-size)) |
| 1127 | (set-buffer tar-superior-buffer) |
| 1128 | (let* ((tokens (tar-desc-tokens descriptor)) |
| 1129 | (start (tar-desc-data-start descriptor)) |
| 1130 | (name (tar-header-name tokens)) |
| 1131 | (size (tar-header-size tokens)) |
| 1132 | (size-pad (ash (ash (+ size 511) -9) 9)) |
| 1133 | (head (memq descriptor tar-parse-info)) |
| 1134 | (following-descs (cdr head)) |
| 1135 | (tar-buffer-multibyte enable-multibyte-characters)) |
| 1136 | (if (not head) |
| 1137 | (error "Can't find this tar file entry in its parent tar file!")) |
| 1138 | (unwind-protect |
| 1139 | (save-excursion |
| 1140 | (widen) |
| 1141 | (set-buffer-multibyte nil) |
| 1142 | ;; delete the old data... |
| 1143 | (let* ((data-start (+ start (- tar-header-offset (point-min)))) |
| 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 | (setq subfile-size |
| 1150 | (encode-coding-region |
| 1151 | data-start (+ data-start subfile-size) coding)) |
| 1152 | ;; |
| 1153 | ;; pad the new data out to a multiple of 512... |
| 1154 | (let ((subfile-size-pad (ash (ash (+ subfile-size 511) -9) 9))) |
| 1155 | (goto-char (+ data-start subfile-size)) |
| 1156 | (insert (make-string (- subfile-size-pad subfile-size) 0)) |
| 1157 | ;; |
| 1158 | ;; update the data pointer of this and all following files... |
| 1159 | (tar-setf (tar-header-size tokens) subfile-size) |
| 1160 | (let ((difference (- subfile-size-pad size-pad))) |
| 1161 | (dolist (desc following-descs) |
| 1162 | (tar-setf (tar-desc-data-start desc) |
| 1163 | (+ (tar-desc-data-start desc) difference)))) |
| 1164 | ;; |
| 1165 | ;; Update the size field in the header block. |
| 1166 | (let ((header-start (- data-start 512))) |
| 1167 | (goto-char (+ header-start tar-size-offset)) |
| 1168 | (delete-region (point) (+ (point) 12)) |
| 1169 | (insert (format "%11o" subfile-size)) |
| 1170 | (insert ? ) |
| 1171 | ;; |
| 1172 | ;; Maybe update the datestamp. |
| 1173 | (if (not tar-update-datestamp) |
| 1174 | nil |
| 1175 | (goto-char (+ header-start tar-time-offset)) |
| 1176 | (delete-region (point) (+ (point) 12)) |
| 1177 | (insert (tar-octal-time (current-time))) |
| 1178 | (insert ? )) |
| 1179 | ;; |
| 1180 | ;; compute a new checksum and insert it. |
| 1181 | (let ((chk (tar-header-block-checksum |
| 1182 | (buffer-substring header-start data-start)))) |
| 1183 | (goto-char (+ header-start tar-chk-offset)) |
| 1184 | (delete-region (point) (+ (point) 8)) |
| 1185 | (insert (format "%6o" chk)) |
| 1186 | (insert 0) |
| 1187 | (insert ? ) |
| 1188 | (tar-setf (tar-header-checksum tokens) chk))) |
| 1189 | ;; |
| 1190 | ;; alter the descriptor-line... |
| 1191 | ;; |
| 1192 | (let ((position (- (length tar-parse-info) (length head)))) |
| 1193 | (goto-char (point-min)) |
| 1194 | (next-line position) |
| 1195 | (beginning-of-line) |
| 1196 | (let ((p (point)) |
| 1197 | after |
| 1198 | (m (set-marker (make-marker) tar-header-offset))) |
| 1199 | (forward-line 1) |
| 1200 | (setq after (point)) |
| 1201 | ;; Insert the new text after the old, before deleting, |
| 1202 | ;; to preserve the window start. |
| 1203 | (let ((line (tar-header-block-summarize tokens t))) |
| 1204 | (if (multibyte-string-p line) |
| 1205 | (insert-before-markers (string-as-unibyte line) "\n") |
| 1206 | (insert-before-markers line "\n"))) |
| 1207 | (delete-region p after) |
| 1208 | (setq tar-header-offset (marker-position m))) |
| 1209 | ))) |
| 1210 | ;; after doing the insertion, add any final padding that may be necessary. |
| 1211 | (tar-pad-to-blocksize)) |
| 1212 | (narrow-to-region (point-min) tar-header-offset) |
| 1213 | (set-buffer-multibyte tar-buffer-multibyte))) |
| 1214 | (set-buffer-modified-p t) ; mark the tar file as modified |
| 1215 | (tar-next-line 0) |
| 1216 | (set-buffer subfile) |
| 1217 | ;; Restore the buffer multibyteness. |
| 1218 | (set-buffer-multibyte subfile-multibyte) |
| 1219 | (set-buffer-modified-p nil) ; mark the tar subfile as unmodified |
| 1220 | (message "Saved into tar-buffer `%s'. Be sure to save that buffer!" |
| 1221 | (buffer-name tar-superior-buffer)) |
| 1222 | ;; Prevent basic-save-buffer from changing our coding-system. |
| 1223 | (setq last-coding-system-used buffer-file-coding-system) |
| 1224 | ;; Prevent ordinary saving from happening. |
| 1225 | t))) |
| 1226 | |
| 1227 | |
| 1228 | ;; When this function is called, it is sure that the buffer is unibyte. |
| 1229 | (defun tar-pad-to-blocksize () |
| 1230 | "If we are being anal about tar file blocksizes, fix up the current buffer. |
| 1231 | Leaves the region wide." |
| 1232 | (if (null tar-anal-blocksize) |
| 1233 | nil |
| 1234 | (widen) |
| 1235 | (let* ((last-desc (nth (1- (length tar-parse-info)) tar-parse-info)) |
| 1236 | (start (tar-desc-data-start last-desc)) |
| 1237 | (tokens (tar-desc-tokens last-desc)) |
| 1238 | (link-p (tar-header-link-type tokens)) |
| 1239 | (size (if link-p 0 (tar-header-size tokens))) |
| 1240 | (data-end (+ start size)) |
| 1241 | (bbytes (ash tar-anal-blocksize 9)) |
| 1242 | (pad-to (+ bbytes (* bbytes (/ (1- data-end) bbytes)))) |
| 1243 | (inhibit-read-only t) ; ## |
| 1244 | ) |
| 1245 | ;; If the padding after the last data is too long, delete some; |
| 1246 | ;; else insert some until we are padded out to the right number of blocks. |
| 1247 | ;; |
| 1248 | (goto-char (+ (or tar-header-offset 0) data-end)) |
| 1249 | (if (> (1+ (buffer-size)) (+ (or tar-header-offset 0) pad-to)) |
| 1250 | (delete-region (+ (or tar-header-offset 0) pad-to) (1+ (buffer-size))) |
| 1251 | (insert (make-string (- (+ (or tar-header-offset 0) pad-to) |
| 1252 | (1+ (buffer-size))) |
| 1253 | 0))) |
| 1254 | ))) |
| 1255 | |
| 1256 | |
| 1257 | ;; Used in write-file-hook to write tar-files out correctly. |
| 1258 | (defun tar-mode-write-file () |
| 1259 | (unwind-protect |
| 1260 | (save-excursion |
| 1261 | (widen) |
| 1262 | ;; Doing this here confuses things - the region gets left too wide! |
| 1263 | ;; I suppose this is run in a context where changing the buffer is bad. |
| 1264 | ;; (tar-pad-to-blocksize) |
| 1265 | ;; tar-header-offset turns out to be null for files fetched with W3, |
| 1266 | ;; at least. |
| 1267 | (let ((coding-system-for-write 'no-conversion)) |
| 1268 | (write-region (if tar-header-offset |
| 1269 | (byte-to-position tar-header-offset) |
| 1270 | (point-min)) |
| 1271 | (point-max) |
| 1272 | buffer-file-name nil t)) |
| 1273 | (tar-clear-modification-flags) |
| 1274 | (set-buffer-modified-p nil)) |
| 1275 | (narrow-to-region (point-min) (byte-to-position tar-header-offset))) |
| 1276 | ;; Return t because we've written the file. |
| 1277 | t) |
| 1278 | \f |
| 1279 | (provide 'tar-mode) |
| 1280 | |
| 1281 | ;;; arch-tag: 8a585a4a-340e-42c2-89e7-d3b1013a4b78 |
| 1282 | ;;; tar-mode.el ends here |