Mercurial > hg > xemacs-beta

comparison lisp/process.el @ 412:697ef44129c6 r21-2-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-14
author cvs
date Mon, 13 Aug 2007 11:20:41 +0200
parents de805c49cfc1
children 11054d720c21
comparison
equal deleted inserted replaced
411:12e008d41344 412:697ef44129c6
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 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995, 2000 Ben Wing. 4 ;; Copyright (C) 1995 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
9 9
24 ;; Free Software Foundation, 59 Temple Place - Suite 330, 24 ;; Free Software Foundation, 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA. 25 ;; Boston, MA 02111-1307, USA.
26 26
27 ;;; Synched up with: FSF 19.30. 27 ;;; Synched up with: FSF 19.30.
28 28
29 ;;; Authorship:
30
31 ;; Created 1995 by Ben Wing during Mule work -- some commands split out
32 ;; of simple.el and wrappers of *-internal functions created so they could
33 ;; be redefined in a Mule world.
34 ;; Lisp definition of call-process-internal added Mar. 2000 by Ben Wing.
35
36 ;;; Commentary: 29 ;;; Commentary:
37 30
38 ;; This file is dumped with XEmacs. 31 ;; This file is dumped with XEmacs.
39 32
40 ;;; Code: 33 ;;; Code:
41 34
42 35
36 (defvar binary-process-output)
37 (defvar buffer-file-type)
38
43 (defgroup processes nil 39 (defgroup processes nil
44 "Process, subshell, compilation, and job control support." 40 "Process, subshell, compilation, and job control support."
45 :group 'external 41 :group 'external
46 :group 'development) 42 :group 'development)
47 43
72 ;; We used to use `exec' to replace the shell with the command, 68 ;; We used to use `exec' to replace the shell with the command,
73 ;; but that failed to handle (...) and semicolon, etc. 69 ;; but that failed to handle (...) and semicolon, etc.
74 (start-process name buffer shell-file-name shell-command-switch 70 (start-process name buffer shell-file-name shell-command-switch
75 (mapconcat #'identity args " "))) 71 (mapconcat #'identity args " ")))
76 72
77 (defun call-process-internal (program &optional infile buffer display &rest args)
78 "Call PROGRAM synchronously in separate process, with coding-system specified.
79 Arguments are
80 (PROGRAM &optional INFILE BUFFER DISPLAY &rest ARGS).
81 The program's input comes from file INFILE (nil means `/dev/null').
82 Insert output in BUFFER before point; t means current buffer;
83 nil for BUFFER means discard it; 0 means discard and don't wait.
84 BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case,
85 REAL-BUFFER says what to do with standard output, as above,
86 while STDERR-FILE says what to do with standard error in the child.
87 STDERR-FILE may be nil (discard standard error output),
88 t (mix it with ordinary output), or a file name string.
89
90 Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.
91 Remaining arguments are strings passed as command arguments to PROGRAM.
92
93 If BUFFER is 0, `call-process' returns immediately with value nil.
94 Otherwise it waits for PROGRAM to terminate and returns a numeric exit status
95 or a signal description string.
96 If you quit, the process is killed with SIGINT, or SIGKILL if you
97 quit again."
98 ;; #### remove windows-nt check when this is ready for prime time.
99 (if (or (noninteractive) (not (eq 'windows-nt system-type)))
100 (apply 'old-call-process-internal program infile buffer display args)
101 (let (proc inbuf errbuf discard)
102 (unwind-protect
103 (progn
104 (when infile
105 (setq infile (expand-file-name infile))
106 (setq inbuf (generate-new-buffer "*call-process*"))
107 (with-current-buffer inbuf
108 ;; Make sure this works with jka-compr
109 (let ((file-name-handler-alist nil))
110 (insert-file-contents-internal infile nil nil nil nil
111 'binary))))
112 (let ((stderr (if (consp buffer) (second buffer) t)))
113 (if (consp buffer) (setq buffer (car buffer)))
114 (setq buffer
115 (cond ((null buffer) nil)
116 ((eq buffer t) (current-buffer))
117 ;; use integerp for compatibility with existing
118 ;; call-process rmsism.
119 ((integerp buffer) (setq discard t) nil)
120 (t (get-buffer-create buffer))))
121 (when (and stderr (not (eq t stderr)))
122 (setq stderr (expand-file-name stderr))
123 (setq errbuf (generate-new-buffer "*call-process*")))
124 (setq proc
125 (apply 'start-process-internal "*call-process*"
126 buffer
127 ;#### not implemented until my new process
128 ;changes go in.
129 ;(if (eq t stderr) buffer (list buffer errbuf))
130 program args))
131 (if buffer
132 (set-marker (process-mark proc) (point buffer) buffer))
133 (unwind-protect
134 (prog1
135 (catch 'call-process-done
136 (when (not discard)
137 (set-process-sentinel
138 proc
139 #'(lambda (proc status)
140 (cond ((eq 'exit (process-status proc))
141 (set-process-sentinel proc nil)
142 (throw 'call-process-done
143 (process-exit-status proc)))
144 ((eq 'signal (process-status proc))
145 (set-process-sentinel proc nil)
146 (throw 'call-process-done status))))))
147 (when inbuf
148 (process-send-region proc 1
149 (1+ (buffer-size inbuf)) inbuf))
150 (process-send-eof proc)
151 (when discard
152 ;; we're trying really really hard to emulate
153 ;; the old call-process.
154 (if errbuf
155 (set-process-sentinel
156 proc
157 `(lambda (proc status)
158 (write-region-internal
159 1 (1+ (buffer-size))
160 ,stderr
161 nil 'major-rms-kludge-city nil
162 coding-system-for-write))))
163 (setq errbuf nil)
164 (setq proc nil)
165 (throw 'call-process-done nil))
166 (while t
167 (accept-process-output proc)
168 (if display (sit-for 0))))
169 (when errbuf
170 (with-current-buffer errbuf
171 (write-region-internal 1 (1+ (buffer-size)) stderr
172 nil 'major-rms-kludge-city nil
173 coding-system-for-write))))
174 (if proc (set-process-sentinel proc nil)))))
175 (if inbuf (kill-buffer inbuf))
176 (if errbuf (kill-buffer errbuf))
177 (condition-case nil
178 (if (and proc (process-live-p proc)) (kill-process proc))
179 (error nil))))))
180
181 (defun call-process (program &optional infile buffer displayp &rest args) 73 (defun call-process (program &optional infile buffer displayp &rest args)
182 "Call PROGRAM synchronously in separate process. 74 "Call PROGRAM synchronously in separate process.
183 The program's input comes from file INFILE (nil means `/dev/null'). 75 The program's input comes from file INFILE (nil means `/dev/null').
184 Insert output in BUFFER before point; t means current buffer; 76 Insert output in BUFFER before point; t means current buffer;
185 nil for BUFFER means discard it; 0 means discard and don't wait. 77 nil for BUFFER means discard it; 0 means discard and don't wait.
221 and returns a numeric exit status or a signal description string. 113 and returns a numeric exit status or a signal description string.
222 If you quit, the process is first killed with SIGINT, then with SIGKILL if 114 If you quit, the process is first killed with SIGINT, then with SIGKILL if
223 you quit again before the process exits." 115 you quit again before the process exits."
224 (let ((temp 116 (let ((temp
225 (make-temp-name 117 (make-temp-name
226 (concat (file-name-as-directory (temp-directory)) "emacs")))) 118 (concat (file-name-as-directory (temp-directory))
119 (if (memq system-type '(ms-dos windows-nt)) "em" "emacs")))))
227 (unwind-protect 120 (unwind-protect
228 (progn 121 (progn
229 (write-region start end temp nil 'silent) 122 (if (memq system-type '(ms-dos windows-nt))
123 (let ((buffer-file-type binary-process-output))
124 (write-region start end temp nil 'silent))
125 (write-region start end temp nil 'silent))
230 (if deletep (delete-region start end)) 126 (if deletep (delete-region start end))
231 (apply #'call-process program temp buffer displayp args)) 127 (apply #'call-process program temp buffer displayp args))
232 (ignore-file-errors (delete-file temp))))) 128 (ignore-file-errors (delete-file temp)))))
233 129
234 130
401 with any buffer 297 with any buffer
402 Third arg is program file name. It is searched for as in the shell. 298 Third arg is program file name. It is searched for as in the shell.
403 Remaining arguments are strings to give program as arguments." 299 Remaining arguments are strings to give program as arguments."
404 (apply 'start-process-internal name buffer program program-args)) 300 (apply 'start-process-internal name buffer program program-args))
405 301
406 (defun open-network-stream (name buffer host service &optional protocol) 302 (defun open-network-stream (name buffer host service)
407 "Open a TCP connection for a service to a host. 303 "Open a TCP connection for a service to a host.
408 Returns a subprocess-object to represent the connection. 304 Returns a subprocess-object to represent the connection.
409 Input and output work as for subprocesses; `delete-process' closes it. 305 Input and output work as for subprocesses; `delete-process' closes it.
410 Args are NAME BUFFER HOST SERVICE. 306 Args are NAME BUFFER HOST SERVICE.
411 NAME is name for process. It is modified if necessary to make it unique. 307 NAME is name for process. It is modified if necessary to make it unique.
414 an output stream or filter function to handle the output. 310 an output stream or filter function to handle the output.
415 BUFFER may be also nil, meaning that this process is not associated 311 BUFFER may be also nil, meaning that this process is not associated
416 with any buffer 312 with any buffer
417 Third arg is name of the host to connect to, or its IP address. 313 Third arg is name of the host to connect to, or its IP address.
418 Fourth arg SERVICE is name of the service desired, or an integer 314 Fourth arg SERVICE is name of the service desired, or an integer
419 specifying a port number to connect to. 315 specifying a port number to connect to."
420 Fifth argument PROTOCOL is a network protocol. Currently 'tcp 316 (open-network-stream-internal name buffer host service))
421 (Transmission Control Protocol) and 'udp (User Datagram Protocol) are
422 supported. When omitted, 'tcp is assumed.
423
424 Ouput via `process-send-string' and input via buffer or filter (see
425 `set-process-filter') are stream-oriented. That means UDP datagrams are
426 not guaranteed to be sent and received in discrete packets. (But small
427 datagrams around 500 bytes that are not truncated by `process-send-string'
428 are usually fine.) Note further that UDP protocol does not guard against
429 lost packets."
430 (open-network-stream-internal name buffer host service protocol))
431 317
432 (defun shell-quote-argument (argument) 318 (defun shell-quote-argument (argument)
433 "Quote an argument for passing as argument to an inferior shell." 319 "Quote an argument for passing as argument to an inferior shell."
434 (if (and (eq system-type 'windows-nt) 320 (if (eq system-type 'ms-dos)
435 ;; #### this is a temporary hack. a better solution needs 321 ;; MS-DOS shells don't have quoting, so don't do any.
436 ;; futzing with the c code. i'll do this shortly.
437 (let ((progname (downcase (file-name-nondirectory
438 shell-file-name))))
439 (or (equal progname "command.com")
440 (equal progname "cmd.exe"))))
441 argument 322 argument
442 ;; Quote everything except POSIX filename characters. 323 (if (eq system-type 'windows-nt)
443 ;; This should be safe enough even for really weird shells. 324 (concat "\"" argument "\"")
444 (let ((result "") (start 0) end) 325 ;; Quote everything except POSIX filename characters.
445 (while (string-match "[^-0-9a-zA-Z_./]" argument start) 326 ;; This should be safe enough even for really weird shells.
446 (setq end (match-beginning 0) 327 (let ((result "") (start 0) end)
447 result (concat result (substring argument start end) 328 (while (string-match "[^-0-9a-zA-Z_./]" argument start)
448 "\\" (substring argument end (1+ end))) 329 (setq end (match-beginning 0)
449 start (1+ end))) 330 result (concat result (substring argument start end)
450 (concat result (substring argument start))))) 331 "\\" (substring argument end (1+ end)))
451 332 start (1+ end)))
452 (defun shell-command-to-string (command) 333 (concat result (substring argument start))))))
453 "Execute shell command COMMAND and return its output as a string." 334
335 (defun exec-to-string (command)
336 "Execute COMMAND as an external process and return the output of that
337 process as a string"
338 ;; by "William G. Dubuque" <wgd@zurich.ai.mit.edu>
454 (with-output-to-string 339 (with-output-to-string
455 (call-process shell-file-name nil t nil shell-command-switch command))) 340 (call-process shell-file-name nil t nil shell-command-switch command)))
456 341
457 (defalias 'exec-to-string 'shell-command-to-string) 342 (defalias 'shell-command-to-string 'exec-to-string)
458 343
459 ;;; process.el ends here 344 ;;; process.el ends here