X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/0bfcf5c598d7c351591827b14482253adf9ab015..1040099b36b5df41453e7de9c9d9bf129c493c31:/lisp/arc-mode.el diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index c776a3f8b5..37ddf87cfb 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -1,6 +1,7 @@ ;;; 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 ;; Keywords: files archives msdog editing major-mode @@ -77,7 +78,7 @@ ;; 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 @@ -96,7 +97,7 @@ ;; ;; archive-mode-hook ;; archive-foo-mode-hook -;; archive-extract-hooks +;; archive-extract-hook ;;; Code: @@ -140,8 +141,10 @@ A local copy of the archive will be used when updating." :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) ;; ------------------------------ @@ -215,9 +218,14 @@ Archive and member name will be added." ;; ------------------------------ ;; 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. @@ -236,7 +244,7 @@ be added." (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. @@ -249,7 +257,7 @@ Archive and member names will be added." (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. @@ -263,7 +271,7 @@ file. Archive and member name will be added." (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. @@ -318,7 +326,7 @@ Archive and member name will be added." ;; 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." @@ -330,7 +338,7 @@ be added." :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" @@ -341,7 +349,7 @@ Archive and member names will be added." :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." @@ -675,9 +683,9 @@ archive. ;; 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) @@ -686,9 +694,7 @@ archive. (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) @@ -755,7 +761,7 @@ archive. ((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. @@ -787,7 +793,8 @@ is visible (and the real data of the buffer is hidden). 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 @@ -971,11 +978,6 @@ using `make-temp-file', and the generated name is returned." (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). @@ -1077,7 +1079,7 @@ using `make-temp-file', and the generated name is returned." ;; 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)) @@ -1117,13 +1119,56 @@ using `make-temp-file', and the generated name is returned." (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." @@ -1826,7 +1871,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (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 @@ -2006,17 +2051,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." ;; 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. @@ -2060,7 +2095,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (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. @@ -2099,17 +2134,11 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (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