Mercurial > hg > xemacs-beta

changeset 5534:68db75473fc6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge.
author Mats Lidell <mats.lidell@cag.se>
date Sun, 07 Aug 2011 23:22:59 +0200
parents 69a08906ad27 (current diff) 11da5b828d10 (diff)
children 25325da1d1a8
files lisp/ChangeLog tests/ChangeLog
diffstat 4 files changed, 245 insertions(+), 83 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/ChangeLog	Wed Jul 20 00:42:16 2011 +0200
+++ b/lisp/ChangeLog	Sun Aug 07 23:22:59 2011 +0200
@@ -1,5 +1,9 @@
+2011-07-29  Mats Lidell  <matsl@xemacs.org>
+	* process.el (shell-command): 
+	* process.el (shell-command-on-region): API compatible/synced with
+	FSF 23.3.1.
+
 2011-07-22  Mats Lidell  <matsl@xemacs.or>
-
 	* syntax-ppss.el: Synced up with Emacs 23.3 (syntax.el)
 
 2011-07-03  Aidan Kehoe  <kehoea@parhasard.net>
--- a/lisp/process.el	Wed Jul 20 00:42:16 2011 +0200
+++ b/lisp/process.el	Sun Aug 07 23:22:59 2011 +0200
@@ -1,6 +1,6 @@
 ;;; process.el --- commands for subprocesses; split out of simple.el
 
-;; Copyright (C) 1985-7, 1993,4, 1997 Free Software Foundation, Inc.
+;; Copyright (C) 1985-7, 1993,4, 1997, 2011 Free Software Foundation, Inc.
 ;; Copyright (C) 1995, 2000, 2001, 2002 Ben Wing.
 
 ;; Author: Ben Wing
@@ -24,6 +24,7 @@
 
 ;;; Synched up with: FSF 19.30, except for setenv/getenv (synched with FSF
 ;;; 21.2.1).
+;;; shell-command and shell-command-on-region synced with FSF 23.3.1.
 
 ;;; Authorship:
 
@@ -57,6 +58,12 @@
 (defvar shell-command-switch "-c"
   "Switch used to have the shell execute its command line argument.")
 
+(defvar shell-command-default-error-buffer nil
+  "*Buffer name for `shell-command' and `shell-command-on-region' error output.
+This buffer is used when `shell-command' or `shell-command-on-region'
+is run interactively.  A value of nil means that output to stderr and
+stdout will be intermixed in the output stream.")
+
 (defun start-process-shell-command (name buffer &rest args)
   "Start a program in a subprocess.  Return the process object for it.
 NAME is name for process.  It is modified if necessary to make it unique.
@@ -316,12 +323,12 @@
 	(error nil)))))
 
 
-(defun shell-command (command &optional output-buffer)
+(defun shell-command (command &optional output-buffer error-buffer)
   "Execute string COMMAND in inferior shell; display output, if any.
 
-If COMMAND ends in ampersand, execute it asynchronously.
-The output appears in the buffer `*Async Shell Command*'.
-That buffer is in shell mode.
+If COMMAND ends in ampersand, execute it asynchronously.  The command
+is executed using the background package. See `background' for
+details.
 
 Otherwise, COMMAND is executed synchronously.  The output appears in the
 buffer `*Shell Command Output*'.
@@ -336,9 +343,16 @@
 If OUTPUT-BUFFER is a buffer or buffer name, put the output there.
 If OUTPUT-BUFFER is not a buffer and not nil,
 insert output in current buffer.  (This cannot be done asynchronously.)
-In either case, the output is inserted after point (leaving mark after it)."
+In either case, the output is inserted after point (leaving mark after it).
+
+If the optional third argument ERROR-BUFFER is non-nil, it is a buffer
+or buffer name to which to direct the command's standard error output.
+If it is nil, error output is mingled with regular output.  In an
+interactive call, the variable `shell-command-default-error-buffer'
+specifies the value of ERROR-BUFFER."
   (interactive (list (read-shell-command "Shell command: ")
-		     current-prefix-arg))
+		     current-prefix-arg
+		     shell-command-default-error-buffer))
   (if (and output-buffer
 	   (not (or (bufferp output-buffer)  (stringp output-buffer))))
       (progn (barf-if-buffer-read-only)
@@ -363,7 +377,7 @@
 	       'unimplemented
 	       "backgrounding a shell command requires package `background'")))
 	    
