unofficial mirror of bug-gnu-emacs@gnu.org 
 help / color / mirror / code / Atom feed
* bug#19274: tar-mode.el: allow for adding new archive members
@ 2014-12-04 21:17 Ivan Shmakov
  2014-12-05  2:10 ` Stefan Monnier
  0 siblings, 1 reply; 17+ messages in thread
From: Ivan Shmakov @ 2014-12-04 21:17 UTC (permalink / raw)
  To: 19274

[-- Attachment #1: Type: text/plain, Size: 442 bytes --]

Package:  emacs
Severity: wishlist

	Please consider the patch MIMEd.

	* tar-mode.el: Allow for adding new archive members.
	(tar--pad-to, tar--put-at, tar-header-serialize): New functions.
	(tar-current-position): Split from tar-current-descriptor.
	(tar-current-descriptor): Use it.
	(tar-new-entry): New command.
	(tar-mode-map): Bind it.

-- 
FSF associate member #7257  http://boycottsystemd.org/  … 3013 B6A0 230E 334A

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Type: text/diff, Size: 4769 bytes --]

--- a/lisp/tar-mode.el
+++ b/lisp/tar-mode.el
@@ -369,6 +369,58 @@
 	string)
   (tar-parse-octal-integer string))
 
+(defun tar--pad-to (pos)
+  (make-string (+ pos (- (point)) (point-min)) 0))
+
+(defun tar--put-at (pos val)
+  (when val
+    (insert (tar--pad-to pos) val)))
+
+(defun tar-header-serialize (header &optional update-checksum)
+  (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))
+    (insert (tar--pad-to tar-mode-offset)
+	    (format "%6o\0 " (logand #o777777 (tar-header-mode header)))
+	    (format "%6o\0 " (logand #o777777 (tar-header-uid  header)))
+	    (format "%6o\0 " (logand #o777777 (tar-header-gid  header))))
+    (insert (tar--pad-to tar-size-offset)
+	    (format "%11o " (tar-header-size header)))
+    (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))
+      (let ((dmaj (tar-header-dmaj header))
+	    (dmin (tar-header-dmin header)))
+	(tar--put-at tar-dmaj-offset
+		     (and dmaj (format "%7o\0" (logand #o7777777 dmaj))))
+	(tar--put-at tar-dmin-offset
+		     (and dmin (format "%7o\0" (logand #o7777777 dmin))))))
+    (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."
@@ -547,6 +599,7 @@ defvar tar-mode-map
     (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)
@@ -731,10 +784,14 @@
   (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
@@ -948,6 +1005,45 @@
 	(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 "*sNew file 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
+	  (make-tar-header
+	   nil
+	   filename
+	   #o644 0 0 0
+	   (current-time)
+	   nil				; checksum
+	   nil nil
+	   nil nil nil nil nil)))
+    ;; 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."

^ permalink raw reply	[flat|nested] 17+ messages in thread

end of thread, other threads:[~2015-01-27 22:04 UTC | newest]

Thread overview: 17+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2014-12-04 21:17 bug#19274: tar-mode.el: allow for adding new archive members Ivan Shmakov
2014-12-05  2:10 ` Stefan Monnier
2014-12-05 20:20   ` Ivan Shmakov
2014-12-06  5:09     ` Stefan Monnier
2014-12-06 19:17       ` Ivan Shmakov
2014-12-06 19:33         ` Eli Zaretskii
2014-12-06 19:45           ` Ivan Shmakov
2014-12-06 19:56             ` Eli Zaretskii
2014-12-06 20:04               ` Ivan Shmakov
2014-12-06 20:15                 ` Eli Zaretskii
2014-12-06 20:50                   ` Ivan Shmakov
2014-12-07 16:20                     ` Eli Zaretskii
2014-12-07 17:47                       ` Ivan Shmakov
2014-12-07 17:58                         ` Eli Zaretskii
2014-12-07 18:07                           ` Ivan Shmakov
2015-01-27 22:04                             ` Ivan Shmakov
2014-12-06 23:13         ` Stefan Monnier

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).