Last active
July 26, 2018 10:36
-
-
Save cpbotha/05e07dee7fd8243ba73339be186c0b88 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
;; https://emacs.stackexchange.com/a/3843/8743 original code | |
;; cpbotha.net made small improvements to ergonomics | |
;; cpbotha changes: | |
;; - by default extract files WITHOUT their relative directories into DIR, | |
;; because that's what I expect in OFMs. | |
(defun archive-extract-to-file (archive-name item-name command dir keep-relpath) | |
"Extract ITEM-NAME from ARCHIVE-NAME using COMMAND. Save to | |
DIR. If KEEP-RELPATH, extract with relative path otherwise don't." | |
(unwind-protect | |
(let* ((file-name (if keep-relpath | |
;; remove the leading / from the file name to force | |
;; expand-file-name to interpret its path as relative to dir | |
(if (string-match "\\`/" item-name) | |
(substring item-name 1) | |
item-name) | |
;; by default just strip the path completely | |
(file-name-nondirectory item-name))) | |
(output-file (expand-file-name file-name dir)) | |
(output-dir (file-name-directory output-file))) | |
;; create the output directory (and its parents) if it does | |
;; not exist yet | |
(unless (file-directory-p output-dir) | |
(make-directory output-dir t)) | |
;; execute COMMAND, redirecting output to output-file | |
(apply #'call-process | |
(car command) ;program | |
nil ;infile | |
`(:file ,output-file) ;destination | |
nil ;display | |
(append (cdr command) (list archive-name item-name)))) | |
;; FIXME: add unwind forms | |
nil)) | |
;; cpbotha changes: | |
;; - extract to OTHER dired pane, OR to directory containing archive if there | |
;; is no other dired pane | |
(defun archive-extract-marked-to-file (keep-relpath) | |
"Extract marked archive items to OUTPUT-DIR. If KEEP-RELPATH is non-nil | |
or prefix-arg (C-u) is set, keep relative paths of files in archive, | |
otherwise don't." | |
(interactive "P") | |
(let ((output-dir (or (dired-dwim-target-directory) default-directory)) | |
(command (symbol-value (archive-name "extract"))) | |
(archive (buffer-file-name)) | |
(items (archive-get-marked ?* t))) ; get marked items; t means | |
; get item under point if | |
; nothing is marked | |
(mapc | |
(lambda (item) | |
(archive-extract-to-file archive | |
(aref item 0) ; get the name from the descriptor | |
command output-dir keep-relpath)) | |
items))) | |
(provide 'archive-extract-to-file) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment