;;; arc-mode.el --- simple editing of archives
-;; Copyright (C) 1995, 1997-1998, 2001-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
;; interaction among members.
;; 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
(cond ((executable-find "unzip") '("unzip" "-qq" "-c"))
- ((executable-find "7z") '("7z" "x" "-so"))
+ (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.
(defcustom archive-zip-expunge
(cond ((executable-find "zip") '("zip" "-d" "-q"))
- ((executable-find "7z") '("7z" "d"))
+ (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.
(defcustom archive-zip-update
(cond ((executable-find "zip") '("zip" "-q"))
- ((executable-find "7z") '("7z" "u"))
+ (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.
(defcustom archive-zip-update-case
(cond ((executable-find "zip") '("zip" "-q" "-k"))
- ((executable-find "7z") '("7z" "u"))
+ (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.
;; 7z archive configuration
(defcustom archive-7z-extract
- '("7z" "x" "-so")
+ `(,(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
:group 'archive-7z)
(defcustom archive-7z-expunge
- '("7z" "d")
+ `(,(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
:group 'archive-7z)
(defcustom archive-7z-update
- '("7z" "u")
+ `(,(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
(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."
;; 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.
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
(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).
;; 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))
(archive-delete-local tmpfile)
success))
-(defun archive-extract-by-stdout (archive name command &optional stderr-file)
- (apply 'call-process
- (car command)
- nil
- (if stderr-file (list t stderr-file) 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."
(cond
((member-ignore-case (car archive-zip-extract) '("pkunzip" "pkzip"))
(archive-*-extract archive name archive-zip-extract))
- ((equal (car archive-zip-extract) "7z")
+ ((equal (car archive-zip-extract) archive-7z-program)
(let ((archive-7z-extract archive-zip-extract))
(archive-7z-extract archive name)))
(t
;; 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.
(file buffer-file-name)
(files ()))
(with-temp-buffer
- (call-process "7z" nil t nil "l" "-slt" file)
+ (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.
(apply 'vector files))))
(defun archive-7z-extract (archive name)
- (let ((tmpfile (make-temp-file "7z-stderr")))
- ;; 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 error messages.
- (prog1 (archive-extract-by-stdout
- archive name archive-7z-extract tmpfile)
- (with-temp-buffer
- (insert-file-contents tmpfile)
- (unless (search-forward "Everything is Ok" nil t)
- (message "%s" (buffer-string)))
- (delete-file tmpfile)))))
+ ;; 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
HCoop / bpt / emacs.git / blobdiff