-	(shell-command-on-region (point) (point) command output-buffer)))))
+	(shell-command-on-region (point) (point) command output-buffer nil error-buffer)))))
 
 ;; We have a sentinel to prevent insertion of a termination message
 ;; in the buffer itself.
@@ -374,7 +388,8 @@
 	       (substring signal 0 -1))))
 
 (defun shell-command-on-region (start end command
-				      &optional output-buffer replace)
+				      &optional output-buffer replace
+				      error-buffer display-error-buffer)
   "Execute string COMMAND in inferior shell with region as input.
 Normally display output (if any) in temp buffer `*Shell Command Output*';
 Prefix arg means replace the region with it.
@@ -394,7 +409,15 @@
 If OUTPUT-BUFFER is a buffer or buffer name, put the output there.
 If OUTPUT-BUFFER is not a buffer and not nil,
 insert output in the current buffer.
-In either case, the output is inserted after point (leaving mark after it)."
+In either case, the output is inserted after point (leaving mark after it).
+
+If optional sixth argument ERROR-BUFFER is non-nil, it is a buffer
+or buffer name to which to direct the command's standard error output.
+If it is nil, error output is mingled with regular output.
+If DISPLAY-ERROR-BUFFER is non-nil, display the error buffer if there
+were any errors.  (This is always t, interactively.)
+In an interactive call, the variable `shell-command-default-error-buffer'
+specifies the value of ERROR-BUFFER."
   (interactive (let ((string
 		      ;; Do this before calling region-beginning
 		      ;; and region-end, in case subprocess output
@@ -405,79 +428,142 @@
 		 (list (region-beginning) (region-end)
 		       string
 		       current-prefix-arg
-		       current-prefix-arg)))
-  (if (or replace
-	  (and output-buffer
-	       (not (or (bufferp output-buffer) (stringp output-buffer)))))
-      ;; Replace specified region with output from command.
-      (let ((swap (and replace (< start end))))
-	;; Don't muck with mark unless REPLACE says we should.
-	(goto-char start)
-	(and replace (push-mark))
-	(call-process-region start end shell-file-name t t nil
-			     shell-command-switch command)
-	(let ((shell-buffer (get-buffer "*Shell Command Output*")))
-	  (and shell-buffer (not (eq shell-buffer (current-buffer)))
-	       (kill-buffer shell-buffer)))
-	;; Don't muck with mark unless REPLACE says we should.
-	(and replace swap (exchange-point-and-mark t)))
+		       current-prefix-arg
+		       shell-command-default-error-buffer
+		       t)))
+  (let ((error-file
+	 (if error-buffer
+	     (make-temp-file
+	      (expand-file-name "scor"
+				(or small-temporary-file-directory
+				    (temp-directory))))
+	   nil))
+	(exit-status nil))
+    (if (or replace
+	    (and output-buffer
+		 (not (or (bufferp output-buffer) (stringp output-buffer)))))
+	;; Replace specified region with output from command.
+	(let ((swap (and replace (< start end))))
+	  ;; Don't muck with mark unless REPLACE says we should.
+	  (goto-char start)
+	  (and replace (push-mark))
+	  (setq exit-status (call-process-region start end shell-file-name t 
+						 (if error-file
+						     (list t error-file)
+						   t)
+						 nil shell-command-switch command))
+	  (let ((shell-buffer (get-buffer "*Shell Command Output*")))
+	    (and shell-buffer (nnot (eq shell-buffer (current-buffer)))
+		 (kill-buffer shell-buffer)))
+	  ;; Don't muck with mark unless REPLACE says we should.
+	  (and replace swap (exchange-point-and-mark t)))
       ;; No prefix argument: put the output in a temp buffer,
       ;; replacing its entire contents.
-    (let ((buffer (get-buffer-create
-		   (or output-buffer "*Shell Command Output*")))
-	  (success nil)
-	  (exit-status nil)
-	  (directory default-directory))
-      (unwind-protect
-	  (if (eq buffer (current-buffer))
-	      ;; If the input is the same buffer as the output,
-	      ;; delete everything but the specified region,
-	      ;; then replace that region with the output.
-	      (progn (setq buffer-read-only nil)
-		     (delete-region (max start end) (point-max))
-		     (delete-region (point-min) (min start end))
-		     (setq exit-status
-			   (call-process-region (point-min) (point-max)
-						shell-file-name t t nil
-						shell-command-switch command))
-		     (setq success t))
-	    ;; Clear the output buffer,
-	    ;; then run the command with output there.
-	    (save-excursion
-	      (set-buffer buffer)
-	      (setq buffer-read-only nil)
-	      ;; XEmacs change
-	      (setq default-directory directory)
-	      (erase-buffer))
-	    (setq exit-status
-		  (call-process-region start end shell-file-name
-				       nil buffer nil
-				       shell-command-switch command))
-	    (setq success t))
-	;; Report the amount of output.
-	(let ((lines (save-excursion
-		       (set-buffer buffer)
-		       (if (= (buffer-size) 0)
-			   0
-			 (count-lines (point-min) (point-max))))))
-	  (cond ((= lines 0)
-		 (if success
-		     (display-message
-		      'command
-		      (if (eql exit-status 0)
-			  "(Shell command succeeded with no output)"
-			"(Shell command failed with no output)")))
-		 (kill-buffer buffer))
-		((and success (= lines 1))
-		 (message "%s"
-			  (save-excursion
-			    (set-buffer buffer)
-			    (goto-char (point-min))
-			    (buffer-substring (point)
-					      (progn (end-of-line)
-						     (point))))))
-		(t
-		 (set-window-start (display-buffer buffer) 1))))))))
+      (let ((buffer (get-buffer-create
+		     (or output-buffer "*Shell Command Output*")))
+	    (directory default-directory))
+	(unwind-protect
+	    (if (eq buffer (current-buffer))
+		;; If the input is the same buffer as the output,
+		;; delete everything but the specified region,
+		;; then replace that region with the output.
+		(progn (setq buffer-read-only nil)
+		       (delete-region (max start end) (point-max))
+		       (delete-region (point-min) (min start end))
+		       (setq exit-status
+			     (call-process-region (point-min) (point-max)
+						  shell-file-name t 
+						  (if error-file
+						      (list t error-file)
+						    t)
+						  nil shell-command-switch 
+						  command)))
+	      ;; Clear the output buffer,
+	      ;; then run the command with output there.
+	      (save-excursion
+		(set-buffer buffer)
+		(setq buffer-read-only nil)
+		;; XEmacs change
+		(setq default-directory directory)
+		(erase-buffer))
+	      (setq exit-status
+		    (call-process-region start end shell-file-name
+					 nil 
+					 (if error-file
+					     (list buffer error-file)
+					   buffer)
+					 nil shell-command-switch command)))
+
+	  ;; Report the output.
+	  (with-current-buffer buffer
+	    (setq modeline-process
+		  (cond ((null exit-status)
+			 " - Error")
+			((stringp exit-status)
+			 (format " - Signal [%s]" exit-status))
+			((not (equal 0 exit-status))
+			 (format " - Exit [%d]" exit-status)))))
+	  (if (with-current-buffer buffer (> (point-max) (point-min)))
+	      ;; There's some output, display it
+	      (let ((lines (save-excursion
+			     (set-buffer buffer)
+			     (if (= (buffer-size) 0)
+				 0
+			       (count-lines (point-min) (point-max))))))
+		(cond ((= lines 0)
+		       (display-message
+			   'command
+			 (if (eql exit-status 0)
+			     "(Shell command succeeded with no output)"
+			   "(Shell command failed with no output)"))
+		       (kill-buffer buffer))
+		      ((= lines 1)
+		       (message "%s"
+				(save-excursion
+				  (set-buffer buffer)
+				  (goto-char (point-min))
+				  (buffer-substring (point)
+						    (progn (end-of-line)
+							   (point))))))
+		      (t
+		       (set-window-start (display-buffer buffer) 1))))
+	    ;; No output; error?
+	    (let ((output
+		   (if (and error-file
+			    (< 0 (nth 7 (file-attributes error-file))))
+		       "some error output"
+		     "no output")))
+	      (cond ((null exit-status)
+		     (message "(Shell command failed with error)"))
+		    ((equal 0 exit-status)
+		     (message "(Shell command succeeded with %s)"
+			      output))
+		    ((stringp exit-status)
+		     (message "(Shell command killed by signal %s)"
+			      exit-status))
+		    (t
+		     (message "(Shell command failed with code %d and %s)"
+			      exit-status output))))
+	    ;; Don't kill: there might be useful info in the undo-log.
+	    ;; (kill-buffer buffer)
+	    ))))
+
+    (when (and error-file (file-exists-p error-file))
+      (if (< 0 (nth 7 (file-attributes error-file)))
+	  (with-current-buffer (get-buffer-create error-buffer)
+	    (let ((pos-from-end (- (point-max) (point))))
+	      (or (bobp)
+		  (insert "\f\n"))
+	      ;; Do no formatting while reading error file,
+	      ;; because that can run a shell command, and we
+	      ;; don't want that to cause an infinite recursion.
+	      (format-insert-file error-file nil)
+	      ;; Put point after the inserted errors.
+	      (goto-char (- (point-max) pos-from-end)))
+	    (and display-error-buffer
+		 (display-buffer (current-buffer)))))
+      (delete-file error-file))
+    exit-status))
 
 (defun shell-quote-argument (argument)
   "Quote an argument for passing as argument to an inferior shell."
--- a/tests/ChangeLog	Wed Jul 20 00:42:16 2011 +0200
+++ b/tests/ChangeLog	Sun Aug 07 23:22:59 2011 +0200
@@ -1,5 +1,7 @@
+2011-07-31  Mats Lidell  <matsl@xemacs.org>
+	* automated/process-tests.el: shell-command tests.
+	
 2011-07-22  Mats Lidell  <matsl@xemacs.org>
-
 	* automated/syntax-ppss-tests.el: Add tests for syntax-ppss.el.
 
 2011-06-28  Aidan Kehoe  <kehoea@parhasard.net>
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/automated/process-tests.el	Sun Aug 07 23:22:59 2011 +0200
@@ -0,0 +1,70 @@
+;; Copyright (C) 2011 Free Software Foundation, Inc.
+
+;; Author: Mats Lidell <matsl@xemacs.org>
+;; Maintainer: 
+;; Created: 2011
+;; Keywords: tests
+
+;; This file is part of XEmacs.
+
+;; XEmacs is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the
+;; Free Software Foundation, either version 3 of the License, or (at your
+;; option) any later version.
+
+;; XEmacs is distributed in the hope that it will be useful, but WITHOUT
+;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+;; for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with XEmacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Synched up with: Not in FSF.
+
+;;; Commentary:
+
+;; Test tag support.
+;; See test-harness.el for instructions on how to run these tests.
+
+(require 'test-harness)
+
+(when (equal system-type 'linux)
+  (setenv "LANG" "C")
+  
+  ;; One line output
+  (Assert (= 0 (shell-command "echo hello")))
+  (Assert (equal "hello" (message-displayed-p t)))
+  (with-current-buffer " *Echo Area*"
+    (goto-char (point-min))
+    (Assert (looking-at "hello")))
+
+  ;; Two lines. No output in echo area. (GNU resizes minibuffer but we
+  ;; haven't implemented that.)
+  (message "")
+  (Assert (= 0 (shell-command "echo -e \"foo\nbar\n\"")))
+  (with-current-buffer " *Echo Area*"
+    (Assert (= 0 (buffer-size))))
+  (with-current-buffer "*Shell Command Output*"
+    (goto-char (point-min))
+    (Assert (looking-at "foo"))):
+
+  (Assert (= 127 (shell-command "unknown_command")))
+  (Assert (= 2 (shell-command "exit 2")))
+  (Assert (equal "(Shell command failed with code 2 and no output)" (message-displayed-p t)))
+  
+  ;; Output to stderr With error buffer
+  (Assert (= 0 (shell-command "echo -e \"foo\nbar\n\" 1>&2" "Output buffer" "Error buffer")))
+  (Assert (equal "(Shell command succeeded with some error output)" (message-displayed-p t)))
+  (with-current-buffer "Error buffer" 
+    (goto-char (point-min))
+    (Assert (looking-at "foo")))
+  (with-current-buffer "Output buffer" 
+    (Assert (= 0 (buffer-size))))
+
+  ;; Output to stderr but no error buffer
+  (Assert (= 0 (shell-command "echo -e \"foobar\nfoobar\n\" 1>&2" "Output buffer")))
+  (with-current-buffer "Output buffer" 
+    (goto-char (point-min))
+    (Assert (looking-at "foobar")))
+)