Minor fixes in w32-shell-execute.

[gnu-emacs] / lisp / arc-mode.el

diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el
index c776a3f8b5ce11a2149d7d6a6e53ad4d417db613..4683532c4a4876324ee3d5947090b83ab5c23188 100644 (file)
--- a/lisp/arc-mode.el
+++ b/lisp/arc-mode.el
@@ -1,6 +1,6 @@
 ;;; arc-mode.el --- simple editing of archives
 
 ;;; arc-mode.el --- simple editing of archives
 

-;; Copyright (C) 1995, 1997-1998, 2001-2012  Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1997-1998, 2001-2013 Free Software Foundation, Inc.

 
 ;; Author: Morten Welinder <terra@gnu.org>
 ;; Keywords: files archives msdog editing major-mode
 
 ;; Author: Morten Welinder <terra@gnu.org>
 ;; Keywords: files archives msdog editing major-mode


@@ -96,7 +96,7 @@
 ;;
 ;; archive-mode-hook
 ;; archive-foo-mode-hook
 ;;
 ;; archive-mode-hook
 ;; archive-foo-mode-hook

-;; archive-extract-hooks
+;; archive-extract-hook

 
 ;;; Code:
 
 
 ;;; Code:
 


@@ -140,8 +140,10 @@ A local copy of the archive will be used when updating."
   :type 'regexp
   :group 'archive)
 
   :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)
 ;; ------------------------------
   :type 'hook
   :group 'archive)
 ;; ------------------------------


@@ -215,9 +217,14 @@ Archive and member name will be added."
 ;; ------------------------------
 ;; Zip archive configuration
 
 ;; ------------------------------
 ;; 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"))
 (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.
        ((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 +243,7 @@ be added."
 
 (defcustom archive-zip-expunge
   (cond ((executable-find "zip")     '("zip" "-d" "-q"))
 
 (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.
        ((executable-find "pkzip")   '("pkzip" "-d"))
        (t                           '("zip" "-d" "-q")))
   "Program and its options to run in order to delete zip file members.


@@ -249,7 +256,7 @@ Archive and member names will be added."
 
 (defcustom archive-zip-update
   (cond ((executable-find "zip")     '("zip" "-q"))
 
 (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.
        ((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 +270,7 @@ file.  Archive and member name will be added."
 
 (defcustom archive-zip-update-case
   (cond ((executable-find "zip")     '("zip" "-q" "-k"))
 
 (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.
        ((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 +325,7 @@ Archive and member name will be added."
 ;; 7z archive configuration
 
 (defcustom archive-7z-extract
 ;; 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."
   "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 +337,7 @@ be added."
   :group 'archive-7z)
 
 (defcustom archive-7z-expunge
   :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"
   "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 +348,7 @@ Archive and member names will be added."
   :group 'archive-7z)
 
 (defcustom archive-7z-update
   :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."
   "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 +682,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
       ;; 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))))
       (let* ((type (archive-find-type))
             (typename (capitalize (symbol-name type))))

-       (kill-all-local-variables)

        (make-local-variable 'archive-subtype)
        (setq archive-subtype type)
 
        (make-local-variable 'archive-subtype)
        (setq archive-subtype type)
 


@@ -686,9 +693,7 @@ archive.
        (setq revert-buffer-function 'archive-mode-revert)
        (auto-save-mode 0)
 
        (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)
 
        (make-local-variable 'require-final-newline)
        (setq require-final-newline nil)


@@ -755,7 +760,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
          ((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.
                              (or buffer-file-name (buffer-name))))
           'arc)
           ;; This pattern modeled on the BSD/GNU+Linux `file' command.


@@ -787,7 +792,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)
 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
     (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 +977,6 @@ using `make-temp-file', and the generated name is returned."
                    (save-excursion
                      (funcall set-auto-coding-function
                               filename (- (point-max) (point-min)))))
                    (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).
               ;; 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 +1078,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))
               ;; 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))
            (if archive-read-only
                (message "Note: altering this archive is not implemented."))))
        (archive-maybe-update t))


@@ -1117,13 +1118,56 @@ using `make-temp-file', and the generated name is returned."
     (archive-delete-local tmpfile)
     success))
 
     (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."
 
 (defun archive-extract-other-window ()
   "In archive mode, find this member in another window."


@@ -1826,7 +1870,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))
   (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
     (let ((archive-7z-extract archive-zip-extract))
       (archive-7z-extract archive name)))
    (t


@@ -2006,17 +2050,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")
       ;; 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.
 
 
 ;;; Section: Rar self-extracting .exe archives.
 


@@ -2060,7 +2094,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
        (file buffer-file-name)
        (files ()))
     (with-temp-buffer
        (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.
       (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 +2133,11 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
       (apply 'vector files))))
 
 (defun archive-7z-extract (archive name)
       (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
 
 (defun archive-7z-write-file-member (archive descr)
   (archive-*-write-file-member