;;; 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, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1991, 1993-2011 Free Software Foundation, Inc.
;; Author: Jamie Zawinski <jwz@lucid.com>
;; Maintainer: FSF
(defvar tar-parse-info nil)
(defvar tar-superior-buffer nil)
(defvar tar-superior-descriptor nil)
-(defvar tar-subfile-mode nil)
(defvar tar-file-name-coding-system nil)
(put 'tar-superior-buffer 'permanent-local t)
;; 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))))
+ (assert (or (= (buffer-size tar-data-buffer) (buffer-size))
+ (eq tar-data-swapped
+ (> (buffer-size tar-data-buffer) (buffer-size)))))
tar-data-swapped)))
(defun tar-swap-data ()
"Return a `tar-header' structure.
This is a list of name, mode, uid, gid, size,
write-date, checksum, link-type, and link-name."
- (assert (<= (+ pos 512) (point-max)))
+ (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)))))
(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 (car (member magic-str '("ustar " "ustar\0\0"))))
+ ;; 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)
nil
(- link-p ?0)))
(setq linkname (substring string tar-link-offset link-end))
- (when (and (equal uname-valid-p "ustar\0\0")
+ (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
+ (if (default-value 'enable-multibyte-characters)
(setq name
(decode-coding-string name coding)
linkname
(setq link-p 5)) ; directory
(if (and (equal name "././@LongLink")
- (equal magic-str "ustar ")) ;OLDGNU_MAGIC.
+ ;; Supposedly @LongLink is only used for GNUTAR
+ ;; format (i.e. "ustar ") but some POSIX Tar files
+ ;; (with "ustar\0") have been seen using it as well.
+ (member magic-str '("ustar " "ustar\0")))
;; 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)))
+ (name (decode-coding-string
+ (buffer-substring pos (+ pos size -1)) coding))
(descriptor (tar-header-block-tokenize
(+ pos (tar-roundup-512 size))
coding)))
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))
+ (when uname-valid-p
+ (decode-coding-string
+ (substring string tar-uname-offset uname-end) coding))
+ (when uname-valid-p
+ (decode-coding-string
+ (substring string tar-gname-offset gname-end) coding))
(tar-parse-octal-integer string tar-dmaj-offset tar-dmin-offset)
(tar-parse-octal-integer string tar-dmin-offset tar-prefix-offset)
))))))
(point-min) (point-max))))
descriptor)
(with-current-buffer tar-data-buffer
- (while (and (<= (+ pos 512) (point-max))
+ (while (and (< pos (point-max))
(setq descriptor (tar-header-block-tokenize pos coding)))
(let ((size (tar-header-size descriptor)))
(if (< size 0)
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)
(generate-new-buffer (format " *tar-data %s*"
(file-name-nondirectory
(or buffer-file-name (buffer-name))))))
- (tar-swap-data)
- (tar-summarize-buffer)
- (tar-next-line 0))
-
-
-(defun tar-subfile-mode (p)
+ (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)))))
+
+
+(define-minor-mode tar-subfile-mode
"Minor mode for editing an element of a tar-file.
This mode arranges for \"saving\" this buffer to write the data
into the tar-file buffer that it came from. The changes will actually
appear on disk when you save the tar-file's buffer."
- (interactive "P")
+ ;; Don't do this, because it is redundant and wastes mode line space.
+ ;; :lighter " TarFile"
+ nil nil nil
(or (and (boundp 'tar-superior-buffer) tar-superior-buffer)
(error "This buffer is not an element of a tar file"))
- ;; Don't do this, because it is redundant and wastes mode line space.
- ;; (or (assq 'tar-subfile-mode minor-mode-alist)
- ;; (setq minor-mode-alist (append minor-mode-alist
- ;; (list '(tar-subfile-mode " TarFile")))))
- (make-local-variable 'tar-subfile-mode)
- (setq tar-subfile-mode
- (if (null p)
- (not tar-subfile-mode)
- (> (prefix-numeric-value p) 0)))
(cond (tar-subfile-mode
(add-hook 'write-file-functions 'tar-subfile-save-buffer nil t)
;; turn off auto-save.
(auto-save-mode -1)
- (setq buffer-auto-save-file-name nil)
- (run-hooks 'tar-subfile-mode-hook))
+ (setq buffer-auto-save-file-name nil))
(t
(remove-hook 'write-file-functions 'tar-subfile-save-buffer t))))
(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)
undo-list)
(if (or (not coding)
(eq (coding-system-type coding) 'undecided))
(setq coding (detect-coding-region start end t)))
- (if (and default-enable-multibyte-characters
+ (if (and (default-value 'enable-multibyte-characters)
(coding-system-get coding :for-unibyte))
(with-current-buffer buffer
(set-buffer-multibyte nil)))
(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
- buffer (and just-created 'kill-buffer-if-not-modified))
- (if (eq other-window-p 'display)
- (display-buffer buffer)
- (if other-window-p
- (switch-to-buffer-other-window buffer)
- (switch-to-buffer buffer)))))))
+ (cond
+ (view-p
+ (view-buffer buffer (and just-created 'kill-buffer-if-not-modified)))
+ ((eq other-window-p 'display) (display-buffer buffer))
+ (other-window-p (switch-to-buffer-other-window buffer))
+ (t (switch-to-buffer buffer))))))
(defun tar-extract-other-window ()
(end (+ start size))
(inhibit-file-name-handlers inhibit-file-name-handlers)
(inhibit-file-name-operation inhibit-file-name-operation))
- (save-restriction
- (widen)
+ (with-current-buffer
+ (if (tar-data-swapped-p) tar-data-buffer (current-buffer))
;; Inhibit compressing a subfile again if *both* name and
;; to-file are handled by jka-compr
- (if (and (eq (find-file-name-handler name 'write-region) 'jka-compr-handler)
- (eq (find-file-name-handler to-file 'write-region) 'jka-compr-handler))
+ (if (and (eq (find-file-name-handler name 'write-region)
+ 'jka-compr-handler)
+ (eq (find-file-name-handler to-file 'write-region)
+ 'jka-compr-handler))
(setq inhibit-file-name-handlers
(cons 'jka-compr-handler
(and (eq inhibit-file-name-operation 'write-region)
(read-string "New UID string: " (tar-header-uname descriptor))))))
(cond ((stringp new-uid)
(setf (tar-header-uname (tar-current-descriptor)) new-uid)
- (tar-alter-one-field tar-uname-offset (concat new-uid "\000")))
+ (tar-alter-one-field tar-uname-offset
+ (concat (encode-coding-string
+ new-uid tar-file-name-coding-system)
+ "\000")))
(t
(setf (tar-header-uid (tar-current-descriptor)) new-uid)
(tar-alter-one-field tar-uid-offset
(cond ((stringp new-gid)
(setf (tar-header-gname (tar-current-descriptor)) new-gid)
(tar-alter-one-field tar-gname-offset
- (concat new-gid "\000")))
+ (concat (encode-coding-string
+ new-gid tar-file-name-coding-system)
+ "\000")))
(t
(setf (tar-header-gid (tar-current-descriptor)) new-gid)
(tar-alter-one-field tar-gid-offset
(string-match "/" encoded-new-name
(- (length encoded-new-name) 99))
(< (match-beginning 0) 155))
- (unless (equal (tar-header-magic descriptor) "ustar\0\0")
- (tar-alter-one-field tar-magic-offset "ustar\0\0"))
+ (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))))
(provide 'tar-mode)
-;; arch-tag: 8a585a4a-340e-42c2-89e7-d3b1013a4b78
;;; tar-mode.el ends here
HCoop / bpt / emacs.git / blobdiff