;;; arc-mode.el --- simple editing of archives
-;; Copyright (C) 1995, 1997, 1998, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1997-1998, 2001-2014 Free Software Foundation,
+;; Inc.
;; Author: Morten Welinder <terra@gnu.org>
;; Keywords: files archives msdog editing major-mode
-;; Favourite-brand-of-beer: None, I hate beer.
+;; Favorite-brand-of-beer: None, I hate beer.
;; This file is part of GNU Emacs.
;; ARCHIVE TYPES: Currently only the archives below are handled, but the
;; structure for handling just about anything is in place.
;;
-;; Arc Lzh Zip Zoo Rar
-;; ----------------------------------------
-;; View listing Intern Intern Intern Intern Y
-;; Extract member Y Y Y Y Y
-;; Save changed member Y Y Y Y N
-;; Add new member N N N N N
-;; Delete member Y Y Y Y N
-;; Rename member Y Y N N N
-;; Chmod - Y Y - N
-;; Chown - Y - - N
-;; Chgrp - Y - - N
+;; Arc Lzh Zip Zoo Rar 7z
+;; --------------------------------------------
+;; View listing Intern Intern Intern Intern Y Y
+;; Extract member Y Y Y Y Y Y
+;; Save changed member Y Y Y Y N Y
+;; Add new member N N N N N N
+;; Delete member Y Y Y Y N Y
+;; Rename member Y Y N N N N
+;; Chmod - Y Y - N N
+;; Chown - Y - - N N
+;; Chgrp - Y - - N N
;;
;; Special thanks to Bill Brodie <wbrodie@panix.com> for very useful tips
;; on the first released version of this package.
;;
;; LZH A series of (header,file). Headers are checksummed. No
;; interaction among members.
-;; Headers come in three flavours called level 0, 1 and 2 headers.
+;; Headers come in three flavors called level 0, 1 and 2 headers.
;; Level 2 header is free of DOS specific restrictions and most
-;; prevalently used. Also level 1 and 2 headers consist of base
+;; commonly used. Also level 1 and 2 headers consist of base
;; and extension headers. For more details see
;; http://homepage1.nifty.com/dangan/en/Content/Program/Java/jLHA/Notes/Notes.html
;; http://www.osirusoft.com/joejared/lzhformat.html
;;
;; archive-mode-hook
;; archive-foo-mode-hook
-;; archive-extract-hooks
+;; archive-extract-hook
;;; Code:
:type 'regexp
:group 'archive)
-(defcustom archive-extract-hooks nil
- "Hooks to run when an archive member has been extracted."
+(define-obsolete-variable-alias 'archive-extract-hooks
+ 'archive-extract-hook "24.3")
+(defcustom archive-extract-hook nil
+ "Hook run when an archive member has been extracted."
:type 'hook
:group 'archive)
;; ------------------------------
;; ------------------------------
;; Zip archive configuration
+(defvar archive-7z-program (let ((7z (or (executable-find "7z")
+ (executable-find "7za"))))
+ (when 7z
+ (file-name-nondirectory 7z))))
+
(defcustom archive-zip-extract
- (if (and (not (executable-find "unzip"))
- (executable-find "pkunzip"))
- '("pkunzip" "-e" "-o-")
- '("unzip" "-qq" "-c"))
+ (cond ((executable-find "unzip") '("unzip" "-qq" "-c"))
+ (archive-7z-program `(,archive-7z-program "x" "-so"))
+ ((executable-find "pkunzip") '("pkunzip" "-e" "-o-"))
+ (t '("unzip" "-qq" "-c")))
"Program and its options to run in order to extract a zip file member.
Extraction should happen to standard output. Archive and member name will
be added."
:type '(list (string :tag "Program")
- (repeat :tag "Options"
- :inline t
- (string :format "%v")))
+ (repeat :tag "Options"
+ :inline t
+ (string :format "%v")))
:group 'archive-zip)
;; For several reasons the latter behavior is not desirable in general.
;; names.
(defcustom archive-zip-expunge
- (if (and (not (executable-find "zip"))
- (executable-find "pkzip"))
- '("pkzip" "-d")
- '("zip" "-d" "-q"))
+ (cond ((executable-find "zip") '("zip" "-d" "-q"))
+ (archive-7z-program `(,archive-7z-program "d"))
+ ((executable-find "pkzip") '("pkzip" "-d"))
+ (t '("zip" "-d" "-q")))
"Program and its options to run in order to delete zip file members.
Archive and member names will be added."
:type '(list (string :tag "Program")
- (repeat :tag "Options"
- :inline t
- (string :format "%v")))
+ (repeat :tag "Options"
+ :inline t
+ (string :format "%v")))
:group 'archive-zip)
(defcustom archive-zip-update
- (if (and (not (executable-find "zip"))
- (executable-find "pkzip"))
- '("pkzip" "-u" "-P")
- '("zip" "-q"))
+ (cond ((executable-find "zip") '("zip" "-q"))
+ (archive-7z-program `(,archive-7z-program "u"))
+ ((executable-find "pkzip") '("pkzip" "-u" "-P"))
+ (t '("zip" "-q")))
"Program and its options to run in order to update a zip file member.
Options should ensure that specified directory will be put into the zip
file. Archive and member name will be added."
:type '(list (string :tag "Program")
- (repeat :tag "Options"
- :inline t
- (string :format "%v")))
+ (repeat :tag "Options"
+ :inline t
+ (string :format "%v")))
:group 'archive-zip)
(defcustom archive-zip-update-case
- (if (and (not (executable-find "zip"))
- (executable-find "pkzip"))
- '("pkzip" "-u" "-P")
- '("zip" "-q" "-k"))
+ (cond ((executable-find "zip") '("zip" "-q" "-k"))
+ (archive-7z-program `(,archive-7z-program "u"))
+ ((executable-find "pkzip") '("pkzip" "-u" "-P"))
+ (t '("zip" "-q" "-k")))
"Program and its options to run in order to update a case fiddled zip member.
Options should ensure that specified directory will be put into the zip file.
Archive and member name will be added."
:type '(list (string :tag "Program")
- (repeat :tag "Options"
- :inline t
- (string :format "%v")))
+ (repeat :tag "Options"
+ :inline t
+ (string :format "%v")))
:group 'archive-zip)
(defcustom archive-zip-case-fiddle t
:inline t
(string :format "%v")))
:group 'archive-zoo)
+;; ------------------------------
+;; 7z archive configuration
+
+(defcustom archive-7z-extract
+ `(,(or archive-7z-program "7z") "x" "-so")
+ "Program and its options to run in order to extract a 7z file member.
+Extraction should happen to standard output. Archive and member name will
+be added."
+ :version "24.1"
+ :type '(list (string :tag "Program")
+ (repeat :tag "Options"
+ :inline t
+ (string :format "%v")))
+ :group 'archive-7z)
+
+(defcustom archive-7z-expunge
+ `(,(or archive-7z-program "7z") "d")
+ "Program and its options to run in order to delete 7z file members.
+Archive and member names will be added."
+ :version "24.1"
+ :type '(list (string :tag "Program")
+ (repeat :tag "Options"
+ :inline t
+ (string :format "%v")))
+ :group 'archive-7z)
+
+(defcustom archive-7z-update
+ `(,(or archive-7z-program "7z") "u")
+ "Program and its options to run in order to update a 7z file member.
+Options should ensure that specified directory will be put into the 7z
+file. Archive and member name will be added."
+ :version "24.1"
+ :type '(list (string :tag "Program")
+ (repeat :tag "Options"
+ :inline t
+ (string :format "%v")))
+ :group 'archive-7z)
+
;; -------------------------------------------------------------------------
;;; Section: Variables
(defvar archive-local-name nil "Name of local copy of remote archive.")
(defvar archive-mode-map
(let ((map (make-keymap)))
- (suppress-keymap map)
+ (set-keymap-parent map special-mode-map)
(define-key map " " 'archive-next-line)
(define-key map "a" 'archive-alternate-display)
;;(define-key map "c" 'archive-copy)
(define-key map "e" 'archive-extract)
(define-key map "f" 'archive-extract)
(define-key map "\C-m" 'archive-extract)
- (define-key map "g" 'revert-buffer)
- (define-key map "h" 'describe-mode)
(define-key map "m" 'archive-mark)
(define-key map "n" 'archive-next-line)
(define-key map "\C-n" 'archive-next-line)
(define-key map [down] 'archive-next-line)
(define-key map "o" 'archive-extract-other-window)
(define-key map "p" 'archive-previous-line)
- (define-key map "q" 'quit-window)
(define-key map "\C-p" 'archive-previous-line)
(define-key map [up] 'archive-previous-line)
(define-key map "r" 'archive-rename-entry)
(defun archive-unixdate (low high)
"Stringify Unix (LOW HIGH) date."
- (let ((str (current-time-string (cons high low))))
+ (let* ((time (cons high low))
+ (str (current-time-string time)))
(format "%s-%s-%s"
(substring str 8 10)
(substring str 4 7)
- (substring str 20 24))))
+ (format-time-string "%Y" time))))
(defun archive-unixtime (low high)
"Stringify Unix (LOW HIGH) time."
(defun archive-get-lineno ()
(if (>= (point) archive-file-list-start)
(count-lines archive-file-list-start
- (save-excursion (beginning-of-line) (point)))
+ (line-beginning-position))
0))
(defun archive-get-descr (&optional noerror)
;; At present we cannot create archives from scratch
(funcall (or (default-value 'major-mode) 'fundamental-mode))
(if (and (not force) archive-files) nil
+ (kill-all-local-variables)
(let* ((type (archive-find-type))
(typename (capitalize (symbol-name type))))
- (kill-all-local-variables)
(make-local-variable 'archive-subtype)
(setq archive-subtype type)
(setq revert-buffer-function 'archive-mode-revert)
(auto-save-mode 0)
- ;; Remote archives are not written by a hook.
- (if archive-remote nil
- (add-hook 'write-contents-functions 'archive-write-file nil t))
+ (add-hook 'write-contents-functions 'archive-write-file nil t)
(make-local-variable 'require-final-newline)
(setq require-final-newline nil)
((looking-at "..-l[hz][0-9ds]-") 'lzh)
((looking-at "....................[\334]\247\304\375") 'zoo)
((and (looking-at "\C-z") ; signature too simple, IMHO
- (string-match "\\.[aA][rR][cC]$"
+ (string-match "\\.[aA][rR][cC]\\'"
(or buffer-file-name (buffer-name))))
'arc)
;; This pattern modeled on the BSD/GNU+Linux `file' command.
((and (looking-at "MZ")
(re-search-forward "Rar!" (+ (point) 100000) t))
'rar-exe)
+ ((looking-at "7z\274\257\047\034") '7z)
(t (error "Buffer format not recognized")))))
;; -------------------------------------------------------------------------
Optional argument SHUT-UP, if non-nil, means don't print messages
when parsing the archive."
(widen)
- (let ((inhibit-read-only t))
+ (let ((buffer-file-truename nil) ; avoid changing dir mtime by lock_file
+ (inhibit-read-only t))
(setq archive-proper-file-start (copy-marker (point-min) t))
(set (make-local-variable 'change-major-mode-hook) 'archive-desummarize)
(or shut-up
dir)))
(if (or alien (file-exists-p fullname))
(progn
- ;; Maked sure all the leading directories in
+ ;; Make sure all the leading directories in
;; archive-local-name exist under archive-tmpdir, so that
;; the directory structure recorded in the archive is
;; reconstructed in the temporary directory.
(make-directory (file-name-directory tmpfile) t)
(make-temp-file tmpfile))
- ;; Maked sure all the leading directories in `fullname' exist
+ ;; Make sure all the leading directories in `fullname' exist
;; under archive-tmpdir. This is necessary for nested archives
;; (`archive-extract' sets `archive-remote' to t in case
;; an archive occurs inside another archive).
(save-excursion
(funcall set-auto-coding-function
filename (- (point-max) (point-min)))))
- ;; dos-w32.el defines the function
- ;; find-buffer-file-type-coding-system for DOS/Windows
- ;; systems which preserves the coding-system of existing files.
- ;; (That function is called via file-coding-system-alist.)
- ;; Here, we want it to act as if the extracted file existed.
;; The following let-binding of file-name-handler-alist forces
;; find-file-not-found-set-buffer-file-coding-system to ignore
;; the file's name (see dos-w32.el).
(setq archive-file-name-coding-system file-name-coding)
(if (and
(null
- (let (;; We may have to encode file name arguement for
+ (let (;; We may have to encode the file name argument for
;; external programs.
(coding-system-for-write
(and enable-multibyte-characters
;; We will write out the archive ourselves if it is
;; part of another archive.
(remove-hook 'write-contents-functions 'archive-write-file t))
- (run-hooks 'archive-extract-hooks)
+ (run-hooks 'archive-extract-hook)
(if archive-read-only
(message "Note: altering this archive is not implemented."))))
(archive-maybe-update t))
(or (not (buffer-name buffer))
(cond
- (view-p (view-buffer
- buffer (and just-created 'kill-buffer-if-not-modified)))
+ (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))))))
(archive-delete-local tmpfile)
success))
-(defun archive-extract-by-stdout (archive name command)
- (apply 'call-process
- (car command)
- nil
- t
- nil
- (append (cdr command) (list archive name))))
+(defun archive-extract-by-stdout (archive name command &optional stderr-test)
+ (let ((stderr-file (make-temp-file "arc-stderr")))
+ (unwind-protect
+ (prog1
+ (apply 'call-process
+ (car command)
+ nil
+ (if stderr-file (list t stderr-file) t)
+ nil
+ (append (cdr command) (list archive name)))
+ (with-temp-buffer
+ (insert-file-contents stderr-file)
+ (goto-char (point-min))
+ (when (if (stringp stderr-test)
+ (not (re-search-forward stderr-test nil t))
+ (> (buffer-size) 0))
+ (message "%s" (buffer-string)))))
+ (if (file-exists-p stderr-file)
+ (delete-file stderr-file)))))
+
+(defun archive-extract-by-file (archive name command &optional stdout-test)
+ (let ((dest (make-temp-file "arc-dir" 'dir))
+ (stdout-file (make-temp-file "arc-stdout")))
+ (unwind-protect
+ (prog1
+ (apply 'call-process
+ (car command)
+ nil
+ `(:file ,stdout-file)
+ nil
+ (append (cdr command) (list archive name dest)))
+ (with-temp-buffer
+ (insert-file-contents stdout-file)
+ (goto-char (point-min))
+ (when (if (stringp stdout-test)
+ (not (re-search-forward stdout-test nil t))
+ (> (buffer-size) 0))
+ (message "%s" (buffer-string))))
+ (if (file-exists-p (expand-file-name name dest))
+ (insert-file-contents-literally (expand-file-name name dest))))
+ (if (file-exists-p stdout-file)
+ (delete-file stdout-file))
+ (if (file-exists-p (expand-file-name name dest))
+ (delete-file (expand-file-name name dest)))
+ (while (file-name-directory name)
+ (setq name (directory-file-name (file-name-directory name)))
+ (when (file-directory-p (expand-file-name name dest))
+ (delete-directory (expand-file-name name dest))))
+ (when (file-directory-p dest)
+ (delete-directory dest)))))
(defun archive-extract-other-window ()
"In archive mode, find this member in another window."
(error "Renaming is not supported for this archive type"))))
;; Revert the buffer and recompute the dired-like listing.
-(defun archive-mode-revert (&optional no-auto-save no-confirm)
+(defun archive-mode-revert (&optional _no-auto-save _no-confirm)
(let ((no (archive-get-lineno)))
(setq archive-files nil)
(let ((revert-buffer-function nil)
(apply 'vector (nreverse files))))
(defun archive-zip-extract (archive name)
- (if (member-ignore-case (car archive-zip-extract) '("pkunzip" "pkzip"))
- (archive-*-extract archive name archive-zip-extract)
+ (cond
+ ((member-ignore-case (car archive-zip-extract) '("pkunzip" "pkzip"))
+ (archive-*-extract archive name archive-zip-extract))
+ ((equal (car archive-zip-extract) archive-7z-program)
+ (let ((archive-7z-extract archive-zip-extract))
+ (archive-7z-extract archive name)))
+ (t
(archive-extract-by-stdout
archive
;; unzip expands wildcards in NAME, so we need to quote it. But
;; not on DOS/Windows, since that fails extraction on those
- ;; systems, and file names with wildcards in zip archives don't
- ;; work there anyway.
+ ;; systems (unless w32-quote-process-args is nil), and file names
+ ;; with wildcards in zip archives don't work there anyway.
;; FIXME: Does pkunzip need similar treatment?
- (if (and (not (memq system-type '(windows-nt ms-dos)))
+ (if (and (or (not (memq system-type '(windows-nt ms-dos)))
+ (and (boundp 'w32-quote-process-args)
+ (null w32-quote-process-args)))
(equal (car archive-zip-extract) "unzip"))
(shell-quote-argument name)
name)
- archive-zip-extract)))
+ archive-zip-extract))))
(defun archive-zip-write-file-member (archive descr)
(archive-*-write-file-member
;; The code below assumes the name is relative and may do undesirable
;; things otherwise.
(error "Can't extract files with non-relative names")
- (let ((dest (make-temp-file "arc-rar" 'dir)))
- (unwind-protect
- (progn
- (call-process "unrar-free" nil nil nil
- "--extract" archive name dest)
- (insert-file-contents-literally (expand-file-name name dest)))
- (delete-file (expand-file-name name dest))
- (while (file-name-directory name)
- (setq name (directory-file-name (file-name-directory name)))
- (delete-directory (expand-file-name name dest)))
- (delete-directory dest)))))
+ (archive-extract-by-file archive name '("unrar-free" "--extract") "All OK")))
;;; Section: Rar self-extracting .exe archives.
(if tmpbuf (kill-buffer tmpbuf))
(delete-file tmpfile))))
+;; -------------------------------------------------------------------------
+;;; Section: 7z Archives
+
+(defun archive-7z-summarize ()
+ (let ((maxname 10)
+ (maxsize 5)
+ (file buffer-file-name)
+ (files ()))
+ (with-temp-buffer
+ (call-process archive-7z-program nil t nil "l" "-slt" file)
+ (goto-char (point-min))
+ ;; Four dashes start the meta info section that should be skipped.
+ ;; Archive members start with more than four dashes.
+ (re-search-forward "^-----+\n")
+ (while (re-search-forward "^Path = \\(.*\\)\n" nil t)
+ (goto-char (match-end 0))
+ (let ((name (match-string 1))
+ (size (save-excursion
+ (and (re-search-forward "^Size = \\(.*\\)\n")
+ (match-string 1))))
+ (time (save-excursion
+ (and (re-search-forward "^Modified = \\(.*\\)\n")
+ (match-string 1)))))
+ (if (> (length name) maxname) (setq maxname (length name)))
+ (if (> (length size) maxsize) (setq maxsize (length size)))
+ (push (vector name name nil nil time nil nil size)
+ files))))
+ (setq files (nreverse files))
+ (goto-char (point-min))
+ (let* ((format (format " %%%ds %%s %%s" maxsize))
+ (sep (format format (make-string maxsize ?-) "-------------------" ""))
+ (column (length sep)))
+ (insert (format format "Size " "Date Time " " Filename") "\n")
+ (insert sep (make-string maxname ?-) "\n")
+ (archive-summarize-files (mapcar (lambda (desc)
+ (let ((text
+ (format format
+ (aref desc 7)
+ (aref desc 4)
+ (aref desc 1))))
+ (vector text
+ column
+ (length text))))
+ files))
+ (insert sep (make-string maxname ?-) "\n")
+ (apply 'vector files))))
+
+(defun archive-7z-extract (archive name)
+ ;; 7z doesn't provide a `quiet' option to suppress non-essential
+ ;; stderr messages. So redirect stderr to a temp file and display it
+ ;; in the echo area when it contains no message indicating success.
+ (archive-extract-by-stdout
+ archive name archive-7z-extract "Everything is Ok"))
+
+(defun archive-7z-write-file-member (archive descr)
+ (archive-*-write-file-member
+ archive
+ descr
+ archive-7z-update))
+;; -------------------------------------------------------------------------
;;; Section `ar' archives.
;; TODO: we currently only handle the basic format of ar archives,
(provide 'arc-mode)
-;; arch-tag: e5966a01-35ec-4f27-8095-a043a79b457b
;;; arc-mode.el ends here
HCoop / bpt / emacs.git / blobdiff