X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/0877d0dc24ee792b9b14592869ea1aa0934aee58..1bd74554970450054c874dbb69837b43f783c6bd:/lisp/tar-mode.el

diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el
index 6e85925a69..0520369511 100644
--- a/lisp/tar-mode.el
+++ b/lisp/tar-mode.el
@@ -1,9 +1,9 @@
 ;;; 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
 
@@ -50,9 +50,6 @@
 ;;
 ;; 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.
@@ -133,8 +130,10 @@ This information is useful, but it takes screen space away from file names."
   :group 'tar)
 
 (defvar tar-parse-info nil)
-(defvar tar-superior-buffer nil)
-(defvar tar-superior-descriptor nil)
+(defvar tar-superior-buffer nil
+  "Buffer containing the tar archive from which a member was extracted.")
+(defvar tar-superior-descriptor nil
+  "Tar descriptor for a member extracted from an archive.")
 (defvar tar-file-name-coding-system nil)
 
 (put 'tar-superior-buffer 'permanent-local t)
@@ -367,6 +366,80 @@ write-date, checksum, link-type, and link-name."
 	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."
@@ -545,6 +618,7 @@ MODE should be an integer which is a file mode value."
     (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)
@@ -729,19 +803,21 @@ tar-file's buffer."
   (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")
@@ -752,10 +828,24 @@ tar-file's buffer."
 		     ((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")
@@ -774,96 +864,100 @@ tar-file's buffer."
       (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 ()
@@ -930,6 +1024,37 @@ the current tar-entry."
 	(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."