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