;;; tar-mode.el --- simple editing of tar files from GNU emacs
;; Copyright (C) 1990, 1991, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
;; Author: Jamie Zawinski <jwz@lucid.com>
;; Maintainer: FSF
;;; Bugs:
-;; - Expunge and rename on ././@LongLink files
+;; - Rename on ././@LongLink files
;; - Revert confirmation displays the raw data temporarily.
-;; - Incorrect goal-column if username is too long.
;;; Code:
(defvar tar-data-buffer nil "Buffer that holds the actual raw tar bytes.")
(make-variable-buffer-local 'tar-data-buffer)
+(defvar tar-data-swapped nil
+ "If non-nil, `tar-data-buffer' indeed holds raw tar bytes.")
+(make-variable-buffer-local 'tar-data-swapped)
+
(defun tar-data-swapped-p ()
"Return non-nil if the tar-data is in `tar-data-buffer'."
- ;; We need to be careful to keep track of which buffer holds the tar-data,
- ;; since we swap them back and forth. Since the user may make the summary
- ;; buffer unibyte, we can't rely on the multibyteness of the buffers.
- ;; We could try and recognize the tar-format signature, but instead
- ;; I decided to go for something simpler.
(and (buffer-live-p tar-data-buffer)
- (> (buffer-size tar-data-buffer) (buffer-size))))
-
-\f
-(defmacro tar-setf (form val)
- "A mind-numbingly simple implementation of setf."
- (let ((mform (macroexpand form (and (boundp 'byte-compile-macro-environment)
- byte-compile-macro-environment))))
- (cond ((symbolp mform) (list 'setq mform val))
- ((not (consp mform)) (error "can't setf %s" form))
- ((eq (car mform) 'aref)
- (list 'aset (nth 1 mform) (nth 2 mform) val))
- ((eq (car mform) 'car)
- (list 'setcar (nth 1 mform) val))
- ((eq (car mform) 'cdr)
- (list 'setcdr (nth 1 mform) val))
- (t (error "don't know how to setf %s" form)))))
+ ;; Sanity check to try and make sure tar-data-swapped tracks the swap
+ ;; state correctly: the raw data is expected to be always larger than
+ ;; the summary.
+ (progn
+ (assert (eq tar-data-swapped
+ (> (buffer-size tar-data-buffer) (buffer-size))))
+ tar-data-swapped)))
+
+(defun tar-swap-data ()
+ "Swap buffer contents between current buffer and `tar-data-buffer'.
+Preserve the modified states of the buffers and set `buffer-swapped-with'."
+ (let ((data-buffer-modified-p (buffer-modified-p tar-data-buffer))
+ (current-buffer-modified-p (buffer-modified-p)))
+ (buffer-swap-text tar-data-buffer)
+ (setq tar-data-swapped (not tar-data-swapped))
+ (restore-buffer-modified-p data-buffer-modified-p)
+ (with-current-buffer tar-data-buffer
+ (restore-buffer-modified-p current-buffer-modified-p))))
\f
;;; down to business.
-(defmacro make-tar-header (name mode uid git size date ck lt ln
- magic uname gname devmaj devmin)
- (list 'vector name mode uid git size date ck lt ln
- magic uname gname devmaj devmin))
-
-(defmacro tar-header-name (x) (list 'aref x 0))
-(defmacro tar-header-mode (x) (list 'aref x 1))
-(defmacro tar-header-uid (x) (list 'aref x 2))
-(defmacro tar-header-gid (x) (list 'aref x 3))
-(defmacro tar-header-size (x) (list 'aref x 4))
-(defmacro tar-header-date (x) (list 'aref x 5))
-(defmacro tar-header-checksum (x) (list 'aref x 6))
-(defmacro tar-header-link-type (x) (list 'aref x 7))
-(defmacro tar-header-link-name (x) (list 'aref x 8))
-(defmacro tar-header-magic (x) (list 'aref x 9))
-(defmacro tar-header-uname (x) (list 'aref x 10))
-(defmacro tar-header-gname (x) (list 'aref x 11))
-(defmacro tar-header-dmaj (x) (list 'aref x 12))
-(defmacro tar-header-dmin (x) (list 'aref x 13))
-
-(defmacro make-tar-desc (data-start tokens)
- (list 'cons data-start tokens))
-
-(defmacro tar-desc-data-start (x) (list 'car x))
-(defmacro tar-desc-tokens (x) (list 'cdr x))
+(defstruct (tar-header
+ (:constructor nil)
+ (:type vector)
+ :named
+ (:constructor
+ make-tar-header (data-start name mode uid gid size date checksum
+ link-type link-name magic uname gname dmaj dmin)))
+ data-start name mode uid gid size date checksum link-type link-name
+ magic uname gname dmaj dmin
+ ;; Start of the header can be nil (meaning it's 512 bytes before data-start)
+ ;; or a marker (in case the header uses LongLink thingies).
+ header-start)
(defconst tar-name-offset 0)
(defconst tar-mode-offset (+ tar-name-offset 100))
(defconst tar-prefix-offset (+ tar-dmin-offset 8))
(defconst tar-end-offset (+ tar-prefix-offset 155))
-(defun tar-header-block-tokenize (string)
+(defun tar-roundup-512 (s)
+ "Round S up to the next multiple of 512."
+ (ash (ash (+ s 511) -9) 9))
+
+(defun tar-header-block-tokenize (pos coding)
"Return a `tar-header' structure.
This is a list of name, mode, uid, gid, size,
write-date, checksum, link-type, and link-name."
- (setq string (string-as-unibyte string))
- (cond ((< (length string) 512) nil)
- (;(some 'plusp string) ; <-- oops, massive cycle hog!
- (or (not (= 0 (aref string 0))) ; This will do.
- (not (= 0 (aref string 101))))
- (let* ((name-end tar-mode-offset)
- (link-end (1- tar-magic-offset))
- (uname-end (1- tar-gname-offset))
- (gname-end (1- tar-dmaj-offset))
- (link-p (aref string tar-linkp-offset))
- (magic-str (substring string tar-magic-offset (1- tar-uname-offset)))
- (uname-valid-p (or (string= "ustar " magic-str) (string= "GNUtar " magic-str)
- (string= "ustar\0000" magic-str)))
- name linkname
- (nulsexp "[^\000]*\000"))
- (when (string-match nulsexp string tar-name-offset)
- (setq name-end (min name-end (1- (match-end 0)))))
- (when (string-match nulsexp string tar-link-offset)
- (setq link-end (min link-end (1- (match-end 0)))))
- (when (string-match nulsexp string tar-uname-offset)
- (setq uname-end (min uname-end (1- (match-end 0)))))
- (when (string-match nulsexp string tar-gname-offset)
- (setq gname-end (min gname-end (1- (match-end 0)))))
- (setq name (substring string tar-name-offset name-end)
- link-p (if (or (= link-p 0) (= link-p ?0))
- nil
- (- link-p ?0)))
- (setq linkname (substring string tar-link-offset link-end))
- (when (and uname-valid-p
- (string-match nulsexp string tar-prefix-offset)
- (> (match-end 0) (1+ tar-prefix-offset)))
- (setq name (concat (substring string tar-prefix-offset
- (1- (match-end 0)))
- "/" name)))
- (if default-enable-multibyte-characters
- (setq name
- (decode-coding-string name tar-file-name-coding-system)
- linkname
- (decode-coding-string linkname
- tar-file-name-coding-system)))
- (if (and (null link-p) (string-match "/\\'" name)) (setq link-p 5)) ; directory
- (make-tar-header
- name
- (tar-parse-octal-integer string tar-mode-offset tar-uid-offset)
- (tar-parse-octal-integer string tar-uid-offset tar-gid-offset)
- (tar-parse-octal-integer string tar-gid-offset tar-size-offset)
- (tar-parse-octal-integer string tar-size-offset tar-time-offset)
- (tar-parse-octal-long-integer string tar-time-offset tar-chk-offset)
- (tar-parse-octal-integer string tar-chk-offset tar-linkp-offset)
- link-p
- linkname
- uname-valid-p
- (and uname-valid-p (substring string tar-uname-offset uname-end))
- (and uname-valid-p (substring string tar-gname-offset gname-end))
- (tar-parse-octal-integer string tar-dmaj-offset tar-dmin-offset)
- (tar-parse-octal-integer string tar-dmin-offset tar-prefix-offset)
- )))
- (t 'empty-tar-block)))
-
+ (if (> (+ pos 512) (point-max)) (error "Malformed Tar header"))
+ (assert (zerop (mod (- pos (point-min)) 512)))
+ (assert (not enable-multibyte-characters))
+ (let ((string (buffer-substring pos (setq pos (+ pos 512)))))
+ (when ;(some 'plusp string) ; <-- oops, massive cycle hog!
+ (or (not (= 0 (aref string 0))) ; This will do.
+ (not (= 0 (aref string 101))))
+ (let* ((name-end tar-mode-offset)
+ (link-end (1- tar-magic-offset))
+ (uname-end (1- tar-gname-offset))
+ (gname-end (1- tar-dmaj-offset))
+ (link-p (aref string tar-linkp-offset))
+ (magic-str (substring string tar-magic-offset
+ ;; The magic string is actually 6bytes
+ ;; of magic string plus 2bytes of version
+ ;; which we here ignore.
+ (- tar-uname-offset 2)))
+ ;; The magic string is "ustar\0" for POSIX format, and
+ ;; "ustar " for GNU Tar's format.
+ (uname-valid-p (car (member magic-str '("ustar " "ustar\0"))))
+ name linkname
+ (nulsexp "[^\000]*\000"))
+ (when (string-match nulsexp string tar-name-offset)
+ (setq name-end (min name-end (1- (match-end 0)))))
+ (when (string-match nulsexp string tar-link-offset)
+ (setq link-end (min link-end (1- (match-end 0)))))
+ (when (string-match nulsexp string tar-uname-offset)
+ (setq uname-end (min uname-end (1- (match-end 0)))))
+ (when (string-match nulsexp string tar-gname-offset)
+ (setq gname-end (min gname-end (1- (match-end 0)))))
+ (setq name (substring string tar-name-offset name-end)
+ link-p (if (or (= link-p 0) (= link-p ?0))
+ nil
+ (- link-p ?0)))
+ (setq linkname (substring string tar-link-offset link-end))
+ (when (and (equal uname-valid-p "ustar\0")
+ (string-match nulsexp string tar-prefix-offset)
+ (> (match-end 0) (1+ tar-prefix-offset)))
+ (setq name (concat (substring string tar-prefix-offset
+ (1- (match-end 0)))
+ "/" name)))
+ (if default-enable-multibyte-characters
+ (setq name
+ (decode-coding-string name coding)
+ linkname
+ (decode-coding-string linkname coding)))
+ (if (and (null link-p) (string-match "/\\'" name))
+ (setq link-p 5)) ; directory
+
+ (if (and (equal name "././@LongLink")
+ (equal magic-str "ustar ")) ;OLDGNU_MAGIC.
+ ;; This is a GNU Tar long-file-name header.
+ (let* ((size (tar-parse-octal-integer
+ string tar-size-offset tar-time-offset))
+ ;; -1 so as to strip the terminating 0 byte.
+ (name (buffer-substring pos (+ pos size -1)))
+ (descriptor (tar-header-block-tokenize
+ (+ pos (tar-roundup-512 size))
+ coding)))
+ (cond
+ ((eq link-p (- ?L ?0)) ;GNUTYPE_LONGNAME.
+ (setf (tar-header-name descriptor) name))
+ ((eq link-p (- ?K ?0)) ;GNUTYPE_LONGLINK.
+ (setf (tar-header-link-name descriptor) name))
+ (t
+ (message "Unrecognized GNU Tar @LongLink format")))
+ (setf (tar-header-header-start descriptor)
+ (copy-marker (- pos 512) t))
+ descriptor)
+
+ (make-tar-header
+ (copy-marker pos nil)
+ name
+ (tar-parse-octal-integer string tar-mode-offset tar-uid-offset)
+ (tar-parse-octal-integer string tar-uid-offset tar-gid-offset)
+ (tar-parse-octal-integer string tar-gid-offset tar-size-offset)
+ (tar-parse-octal-integer string tar-size-offset tar-time-offset)
+ (tar-parse-octal-long-integer string tar-time-offset tar-chk-offset)
+ (tar-parse-octal-integer string tar-chk-offset tar-linkp-offset)
+ link-p
+ linkname
+ uname-valid-p
+ (and uname-valid-p (substring string tar-uname-offset uname-end))
+ (and uname-valid-p (substring string tar-gname-offset gname-end))
+ (tar-parse-octal-integer string tar-dmaj-offset tar-dmin-offset)
+ (tar-parse-octal-integer string tar-dmin-offset tar-prefix-offset)
+ ))))))
+
+;; Pseudo-field.
+(defun tar-header-data-end (descriptor)
+ (let* ((data-start (tar-header-data-start descriptor))
+ (link-type (tar-header-link-type descriptor))
+ (size (tar-header-size descriptor))
+ (fudge (cond
+ ;; Foo. There's an extra empty block after these.
+ ((memq link-type '(20 55)) 512)
+ (t 0))))
+ (+ data-start fudge
+ (if (and (null link-type) (> size 0))
+ (tar-roundup-512 size)
+ 0))))
(defun tar-parse-octal-integer (string &optional start end)
(if (null start) (setq start 0))
(defun tar-header-block-checksum (string)
"Compute and return a tar-acceptable checksum for this block."
- (setq string (string-as-unibyte string))
+ (assert (not (multibyte-string-p string)))
(let* ((chk-field-start tar-chk-offset)
(chk-field-end (+ chk-field-start 8))
(sum 0)
;; (ck (tar-header-checksum tar-hblock))
(type (tar-header-link-type tar-hblock))
(link-name (tar-header-link-name tar-hblock)))
- (format "%c%c%s%8s/%-8s%7s%s %s%s"
+ (format "%c%c%s %7s/%-7s %7s%s %s%s"
(if mod-p ?* ? )
(cond ((or (eq type nil) (eq type 0)) ?-)
((eq type 1) ?h) ; link
(if (tar-data-swapped-p) tar-data-buffer (current-buffer))
(set-buffer-multibyte nil) ;Hopefully, a no-op.
(dolist (descriptor descriptors)
- (let* ((tokens (tar-desc-tokens descriptor))
- (name (tar-header-name tokens))
- (dir (if (eq (tar-header-link-type tokens) 5)
+ (let* ((name (tar-header-name descriptor))
+ (dir (if (eq (tar-header-link-type descriptor) 5)
name
(file-name-directory name)))
- (start (tar-desc-data-start descriptor))
- (end (+ start (tar-header-size tokens))))
+ (start (tar-header-data-start descriptor))
+ (end (+ start (tar-header-size descriptor))))
(unless (file-directory-p name)
(message "Extracting %s" name)
(if (and dir (not (file-exists-p dir)))
(make-directory dir t))
(unless (file-directory-p name)
(write-region start end name))
- (set-file-modes name (tar-header-mode tokens))))))))
+ (set-file-modes name (tar-header-mode descriptor))))))))
(defun tar-summarize-buffer ()
- "Parse the contents of the tar file in the current buffer.
-Place a dired-like listing on the front;
-then narrow to it, so that only that listing
-is visible (and the real data of the buffer is hidden)."
+ "Parse the contents of the tar file in the current buffer."
(assert (tar-data-swapped-p))
(let* ((modified (buffer-modified-p))
(result '())
(pos (point-min))
+ (coding tar-file-name-coding-system)
(progress-reporter
- (make-progress-reporter "Parsing tar file..."
- (point-min) (max 1 (- (buffer-size) 1024))))
- tokens)
+ (with-current-buffer tar-data-buffer
+ (make-progress-reporter "Parsing tar file..."
+ (point-min) (point-max))))
+ descriptor)
(with-current-buffer tar-data-buffer
- (while (and (<= (+ pos 512) (point-max))
- (not (eq 'empty-tar-block
- (setq tokens
- (tar-header-block-tokenize
- (buffer-substring pos (+ pos 512)))))))
- (setq pos (+ pos 512))
- (when (equal (tar-header-name tokens) "././@LongLink")
- ;; This is a GNU Tar long-file-name header.
- (let* ((size (tar-header-size tokens))
- ;; -1 so as to strip the terminating 0 byte.
- (name (buffer-substring pos (+ pos size -1))))
- (setq pos (+ pos (ash (ash (+ 511 size) -9) 9)))
- (setq tokens (tar-header-block-tokenize
- (buffer-substring pos (+ pos 512))))
- (tar-setf (tar-header-name tokens) name)
- (setq pos (+ pos 512))))
- (progress-reporter-update progress-reporter pos)
- (if (memq (tar-header-link-type tokens) '(20 55))
- ;; Foo. There's an extra empty block after these.
- (setq pos (+ pos 512)))
- (let ((size (tar-header-size tokens)))
+ (while (and (< pos (point-max))
+ (setq descriptor (tar-header-block-tokenize pos coding)))
+ (let ((size (tar-header-size descriptor)))
(if (< size 0)
(error "%s has size %s - corrupted"
- (tar-header-name tokens) size))
- ;;
- ;; This is just too slow. Don't really need it anyway....
- ;;(tar-header-block-check-checksum
- ;; hblock (tar-header-block-checksum hblock)
- ;; (tar-header-name tokens))
-
- (push (make-tar-desc pos tokens) result)
-
- (and (null (tar-header-link-type tokens))
- (> size 0)
- ;; Round up to a multiple of 512.
- (setq pos (+ pos (ash (ash (+ 511 size) -9) 9)))))))
- (make-local-variable 'tar-parse-info)
- (setq tar-parse-info (nreverse result))
+ (tar-header-name descriptor) size)))
+ ;;
+ ;; This is just too slow. Don't really need it anyway....
+ ;;(tar-header-block-check-checksum
+ ;; hblock (tar-header-block-checksum hblock)
+ ;; (tar-header-name descriptor))
+
+ (push descriptor result)
+ (setq pos (tar-header-data-end descriptor))
+ (progress-reporter-update progress-reporter pos)))
+
+ (set (make-local-variable 'tar-parse-info) (nreverse result))
;; A tar file should end with a block or two of nulls,
;; but let's not get a fatal error if it doesn't.
- (if (eq tokens 'empty-tar-block)
+ (if (null descriptor)
(progress-reporter-done progress-reporter)
(message "Warning: premature EOF parsing tar file"))
(goto-char (point-min))
(let ((inhibit-read-only t)
(total-summaries
- (mapconcat
- (lambda (tar-desc)
- (tar-header-block-summarize (tar-desc-tokens tar-desc)))
- tar-parse-info
- "\n")))
+ (mapconcat 'tar-header-block-summarize tar-parse-info "\n")))
(insert total-summaries "\n"))
(goto-char (point-min))
(restore-buffer-modified-p modified)))
(defun tar-change-major-mode-hook ()
;; Bring the actual Tar data back into the main buffer.
- (when (tar-data-swapped-p) (buffer-swap-text tar-data-buffer))
+ (when (tar-data-swapped-p) (tar-swap-data))
;; Throw away the summary.
(when (buffer-live-p tar-data-buffer) (kill-buffer tar-data-buffer)))
See also: variables `tar-update-datestamp' and `tar-anal-blocksize'.
\\{tar-mode-map}"
- ;; this is not interactive because you shouldn't be turning this
- ;; mode on and off. You can corrupt things that way.
- ;; rms: with permanent locals, it should now be possible to make this work
- ;; interactively in some reasonable fashion.
(make-local-variable 'tar-parse-info)
(set (make-local-variable 'require-final-newline) nil) ; binary data, dude...
(set (make-local-variable 'local-enable-local-variables) nil)
locale-coding-system))
;; Prevent loss of data when saving the file.
(set (make-local-variable 'file-precious-flag) t)
- (auto-save-mode 0)
(buffer-disable-undo)
(widen)
;; Now move the Tar data into an auxiliary buffer, so we can use the main
;; buffer for the summary.
(assert (not (tar-data-swapped-p)))
(set (make-local-variable 'revert-buffer-function) 'tar-mode-revert)
- (set (make-local-variable 'write-contents-functions) '(tar-mode-write-file))
+ ;; We started using write-contents-functions, but this hook is not
+ ;; used during auto-save, so we now use
+ ;; write-region-annotate-functions which hooks at a lower-level.
+ (add-hook 'write-region-annotate-functions 'tar-write-region-annotate nil t)
(add-hook 'kill-buffer-hook 'tar-mode-kill-buffer-hook nil t)
(add-hook 'change-major-mode-hook 'tar-change-major-mode-hook nil t)
;; Tar data is made of bytes, not chars.
- (set-buffer-multibyte nil)
+ (set-buffer-multibyte nil) ;Hopefully a no-op.
(set (make-local-variable 'tar-data-buffer)
(generate-new-buffer (format " *tar-data %s*"
(file-name-nondirectory
(or buffer-file-name (buffer-name))))))
- (buffer-swap-text tar-data-buffer)
- (tar-summarize-buffer)
- (tar-next-line 0))
+ (condition-case err
+ (progn
+ (tar-swap-data)
+ (tar-summarize-buffer)
+ (tar-next-line 0))
+ (error
+ ;; If summarizing caused an error, then maybe the buffer doesn't contain
+ ;; tar data. Rather than show a mysterious empty buffer, let's
+ ;; revert to fundamental-mode.
+ (fundamental-mode)
+ (signal (car err) (cdr err)))))
(defun tar-subfile-mode (p)
(defun tar-mode-revert (&optional no-auto-save no-confirm)
(unwind-protect
(let ((revert-buffer-function nil))
- (if (tar-data-swapped-p) (buffer-swap-text tar-data-buffer))
+ (if (tar-data-swapped-p) (tar-swap-data))
;; FIXME: If we ask for confirmation, the user will be temporarily
;; looking at the raw data.
(revert-buffer no-auto-save no-confirm 'preserve-modes)
- ;; The new raw data may be smaller than the old summary, so let's
- ;; make sure tar-data-swapped-p doesn't get confused.
- (if (buffer-live-p tar-data-buffer) (kill-buffer tar-data-buffer))
;; Recompute the summary.
+ (if (buffer-live-p tar-data-buffer) (kill-buffer tar-data-buffer))
(tar-mode))
- (unless (tar-data-swapped-p) (buffer-swap-text tar-data-buffer))))
+ (unless (tar-data-swapped-p) (tar-swap-data))))
(defun tar-next-line (arg)
"Move cursor vertically down ARG lines and to the start of the filename."
(interactive "p")
(forward-line arg)
- (if (eobp) nil (forward-char (if tar-mode-show-date 54 36))))
+ (goto-char (or (next-single-property-change (point) 'mouse-face) (point))))
(defun tar-previous-line (arg)
"Move cursor vertically up ARG lines and to the start of the filename."
(defun tar-get-descriptor ()
(let* ((descriptor (tar-current-descriptor))
- (tokens (tar-desc-tokens descriptor))
- (size (tar-header-size tokens))
- (link-p (tar-header-link-type tokens)))
+ (size (tar-header-size descriptor))
+ (link-p (tar-header-link-type descriptor)))
(if link-p
(error "This is %s, not a real file"
(cond ((eq link-p 5) "a directory")
(interactive)
(let* ((view-p (eq other-window-p 'view))
(descriptor (tar-get-descriptor))
- (tokens (tar-desc-tokens descriptor))
- (name (tar-header-name tokens))
- (size (tar-header-size tokens))
- (start (tar-desc-data-start descriptor))
+ (name (tar-header-name descriptor))
+ (size (tar-header-size descriptor))
+ (start (tar-header-data-start descriptor))
(end (+ start size)))
(let* ((tar-buffer (current-buffer))
(tarname (buffer-name))
(read-only-p (or buffer-read-only view-p))
(new-buffer-file-name (expand-file-name
;; `:' is not allowed on Windows
- (concat tarname "!" name)))
+ (concat tarname "!"
+ (if (string-match "/" name)
+ name
+ ;; Make sure `name' contains a /
+ ;; so set-auto-mode doesn't try
+ ;; to look at `tarname' for hints.
+ (concat "./" name)))))
(buffer (get-file-buffer new-buffer-file-name))
(just-created nil)
- (pos (point))
undo-list)
(unless buffer
(setq buffer (generate-new-buffer bufname))
(setq default-directory
(with-current-buffer tar-buffer
default-directory))
- (normal-mode) ; pick a mode.
(rename-buffer bufname)
- (make-local-variable 'tar-superior-buffer)
- (make-local-variable 'tar-superior-descriptor)
- (setq tar-superior-buffer tar-buffer)
- (setq tar-superior-descriptor descriptor)
- (setq buffer-read-only read-only-p)
(set-buffer-modified-p nil)
(setq buffer-undo-list undo-list)
+ (normal-mode) ; pick a mode.
+ (set (make-local-variable 'tar-superior-buffer) tar-buffer)
+ (set (make-local-variable 'tar-superior-descriptor) descriptor)
+ (setq buffer-read-only read-only-p)
(tar-subfile-mode 1)))
(if view-p
(view-buffer
"Read a file name with this line's entry as the default."
(or prompt (setq prompt "Copy to: "))
(let* ((default-file (expand-file-name
- (tar-header-name (tar-desc-tokens
- (tar-current-descriptor)))))
+ (tar-header-name (tar-current-descriptor))))
(target (expand-file-name
(read-file-name prompt
(file-name-directory default-file)
the current tar-entry."
(interactive (list (tar-read-file-name)))
(let* ((descriptor (tar-get-descriptor))
- (tokens (tar-desc-tokens descriptor))
- (name (tar-header-name tokens))
- (size (tar-header-size tokens))
- (start (tar-desc-data-start descriptor))
+ (name (tar-header-name descriptor))
+ (size (tar-header-size descriptor))
+ (start (tar-header-data-start descriptor))
(end (+ start size))
(inhibit-file-name-handlers inhibit-file-name-handlers)
(inhibit-file-name-operation inhibit-file-name-operation))
(defun tar-expunge-internal ()
"Expunge the tar-entry specified by the current line."
- (let* ((descriptor (tar-current-descriptor))
- (tokens (tar-desc-tokens descriptor))
- ;; (line (tar-desc-data-start descriptor))
- (name (tar-header-name tokens))
- (size (tar-header-size tokens))
- (link-p (tar-header-link-type tokens))
- (start (tar-desc-data-start descriptor))
- (following-descs (cdr (memq descriptor tar-parse-info))))
- (if link-p (setq size 0)) ; size lies for hard-links.
+ (let ((descriptor (tar-current-descriptor)))
;;
;; delete the current line...
(delete-region (line-beginning-position) (line-beginning-position 2))
(setq tar-parse-info (delq descriptor tar-parse-info))
;;
;; delete the data from inside the file...
- (let* ((data-start (+ start -512))
- (data-end (+ data-start 512 (ash (ash (+ size 511) -9) 9))))
- (with-current-buffer tar-data-buffer
- (delete-region data-start data-end))
- ;;
- ;; and finally, decrement the start-pointers of all following
- ;; entries in the archive. This is a pig when deleting a bunch
- ;; of files at once - we could optimize this to only do the
- ;; iteration over the files that remain, or only iterate up to
- ;; the next file to be deleted.
- (let ((data-length (- data-end data-start)))
- (dolist (desc following-descs)
- (tar-setf (tar-desc-data-start desc)
- (- (tar-desc-data-start desc) data-length))))
- )))
+ (with-current-buffer tar-data-buffer
+ (delete-region (or (tar-header-header-start descriptor)
+ (- (tar-header-data-start descriptor) 512))
+ (tar-header-data-end descriptor)))))
(defun tar-expunge (&optional noconfirm)
You can force editing as a number by calling this with a prefix arg.
This does not modify the disk image; you must save the tar file itself
for this to be permanent."
- (interactive (list
- (let ((tokens (tar-desc-tokens (tar-current-descriptor))))
- (if (or current-prefix-arg
- (not (tar-header-magic tokens)))
- (let (n)
- (while (not (numberp (setq n (read-minibuffer
- "New UID number: "
- (format "%s" (tar-header-uid tokens)))))))
- n)
- (read-string "New UID string: " (tar-header-uname tokens))))))
+ (interactive
+ (list
+ (let ((descriptor (tar-current-descriptor)))
+ (if (or current-prefix-arg
+ (not (tar-header-magic descriptor)))
+ (read-number
+ "New UID number: "
+ (format "%s" (tar-header-uid descriptor)))
+ (read-string "New UID string: " (tar-header-uname descriptor))))))
(cond ((stringp new-uid)
- (tar-setf (tar-header-uname (tar-desc-tokens (tar-current-descriptor)))
- new-uid)
+ (setf (tar-header-uname (tar-current-descriptor)) new-uid)
(tar-alter-one-field tar-uname-offset (concat new-uid "\000")))
(t
- (tar-setf (tar-header-uid (tar-desc-tokens (tar-current-descriptor)))
- new-uid)
+ (setf (tar-header-uid (tar-current-descriptor)) new-uid)
(tar-alter-one-field tar-uid-offset
(concat (substring (format "%6o" new-uid) 0 6) "\000 ")))))
You can force editing as a number by calling this with a prefix arg.
This does not modify the disk image; you must save the tar file itself
for this to be permanent."
- (interactive (list
- (let ((tokens (tar-desc-tokens (tar-current-descriptor))))
- (if (or current-prefix-arg
- (not (tar-header-magic tokens)))
- (let (n)
- (while (not (numberp (setq n (read-minibuffer
- "New GID number: "
- (format "%s" (tar-header-gid tokens)))))))
- n)
- (read-string "New GID string: " (tar-header-gname tokens))))))
+ (interactive
+ (list
+ (let ((descriptor (tar-current-descriptor)))
+ (if (or current-prefix-arg
+ (not (tar-header-magic descriptor)))
+ (read-number
+ "New GID number: "
+ (format "%s" (tar-header-gid descriptor)))
+ (read-string "New GID string: " (tar-header-gname descriptor))))))
(cond ((stringp new-gid)
- (tar-setf (tar-header-gname (tar-desc-tokens (tar-current-descriptor)))
- new-gid)
+ (setf (tar-header-gname (tar-current-descriptor)) new-gid)
(tar-alter-one-field tar-gname-offset
(concat new-gid "\000")))
(t
- (tar-setf (tar-header-gid (tar-desc-tokens (tar-current-descriptor)))
- new-gid)
+ (setf (tar-header-gid (tar-current-descriptor)) new-gid)
(tar-alter-one-field tar-gid-offset
(concat (substring (format "%6o" new-gid) 0 6) "\000 ")))))
for this to be permanent."
(interactive
(list (read-string "New name: "
- (tar-header-name (tar-desc-tokens (tar-current-descriptor))))))
+ (tar-header-name (tar-current-descriptor)))))
(if (string= "" new-name) (error "zero length name"))
(let ((encoded-new-name (encode-coding-string new-name
- tar-file-name-coding-system)))
+ tar-file-name-coding-system))
+ (descriptor (tar-current-descriptor))
+ (prefix nil))
+ (when (tar-header-header-start descriptor)
+ ;; FIXME: Make it work for ././@LongLink.
+ (error "Rename with @LongLink format is not implemented"))
+
+ (when (and (> (length encoded-new-name) 98)
+ (string-match "/" encoded-new-name
+ (- (length encoded-new-name) 99))
+ (< (match-beginning 0) 155))
+ (unless (equal (tar-header-magic descriptor) "ustar\0")
+ (tar-alter-one-field tar-magic-offset (concat "ustar\0" "00")))
+ (setq prefix (substring encoded-new-name 0 (match-beginning 0)))
+ (setq encoded-new-name (substring encoded-new-name (match-end 0))))
+
(if (> (length encoded-new-name) 98) (error "name too long"))
- (tar-setf (tar-header-name (tar-desc-tokens (tar-current-descriptor)))
- new-name)
+ (setf (tar-header-name descriptor) new-name)
(tar-alter-one-field 0
- (substring (concat encoded-new-name (make-string 99 0)) 0 99))))
+ (substring (concat encoded-new-name (make-string 99 0)) 0 99))
+ (if prefix
+ (tar-alter-one-field tar-prefix-offset
+ (substring (concat prefix (make-string 155 0)) 0 155)))))
(defun tar-chmod-entry (new-mode)
for this to be permanent."
(interactive (list (tar-parse-octal-integer-safe
(read-string "New protection (octal): "))))
- (tar-setf (tar-header-mode (tar-desc-tokens (tar-current-descriptor)))
- new-mode)
+ (setf (tar-header-mode (tar-current-descriptor)) new-mode)
(tar-alter-one-field tar-mode-offset
(concat (substring (format "%6o" new-mode) 0 6) "\000 ")))
-(defun tar-alter-one-field (data-position new-data-string)
- (let* ((descriptor (tar-current-descriptor))
- (tokens (tar-desc-tokens descriptor)))
- ;;
- ;; update the header-line.
- (let ((col (current-column)))
- (delete-region (line-beginning-position) (line-beginning-position 2))
- (insert (tar-header-block-summarize tokens) "\n")
- (forward-line -1) (move-to-column col))
+(defun tar-alter-one-field (data-position new-data-string &optional descriptor)
+ (unless descriptor (setq descriptor (tar-current-descriptor)))
+ ;;
+ ;; update the header-line.
+ (let ((col (current-column)))
+ (delete-region (line-beginning-position)
+ (prog2 (forward-line 1)
+ (point)
+ ;; Insert the new text after the old, before deleting,
+ ;; to preserve markers such as the window start.
+ (insert (tar-header-block-summarize descriptor) "\n")))
+ (forward-line -1) (move-to-column col))
- (with-current-buffer tar-data-buffer
- (let* ((start (+ (tar-desc-data-start descriptor)
- -512)))
+ (assert (tar-data-swapped-p))
+ (with-current-buffer tar-data-buffer
+ (let* ((start (- (tar-header-data-start descriptor) 512)))
;;
;; delete the old field and insert a new one.
(goto-char (+ start data-position))
(delete-region (point) (+ (point) (length new-data-string))) ; <--
-
(assert (not (or enable-multibyte-characters
(multibyte-string-p new-data-string))))
(insert new-data-string)
;;
;; compute a new checksum and insert it.
(let ((chk (tar-header-block-checksum
- (buffer-substring start (+ start 512)))))
- (goto-char (+ start tar-chk-offset))
- (delete-region (point) (+ (point) 8))
- (insert (format "%6o" chk))
- (insert 0)
- (insert ? )
- (tar-setf (tar-header-checksum tokens) chk)
- ;;
- ;; ok, make sure we didn't botch it.
- (tar-header-block-check-checksum
- (buffer-substring start (+ start 512))
- chk (tar-header-name tokens))
- )))))
+ (buffer-substring start (+ start 512)))))
+ (goto-char (+ start tar-chk-offset))
+ (delete-region (point) (+ (point) 8))
+ (insert (format "%6o\0 " chk))
+ (setf (tar-header-checksum descriptor) chk)
+ ;;
+ ;; ok, make sure we didn't botch it.
+ (tar-header-block-check-checksum
+ (buffer-substring start (+ start 512))
+ chk (tar-header-name descriptor))
+ ))))
(defun tar-octal-time (timeval)
(descriptor tar-superior-descriptor)
subfile-size)
(with-current-buffer tar-superior-buffer
- (let* ((tokens (tar-desc-tokens descriptor))
- (start (tar-desc-data-start descriptor))
- (name (tar-header-name tokens))
- (size (tar-header-size tokens))
- (size-pad (ash (ash (+ size 511) -9) 9))
- (head (memq descriptor tar-parse-info))
- (following-descs (cdr head)))
+ (let* ((start (tar-header-data-start descriptor))
+ (name (tar-header-name descriptor))
+ (size (tar-header-size descriptor))
+ (head (memq descriptor tar-parse-info)))
(if (not head)
(error "Can't find this tar file entry in its parent tar file!"))
(with-current-buffer tar-data-buffer
;; delete the old data...
(let* ((data-start start)
- (data-end (+ data-start (ash (ash (+ size 511) -9) 9))))
+ (data-end (+ data-start (tar-roundup-512 size))))
(narrow-to-region data-start data-end)
(delete-region (point-min) (point-max))
;; insert the new data...
(setq subfile-size (- (point-max) (point-min)))
;;
;; pad the new data out to a multiple of 512...
- (let ((subfile-size-pad (ash (ash (+ subfile-size 511) -9) 9)))
+ (let ((subfile-size-pad (tar-roundup-512 subfile-size)))
(goto-char (point-max))
(insert (make-string (- subfile-size-pad subfile-size) 0))
;;
- ;; update the data pointer of this and all following files...
- (tar-setf (tar-header-size tokens) subfile-size)
- (let ((difference (- subfile-size-pad size-pad)))
- (dolist (desc following-descs)
- (tar-setf (tar-desc-data-start desc)
- (+ (tar-desc-data-start desc) difference))))
+ ;; update the data of this files...
+ (setf (tar-header-size descriptor) subfile-size)
;;
;; Update the size field in the header block.
- (widen)
- (let ((header-start (- data-start 512)))
- (goto-char (+ header-start tar-size-offset))
- (delete-region (point) (+ (point) 12))
- (insert (format "%11o" subfile-size))
- (insert ? )
- ;;
- ;; Maybe update the datestamp.
- (if (not tar-update-datestamp)
- nil
- (goto-char (+ header-start tar-time-offset))
- (delete-region (point) (+ (point) 12))
- (insert (tar-octal-time (current-time)))
- (insert ? ))
- ;;
- ;; compute a new checksum and insert it.
- (let ((chk (tar-header-block-checksum
- (buffer-substring header-start data-start))))
- (goto-char (+ header-start tar-chk-offset))
- (delete-region (point) (+ (point) 8))
- (insert (format "%6o" chk))
- (insert 0)
- (insert ? )
- (tar-setf (tar-header-checksum tokens) chk))))))
+ (widen))))
;;
- ;; alter the descriptor-line...
+ ;; alter the descriptor-line and header
;;
(let ((position (- (length tar-parse-info) (length head))))
(goto-char (point-min))
(forward-line position)
- (beginning-of-line)
- (let ((p (point))
- after)
- (forward-line 1)
- (setq after (point))
- ;; Insert the new text after the old, before deleting,
- ;; to preserve the window start.
- (let ((line (tar-header-block-summarize tokens t)))
- (insert-before-markers line "\n"))
- (delete-region p after)))
+ (tar-alter-one-field tar-size-offset (format "%11o " subfile-size))
+ ;;
+ ;; Maybe update the datestamp.
+ (when tar-update-datestamp
+ (tar-alter-one-field tar-time-offset
+ (concat (tar-octal-time (current-time)) " "))))
;; After doing the insertion, add any necessary final padding.
(tar-pad-to-blocksize))
(set-buffer-modified-p t) ; mark the tar file as modified
(if (null tar-anal-blocksize)
nil
(let* ((last-desc (nth (1- (length tar-parse-info)) tar-parse-info))
- (start (tar-desc-data-start last-desc))
- (tokens (tar-desc-tokens last-desc))
- (link-p (tar-header-link-type tokens))
- (size (if link-p 0 (tar-header-size tokens)))
+ (start (tar-header-data-start last-desc))
+ (link-p (tar-header-link-type last-desc))
+ (size (if link-p 0 (tar-header-size last-desc)))
(data-end (+ start size))
(bbytes (ash tar-anal-blocksize 9))
(pad-to (+ bbytes (* bbytes (/ (- data-end (point-min)) bbytes)))))
(insert (make-string (- goal-end (point-max)) ?\0))))))))
-;; Used in write-file-hook to write tar-files out correctly.
-(defun tar-mode-write-file ()
- (unwind-protect
- (progn
- (if (tar-data-swapped-p) (buffer-swap-text tar-data-buffer))
- ;; Yuck: This is an internal function. We should improve the
- ;; write-content-functions hook to make it easier to DTRT.
- (prog1 (basic-save-buffer-1)
- (unless (tar-data-swapped-p) (buffer-swap-text tar-data-buffer))
- (tar-clear-modification-flags)
- (set-buffer-modified-p nil)))
- (unless (tar-data-swapped-p) (buffer-swap-text tar-data-buffer)))
- ;; Return t because we've written the file.
- t)
-\f
+;; Used in write-region-annotate-functions to write tar-files out correctly.
+(defun tar-write-region-annotate (start end)
+ ;; When called from write-file (and auto-save), `start' is nil.
+ ;; When called from M-x write-region, we assume the user wants to save
+ ;; (part of) the summary, not the tar data.
+ (unless (or start (not (tar-data-swapped-p)))
+ (tar-clear-modification-flags)
+ (set-buffer tar-data-buffer)
+ nil))
+
(provide 'tar-mode)
;; arch-tag: 8a585a4a-340e-42c2-89e7-d3b1013a4b78