Mercurial > hg > xemacs-beta

comparison lisp/process.el @ 5533:11da5b828d10

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
shell-command and shell-command-on-region API compliant with FSF 23.3.1
author Mats Lidell <mats.lidell@cag.se>
date Sun, 31 Jul 2011 01:29:09 +0200
parents 308d34e9f07d
children a39cd9dc92ba
comparison
equal deleted inserted replaced
5531:1b054bc2ac40 5533:11da5b828d10
1 ;;; process.el --- commands for subprocesses; split out of simple.el 1 ;;; process.el --- commands for subprocesses; split out of simple.el
2 2
3 ;; Copyright (C) 1985-7, 1993,4, 1997 Free Software Foundation, Inc. 3 ;; Copyright (C) 1985-7, 1993,4, 1997, 2011 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995, 2000, 2001, 2002 Ben Wing. 4 ;; Copyright (C) 1995, 2000, 2001, 2002 Ben Wing.
5 5
6 ;; Author: Ben Wing 6 ;; Author: Ben Wing
7 ;; Maintainer: XEmacs Development Team 7 ;; Maintainer: XEmacs Development Team
8 ;; Keywords: internal, processes, dumped 8 ;; Keywords: internal, processes, dumped
22 ;; You should have received a copy of the GNU General Public License 22 ;; You should have received a copy of the GNU General Public License
23 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. 23 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>.
24 24
25 ;;; Synched up with: FSF 19.30, except for setenv/getenv (synched with FSF 25 ;;; Synched up with: FSF 19.30, except for setenv/getenv (synched with FSF
26 ;;; 21.2.1). 26 ;;; 21.2.1).
27 ;;; shell-command and shell-command-on-region synced with FSF 23.3.1.
27 28
28 ;;; Authorship: 29 ;;; Authorship:
29 30
30 ;; Created 1995 by Ben Wing during Mule work -- some commands split out 31 ;; Created 1995 by Ben Wing during Mule work -- some commands split out
31 ;; of simple.el and wrappers of *-internal functions created so they could 32 ;; of simple.el and wrappers of *-internal functions created so they could
54 55
55 ;; This may be changed to "/c" in win32-native.el. 56 ;; This may be changed to "/c" in win32-native.el.
56 57
57 (defvar shell-command-switch "-c" 58 (defvar shell-command-switch "-c"
58 "Switch used to have the shell execute its command line argument.") 59 "Switch used to have the shell execute its command line argument.")
60
61 (defvar shell-command-default-error-buffer nil
62 "*Buffer name for `shell-command' and `shell-command-on-region' error output.
63 This buffer is used when `shell-command' or `shell-command-on-region'
64 is run interactively. A value of nil means that output to stderr and
65 stdout will be intermixed in the output stream.")
59 66
60 (defun start-process-shell-command (name buffer &rest args) 67 (defun start-process-shell-command (name buffer &rest args)
61 "Start a program in a subprocess. Return the process object for it. 68 "Start a program in a subprocess. Return the process object for it.
62 NAME is name for process. It is modified if necessary to make it unique. 69 NAME is name for process. It is modified if necessary to make it unique.
63 BUFFER is the buffer or (buffer-name) to associate with the process. 70 BUFFER is the buffer or (buffer-name) to associate with the process.
314 (condition-case nil 321 (condition-case nil
315 (if (and proc (process-live-p proc)) (kill-process proc)) 322 (if (and proc (process-live-p proc)) (kill-process proc))
316 (error nil))))) 323 (error nil)))))
317 324
318 325
319 (defun shell-command (command &optional output-buffer) 326 (defun shell-command (command &optional output-buffer error-buffer)
320 "Execute string COMMAND in inferior shell; display output, if any. 327 "Execute string COMMAND in inferior shell; display output, if any.
321 328
322 If COMMAND ends in ampersand, execute it asynchronously. 329 If COMMAND ends in ampersand, execute it asynchronously. The command
323 The output appears in the buffer `*Async Shell Command*'. 330 is executed using the background package. See `background' for
324 That buffer is in shell mode. 331 details.
325 332
326 Otherwise, COMMAND is executed synchronously. The output appears in the 333 Otherwise, COMMAND is executed synchronously. The output appears in the
327 buffer `*Shell Command Output*'. 334 buffer `*Shell Command Output*'.
328 If the output is one line, it is displayed in the echo area *as well*, 335 If the output is one line, it is displayed in the echo area *as well*,
329 but it is nonetheless available in buffer `*Shell Command Output*', 336 but it is nonetheless available in buffer `*Shell Command Output*',
334 The optional second argument OUTPUT-BUFFER, if non-nil, 341 The optional second argument OUTPUT-BUFFER, if non-nil,
335 says to put the output in some other buffer. 342 says to put the output in some other buffer.
336 If OUTPUT-BUFFER is a buffer or buffer name, put the output there. 343 If OUTPUT-BUFFER is a buffer or buffer name, put the output there.
337 If OUTPUT-BUFFER is not a buffer and not nil, 344 If OUTPUT-BUFFER is not a buffer and not nil,
338 insert output in current buffer. (This cannot be done asynchronously.) 345 insert output in current buffer. (This cannot be done asynchronously.)
339 In either case, the output is inserted after point (leaving mark after it)." 346 In either case, the output is inserted after point (leaving mark after it).
347
348 If the optional third argument ERROR-BUFFER is non-nil, it is a buffer
349 or buffer name to which to direct the command's standard error output.
350 If it is nil, error output is mingled with regular output. In an
351 interactive call, the variable `shell-command-default-error-buffer'
352 specifies the value of ERROR-BUFFER."
340 (interactive (list (read-shell-command "Shell command: ") 353 (interactive (list (read-shell-command "Shell command: ")
341 current-prefix-arg)) 354 current-prefix-arg
355 shell-command-default-error-buffer))
342 (if (and output-buffer 356 (if (and output-buffer
343 (not (or (bufferp output-buffer) (stringp output-buffer)))) 357 (not (or (bufferp output-buffer) (stringp output-buffer))))
344 (progn (barf-if-buffer-read-only) 358 (progn (barf-if-buffer-read-only)
345 (push-mark nil (not (interactive-p))) 359 (push-mark nil (not (interactive-p)))
346 ;; We do not use -f for csh; we will not support broken use of 360 ;; We do not use -f for csh; we will not support broken use of
361 output-buffer) 375 output-buffer)
362 (error 376 (error
363 'unimplemented 377 'unimplemented
364 "backgrounding a shell command requires package `background'"))) 378 "backgrounding a shell command requires package `background'")))
365 379
366 (shell-command-on-region (point) (point) command output-buffer))))) 380 (shell-command-on-region (point) (point) command output-buffer nil error-buffer)))))
367 381
368 ;; We have a sentinel to prevent insertion of a termination message 382 ;; We have a sentinel to prevent insertion of a termination message
369 ;; in the buffer itself. 383 ;; in the buffer itself.
370 (defun shell-command-sentinel (process signal) 384 (defun shell-command-sentinel (process signal)
371 (if (memq (process-status process) '(exit signal)) 385 (if (memq (process-status process) '(exit signal))
372 (message "%s: %s." 386 (message "%s: %s."
373 (car (cdr (cdr (process-command process)))) 387 (car (cdr (cdr (process-command process))))
374 (substring signal 0 -1)))) 388 (substring signal 0 -1))))
375 389
376 (defun shell-command-on-region (start end command 390 (defun shell-command-on-region (start end command
377 &optional output-buffer replace) 391 &optional output-buffer replace
392 error-buffer display-error-buffer)
378 "Execute string COMMAND in inferior shell with region as input. 393 "Execute string COMMAND in inferior shell with region as input.
379 Normally display output (if any) in temp buffer `*Shell Command Output*'; 394 Normally display output (if any) in temp buffer `*Shell Command Output*';
380 Prefix arg means replace the region with it. 395 Prefix arg means replace the region with it.
381 396
382 The noninteractive arguments are START, END, COMMAND, OUTPUT-BUFFER, REPLACE. 397 The noninteractive arguments are START, END, COMMAND, OUTPUT-BUFFER, REPLACE.
392 If the optional fourth argument OUTPUT-BUFFER is non-nil, 407 If the optional fourth argument OUTPUT-BUFFER is non-nil,
393 that says to put the output in some other buffer. 408 that says to put the output in some other buffer.
394 If OUTPUT-BUFFER is a buffer or buffer name, put the output there. 409 If OUTPUT-BUFFER is a buffer or buffer name, put the output there.
395 If OUTPUT-BUFFER is not a buffer and not nil, 410 If OUTPUT-BUFFER is not a buffer and not nil,
396 insert output in the current buffer. 411 insert output in the current buffer.
397 In either case, the output is inserted after point (leaving mark after it)." 412 In either case, the output is inserted after point (leaving mark after it).
413
414 If optional sixth argument ERROR-BUFFER is non-nil, it is a buffer
415 or buffer name to which to direct the command's standard error output.
416 If it is nil, error output is mingled with regular output.
417 If DISPLAY-ERROR-BUFFER is non-nil, display the error buffer if there
418 were any errors. (This is always t, interactively.)
419 In an interactive call, the variable `shell-command-default-error-buffer'
420 specifies the value of ERROR-BUFFER."
398 (interactive (let ((string 421 (interactive (let ((string
399 ;; Do this before calling region-beginning 422 ;; Do this before calling region-beginning
400 ;; and region-end, in case subprocess output 423 ;; and region-end, in case subprocess output
401 ;; relocates them while we are in the minibuffer. 424 ;; relocates them while we are in the minibuffer.
402 (read-shell-command "Shell command on region: "))) 425 (read-shell-command "Shell command on region: ")))
403 ;; call-interactively recognizes region-beginning and 426 ;; call-interactively recognizes region-beginning and
404 ;; region-end specially, leaving them in the history. 427 ;; region-end specially, leaving them in the history.
405 (list (region-beginning) (region-end) 428 (list (region-beginning) (region-end)
406 string 429 string
407 current-prefix-arg 430 current-prefix-arg
408 current-prefix-arg))) 431 current-prefix-arg
409 (if (or replace 432 shell-command-default-error-buffer
410 (and output-buffer 433 t)))
411 (not (or (bufferp output-buffer) (stringp output-buffer))))) 434 (let ((error-file
412 ;; Replace specified region with output from command. 435 (if error-buffer
413 (let ((swap (and replace (< start end)))) 436 (make-temp-file
414 ;; Don't muck with mark unless REPLACE says we should. 437 (expand-file-name "scor"
415 (goto-char start) 438 (or small-temporary-file-directory
416 (and replace (push-mark)) 439 (temp-directory))))
417 (call-process-region start end shell-file-name t t nil 440 nil))
418 shell-command-switch command) 441 (exit-status nil))
419 (let ((shell-buffer (get-buffer "*Shell Command Output*"))) 442 (if (or replace
420 (and shell-buffer (not (eq shell-buffer (current-buffer))) 443 (and output-buffer
421 (kill-buffer shell-buffer))) 444 (not (or (bufferp output-buffer) (stringp output-buffer)))))
422 ;; Don't muck with mark unless REPLACE says we should. 445 ;; Replace specified region with output from command.
423 (and replace swap (exchange-point-and-mark t))) 446 (let ((swap (and replace (< start end))))
447 ;; Don't muck with mark unless REPLACE says we should.
448 (goto-char start)
449 (and replace (push-mark))
450 (setq exit-status (call-process-region start end shell-file-name t
451 (if error-file
452 (list t error-file)
453 t)
454 nil shell-command-switch command))
455 (let ((shell-buffer (get-buffer "*Shell Command Output*")))
456 (and shell-buffer (nnot (eq shell-buffer (current-buffer)))
457 (kill-buffer shell-buffer)))
458 ;; Don't muck with mark unless REPLACE says we should.
459 (and replace swap (exchange-point-and-mark t)))
424 ;; No prefix argument: put the output in a temp buffer, 460 ;; No prefix argument: put the output in a temp buffer,
425 ;; replacing its entire contents. 461 ;; replacing its entire contents.
426 (let ((buffer (get-buffer-create 462 (let ((buffer (get-buffer-create
427 (or output-buffer "*Shell Command Output*"))) 463 (or output-buffer "*Shell Command Output*")))
428 (success nil) 464 (directory default-directory))
429 (exit-status nil) 465 (unwind-protect
430 (directory default-directory)) 466 (if (eq buffer (current-buffer))
431 (unwind-protect 467 ;; If the input is the same buffer as the output,
432 (if (eq buffer (current-buffer)) 468 ;; delete everything but the specified region,
433 ;; If the input is the same buffer as the output, 469 ;; then replace that region with the output.
434 ;; delete everything but the specified region, 470 (progn (setq buffer-read-only nil)
435 ;; then replace that region with the output. 471 (delete-region (max start end) (point-max))
436 (progn (setq buffer-read-only nil) 472 (delete-region (point-min) (min start end))
437 (delete-region (max start end) (point-max)) 473 (setq exit-status
438 (delete-region (point-min) (min start end)) 474 (call-process-region (point-min) (point-max)
439 (setq exit-status 475 shell-file-name t
440 (call-process-region (point-min) (point-max) 476 (if error-file
441 shell-file-name t t nil 477 (list t error-file)
442 shell-command-switch command)) 478 t)
443 (setq success t)) 479 nil shell-command-switch
444 ;; Clear the output buffer, 480 command)))
445 ;; then run the command with output there. 481 ;; Clear the output buffer,
446 (save-excursion 482 ;; then run the command with output there.
447 (set-buffer buffer) 483 (save-excursion
448 (setq buffer-read-only nil) 484 (set-buffer buffer)
449 ;; XEmacs change 485 (setq buffer-read-only nil)
450 (setq default-directory directory) 486 ;; XEmacs change
451 (erase-buffer)) 487 (setq default-directory directory)
452 (setq exit-status 488 (erase-buffer))
453 (call-process-region start end shell-file-name 489 (setq exit-status
454 nil buffer nil 490 (call-process-region start end shell-file-name
455 shell-command-switch command)) 491 nil
456 (setq success t)) 492 (if error-file
457 ;; Report the amount of output. 493 (list buffer error-file)
458 (let ((lines (save-excursion 494 buffer)
459 (set-buffer buffer) 495 nil shell-command-switch command)))
460 (if (= (buffer-size) 0) 496
461 0 497 ;; Report the output.
462 (count-lines (point-min) (point-max)))))) 498 (with-current-buffer buffer
463 (cond ((= lines 0) 499 (setq modeline-process
464 (if success 500 (cond ((null exit-status)
465 (display-message 501 " - Error")
466 'command 502 ((stringp exit-status)
467 (if (eql exit-status 0) 503 (format " - Signal [%s]" exit-status))
468 "(Shell command succeeded with no output)" 504 ((not (equal 0 exit-status))
469 "(Shell command failed with no output)"))) 505 (format " - Exit [%d]" exit-status)))))
470 (kill-buffer buffer)) 506 (if (with-current-buffer buffer (> (point-max) (point-min)))
471 ((and success (= lines 1)) 507 ;; There's some output, display it
472 (message "%s" 508 (let ((lines (save-excursion
473 (save-excursion 509 (set-buffer buffer)
474 (set-buffer buffer) 510 (if (= (buffer-size) 0)
475 (goto-char (point-min)) 511 0
476 (buffer-substring (point) 512 (count-lines (point-min) (point-max))))))
477 (progn (end-of-line) 513 (cond ((= lines 0)
478 (point)))))) 514 (display-message
479 (t 515 'command
480 (set-window-start (display-buffer buffer) 1)))))))) 516 (if (eql exit-status 0)
517 "(Shell command succeeded with no output)"
518 "(Shell command failed with no output)"))
519 (kill-buffer buffer))
520 ((= lines 1)
521 (message "%s"
522 (save-excursion
523 (set-buffer buffer)
524 (goto-char (point-min))
525 (buffer-substring (point)
526 (progn (end-of-line)
527 (point))))))
528 (t
529 (set-window-start (display-buffer buffer) 1))))
530 ;; No output; error?
531 (let ((output
532 (if (and error-file
533 (< 0 (nth 7 (file-attributes error-file))))
534 "some error output"
535 "no output")))
536 (cond ((null exit-status)
537 (message "(Shell command failed with error)"))
538 ((equal 0 exit-status)
539 (message "(Shell command succeeded with %s)"
540 output))
541 ((stringp exit-status)
542 (message "(Shell command killed by signal %s)"
543 exit-status))
544 (t
545 (message "(Shell command failed with code %d and %s)"
546 exit-status output))))
547 ;; Don't kill: there might be useful info in the undo-log.
548 ;; (kill-buffer buffer)
549 ))))
550
551 (when (and error-file (file-exists-p error-file))
552 (if (< 0 (nth 7 (file-attributes error-file)))
553 (with-current-buffer (get-buffer-create error-buffer)
554 (let ((pos-from-end (- (point-max) (point))))
555 (or (bobp)
556 (insert "\f\n"))
557 ;; Do no formatting while reading error file,
558 ;; because that can run a shell command, and we
559 ;; don't want that to cause an infinite recursion.
560 (format-insert-file error-file nil)
561 ;; Put point after the inserted errors.
562 (goto-char (- (point-max) pos-from-end)))
563 (and display-error-buffer
564 (display-buffer (current-buffer)))))
565 (delete-file error-file))
566 exit-status))
481 567
482 (defun shell-quote-argument (argument) 568 (defun shell-quote-argument (argument)
483 "Quote an argument for passing as argument to an inferior shell." 569 "Quote an argument for passing as argument to an inferior shell."
484 (if (and (eq system-type 'windows-nt) 570 (if (and (eq system-type 'windows-nt)
485 (let ((progname (downcase (file-name-nondirectory 571 (let ((progname (downcase (file-name-nondirectory