From: Ivan Shmakov <ivan@siamics.net>
To: 19274@debbugs.gnu.org
Subject: bug#19274: tar-mode.el: allow for adding new archive members
Date: Thu, 04 Dec 2014 21:17:54 +0000 [thread overview]
Message-ID: <877fy7nmgt.fsf@violet.siamics.net> (raw)
[-- 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."
next reply other threads:[~2014-12-04 21:17 UTC|newest]
Thread overview: 17+ messages / expand[flat|nested] mbox.gz Atom feed top
2014-12-04 21:17 Ivan Shmakov [this message]
2014-12-05 2:10 ` bug#19274: tar-mode.el: allow for adding new archive members 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
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=877fy7nmgt.fsf@violet.siamics.net \
--to=ivan@siamics.net \
--cc=19274@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/emacs.git
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.