;;; tar-mode.el --- simple editing of tar files from GNU Emacs
-;; Copyright (C) 1990-1991, 1993-2013 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1991, 1993-2016 Free Software Foundation, Inc.
;; Author: Jamie Zawinski <jwz@lucid.com>
-;; Maintainer: FSF
+;; Maintainer: emacs-devel@gnu.org
;; Created: 04 Apr 1990
;; Keywords: unix
;;
;; o chmod should understand "a+x,og-w".
;;
-;; o It's not possible to add a NEW file to a tar archive; not that
-;; important, but still...
-;;
;; o The code is less efficient that it could be - in a lot of places, I
;; pull a 512-character string out of the buffer and parse it, when I could
;; be parsing it in place, not garbaging a string. Should redo that.
string)
(tar-parse-octal-integer string))
+(defun tar-new-regular-file-header (filename &optional size time)
+ "Return a Tar header for a regular file.
+The header will lack a proper checksum; use `tar-header-block-checksum'
+to compute one, or request `tar-header-serialize' to do that.
+
+Other tar-mode facilities may also require the data-start header
+field to be set to a valid value.
+
+If SIZE is not given or nil, it defaults to 0.
+If TIME is not given or nil, assume now."
+ (make-tar-header
+ nil
+ filename
+ #o644 0 0 (or size 0)
+ (or time (current-time))
+ nil ; checksum
+ nil nil
+ nil nil nil nil nil))
+
+(defun tar--pad-to (pos)
+ (make-string (+ pos (- (point)) (point-min)) 0))
+
+(defun tar--put-at (pos val &optional fmt mask)
+ (when val
+ (insert (tar--pad-to pos)
+ (if fmt
+ (format fmt (if mask (logand mask val) val))
+ val))))
+
+(defun tar-header-serialize (header &optional update-checksum)
+ "Return the serialization of a Tar HEADER as a string.
+This function calls `tar-header-block-check-checksum' to ensure the
+checksum is correct.
+
+If UPDATE-CHECKSUM is non-nil, update HEADER with the newly-computed
+checksum before doing the check."
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (let ((encoded-name
+ (encode-coding-string (tar-header-name header)
+ tar-file-name-coding-system)))
+ (unless (< (length encoded-name) 99)
+ ;; FIXME: Implement it.
+ (error "Long file name support is not implemented"))
+ (insert encoded-name))
+ (tar--put-at tar-mode-offset (tar-header-mode header) "%6o\0 " #o777777)
+ (tar--put-at tar-uid-offset (tar-header-uid header) "%6o\0 " #o777777)
+ (tar--put-at tar-gid-offset (tar-header-gid header) "%6o\0 " #o777777)
+ (tar--put-at tar-size-offset (tar-header-size header) "%11o ")
+ (insert (tar--pad-to tar-time-offset)
+ (tar-octal-time (tar-header-date header))
+ " ")
+ ;; Omit tar-header-checksum (tar-chk-offset) for now.
+ (tar--put-at tar-linkp-offset (tar-header-link-type header))
+ (tar--put-at tar-link-offset (tar-header-link-name header))
+ (when (tar-header-magic header)
+ (tar--put-at tar-magic-offset (tar-header-magic header))
+ (tar--put-at tar-uname-offset (tar-header-uname header))
+ (tar--put-at tar-gname-offset (tar-header-gname header))
+ (tar--put-at tar-dmaj-offset (tar-header-dmaj header) "%7o\0" #o7777777)
+ (tar--put-at tar-dmin-offset (tar-header-dmin header) "%7o\0" #o7777777))
+ (tar--put-at 512 "")
+ (let ((ck (tar-header-block-checksum (buffer-string))))
+ (goto-char (+ (point-min) tar-chk-offset))
+ (delete-char 8)
+ (insert (format "%6o\0 " ck))
+ (when update-checksum
+ (setf (tar-header-checksum header) ck))
+ (tar-header-block-check-checksum (buffer-string)
+ (tar-header-checksum header)
+ (tar-header-name header)))
+ ;; .
+ (buffer-string)))
+
(defun tar-header-block-checksum (string)
"Compute and return a tar-acceptable checksum for this block."
(define-key map "p" 'tar-previous-line)
(define-key map "\^P" 'tar-previous-line)
(define-key map [up] 'tar-previous-line)
+ (define-key map "I" 'tar-new-entry)
(define-key map "R" 'tar-rename-entry)
(define-key map "u" 'tar-unflag)
(define-key map "v" 'tar-view)
(interactive "p")
(tar-next-line (- arg)))
+(defun tar-current-position ()
+ "Return the `tar-parse-info' index for the current line."
+ (count-lines (point-min) (line-beginning-position)))
+
(defun tar-current-descriptor (&optional noerror)
"Return the tar-descriptor of the current line, or signals an error."
;; I wish lines had plists, like in ZMACS...
- (or (nth (count-lines (point-min) (line-beginning-position))
+ (or (nth (tar-current-position)
tar-parse-info)
(if noerror
nil
(error "This line does not describe a tar-file entry"))))
-(defun tar-get-descriptor ()
- (let* ((descriptor (tar-current-descriptor))
- (size (tar-header-size descriptor))
- (link-p (tar-header-link-type descriptor)))
+(defun tar--check-descriptor (descriptor)
+ (let ((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")
((eq link-p 38) "a volume header")
((eq link-p 55) "a pax global extended header")
((eq link-p 72) "a pax extended header")
- (t "a link"))))
+ (t "a link"))))))
+
+(defun tar-get-descriptor ()
+ (let* ((descriptor (tar-current-descriptor))
+ (size (tar-header-size descriptor)))
+ (tar--check-descriptor descriptor)
(if (zerop size) (message "This is a zero-length file"))
descriptor))
+(defun tar-get-file-descriptor (file)
+ ;; Used by package.el.
+ (let ((desc ()))
+ (dolist (hdr tar-parse-info)
+ (when (equal file (tar-header-name hdr))
+ (setq desc hdr)))
+ (tar--check-descriptor desc)
+ desc))
+
(defun tar-mouse-extract (event)
"Extract a file whose tar directory line you click on."
(interactive "e")
(let ((file-name-handler-alist nil))
(apply op args))))
+(defun tar--extract (descriptor)
+ "Extract this entry of the tar file into its own buffer."
+ (let* ((name (tar-header-name descriptor))
+ (size (tar-header-size descriptor))
+ (start (tar-header-data-start descriptor))
+ (end (+ start size))
+ (tarname (buffer-name))
+ (bufname (concat (file-name-nondirectory name)
+ " ("
+ tarname
+ ")"))
+ (buffer (generate-new-buffer bufname)))
+ (with-current-buffer tar-data-buffer
+ (let (coding)
+ (narrow-to-region start end)
+ (goto-char start)
+ (setq coding (or coding-system-for-read
+ (and set-auto-coding-function
+ (funcall set-auto-coding-function
+ name (- end start)))
+ ;; The following binding causes
+ ;; find-buffer-file-type-coding-system
+ ;; (defined on dos-w32.el) to act as if
+ ;; the file being extracted existed, so
+ ;; that the file's contents' encoding and
+ ;; EOL format are auto-detected.
+ (let ((file-name-handler-alist
+ '(("" . tar-file-name-handler))))
+ (car (find-operation-coding-system
+ 'insert-file-contents
+ (cons name (current-buffer)) t)))))
+ (if (or (not coding)
+ (eq (coding-system-type coding) 'undecided))
+ (setq coding (detect-coding-region start end t)))
+ (if (and (default-value 'enable-multibyte-characters)
+ (coding-system-get coding :for-unibyte))
+ (with-current-buffer buffer
+ (set-buffer-multibyte nil)))
+ (widen)
+ (with-current-buffer buffer
+ (setq buffer-undo-list t))
+ (decode-coding-region start end coding buffer)
+ (with-current-buffer buffer
+ (setq buffer-undo-list nil))))
+ buffer))
+
(defun tar-extract (&optional other-window-p)
"In Tar mode, extract this entry of the tar file into its own buffer."
(interactive)
(let* ((view-p (eq other-window-p 'view))
(descriptor (tar-get-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))
- (bufname (concat (file-name-nondirectory name)
- " ("
- tarname
- ")"))
- (read-only-p (or buffer-read-only view-p))
- (new-buffer-file-name (expand-file-name
- ;; `:' is not allowed on Windows
- (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)
- (unless buffer
- (setq buffer (generate-new-buffer bufname))
- (with-current-buffer buffer
- (setq undo-list buffer-undo-list
- buffer-undo-list t))
- (setq bufname (buffer-name buffer))
- (setq just-created t)
- (with-current-buffer tar-data-buffer
- (let (coding)
- (narrow-to-region start end)
- (goto-char start)
- (setq coding (or coding-system-for-read
- (and set-auto-coding-function
- (funcall set-auto-coding-function
- name (- end start)))
- ;; The following binding causes
- ;; find-buffer-file-type-coding-system
- ;; (defined on dos-w32.el) to act as if
- ;; the file being extracted existed, so
- ;; that the file's contents' encoding and
- ;; EOL format are auto-detected.
- (let ((file-name-handler-alist
- '(("" . tar-file-name-handler))))
- (car (find-operation-coding-system
- 'insert-file-contents
- (cons name (current-buffer)) t)))))
- (if (or (not coding)
- (eq (coding-system-type coding) 'undecided))
- (setq coding (detect-coding-region start end t)))
- (if (and (default-value 'enable-multibyte-characters)
- (coding-system-get coding :for-unibyte))
- (with-current-buffer buffer
- (set-buffer-multibyte nil)))
- (widen)
- (decode-coding-region start end coding buffer)))
- (with-current-buffer buffer
- (goto-char (point-min))
- (setq buffer-file-name new-buffer-file-name)
- (setq buffer-file-truename
- (abbreviate-file-name buffer-file-name))
- ;; Force buffer-file-coding-system to what
- ;; decode-coding-region actually used.
- (set-buffer-file-coding-system last-coding-system-used t)
- ;; Set the default-directory to the dir of the
- ;; superior buffer.
- (setq default-directory
- (with-current-buffer tar-buffer
- default-directory))
- (rename-buffer bufname)
- (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)))
- (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))))))
+ (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 "!"
+ (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))
+ (unless buffer
+ (setq buffer (tar--extract descriptor))
+ (setq just-created t)
+ (with-current-buffer buffer
+ (goto-char (point-min))
+ (setq buffer-file-name new-buffer-file-name)
+ (setq buffer-file-truename
+ (abbreviate-file-name buffer-file-name))
+ ;; Force buffer-file-coding-system to what
+ ;; decode-coding-region actually used.
+ (set-buffer-file-coding-system last-coding-system-used t)
+ ;; Set the default-directory to the dir of the
+ ;; superior buffer.
+ (setq default-directory
+ (with-current-buffer tar-buffer
+ default-directory))
+ (set-buffer-modified-p nil)
+ (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)))
+ (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 ()
(write-region start end to-file nil nil nil t)))
(message "Copied tar entry %s to %s" name to-file)))
+(defun tar-new-entry (filename &optional index)
+ "Insert a new empty regular file before point."
+ (interactive "*sFile name: ")
+ (let* ((buffer (current-buffer))
+ (index (or index (tar-current-position)))
+ (d-list (and (not (zerop index))
+ (nthcdr (+ -1 index) tar-parse-info)))
+ (pos (if d-list
+ (tar-header-data-end (car d-list))
+ (point-min)))
+ (new-descriptor
+ (tar-new-regular-file-header filename)))
+ ;; Update the data buffer; fill the missing descriptor fields.
+ (with-current-buffer tar-data-buffer
+ (goto-char pos)
+ (insert (tar-header-serialize new-descriptor t))
+ (setf (tar-header-data-start new-descriptor)
+ (copy-marker (point) nil)))
+ ;; Update tar-parse-info.
+ (if d-list
+ (setcdr d-list (cons new-descriptor (cdr d-list)))
+ (setq tar-parse-info (cons new-descriptor tar-parse-info)))
+ ;; Update the listing buffer.
+ (save-excursion
+ (goto-char (point-min))
+ (forward-line index)
+ (let ((inhibit-read-only t))
+ (insert (tar-header-block-summarize new-descriptor) ?\n)))
+ ;; .
+ index))
+
(defun tar-flag-deleted (p &optional unflag)
"In Tar mode, mark this sub-file to be deleted from the tar file.
With a prefix argument, mark that many files."