Source

xemacs-21.4 / lisp / process.el

Full commit
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
;;; process.el --- commands for subprocesses; split out of simple.el

;; Copyright (C) 1985-7, 1993,4, 1997 Free Software Foundation, Inc.
;; Copyright (C) 1995, 2000 Ben Wing.

;; Author: Ben Wing
;; Maintainer: XEmacs Development Team
;; Keywords: internal, processes, dumped

;; 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 2, 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; see the file COPYING.  If not, write to the
;; Free Software Foundation, 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Synched up with: FSF 19.30.

;;; Authorship:

;; Created 1995 by Ben Wing during Mule work -- some commands split out
;; of simple.el and wrappers of *-internal functions created so they could
;; be redefined in a Mule world.
;; Lisp definition of call-process-internal added Mar. 2000 by Ben Wing.

;;; Commentary:

;; This file is dumped with XEmacs.

;;; Code:


(defgroup processes nil
  "Process, subshell, compilation, and job control support."
  :group 'external
  :group 'development)

(defgroup processes-basics nil
  "Basic stuff dealing with processes."
  :group 'processes)

(defgroup execute nil
  "Executing external commands."
  :group 'processes)


(defvar shell-command-switch "-c"
  "Switch used to have the shell execute its command line argument.")

(defun start-process-shell-command (name buffer &rest args)
  "Start a program in a subprocess.  Return the process object for it.
Args are NAME BUFFER COMMAND &rest COMMAND-ARGS.
NAME is name for process.  It is modified if necessary to make it unique.
BUFFER is the buffer or (buffer-name) to associate with the process.
 Process output goes at end of that buffer, unless you specify
 an output stream or filter function to handle the output.
 BUFFER may be also nil, meaning that this process is not associated
 with any buffer
Third arg is command name, the name of a shell command.
Remaining arguments are the arguments for the command.
Wildcards and redirection are handled as usual in the shell."
  ;; We used to use `exec' to replace the shell with the command,
  ;; but that failed to handle (...) and semicolon, etc.
  (start-process name buffer shell-file-name shell-command-switch
		 (mapconcat #'identity args " ")))

(defun call-process-internal (program &optional infile buffer display &rest args)
  "Call PROGRAM synchronously in separate process, with coding-system specified.
Arguments are
 (PROGRAM &optional INFILE BUFFER DISPLAY &rest ARGS).
The program's input comes from file INFILE (nil means `/dev/null').
Insert output in BUFFER before point; t means current buffer;
 nil for BUFFER means discard it; 0 means discard and don't wait.
BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case,
REAL-BUFFER says what to do with standard output, as above,
while STDERR-FILE says what to do with standard error in the child.
STDERR-FILE may be nil (discard standard error output),
t (mix it with ordinary output), or a file name string.

Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.
Remaining arguments are strings passed as command arguments to PROGRAM.

If BUFFER is 0, `call-process' returns immediately with value nil.
Otherwise it waits for PROGRAM to terminate and returns a numeric exit status
 or a signal description string.
If you quit, the process is killed with SIGINT, or SIGKILL if you
 quit again."
  ;; #### remove windows-nt check when this is ready for prime time.
  (if (or (noninteractive) (not (eq 'windows-nt system-type)))
      (apply 'old-call-process-internal program infile buffer display args)
    (let (proc inbuf errbuf discard)
      (unwind-protect
	  (progn
	    (when infile
	      (setq infile (expand-file-name infile))
	      (setq inbuf (generate-new-buffer "*call-process*"))
	      (with-current-buffer inbuf
               ;; Make sure this works with jka-compr
               (let ((file-name-handler-alist nil))
                 (insert-file-contents-internal infile nil nil nil nil
                                                'binary))))
	    (let ((stderr (if (consp buffer) (second buffer) t)))
	      (if (consp buffer) (setq buffer (car buffer)))
	      (setq buffer
		    (cond ((null buffer) nil)
			  ((eq buffer t) (current-buffer))
			  ;; use integerp for compatibility with existing
			  ;; call-process rmsism.
			  ((integerp buffer) (setq discard t) nil)
			  (t (get-buffer-create buffer))))
	      (when (and stderr (not (eq t stderr)))
		(setq stderr (expand-file-name stderr))
		(setq errbuf (generate-new-buffer "*call-process*")))
	      (setq proc
		    (apply 'start-process-internal "*call-process*"
			   buffer
			   ;#### not implemented until my new process
			   ;changes go in.
			   ;(if (eq t stderr) buffer (list buffer errbuf))
			   program args))
	      (if buffer
		  (set-marker (process-mark proc) (point buffer) buffer))
	      (unwind-protect
		  (prog1
		    (catch 'call-process-done
		      (when (not discard)
			(set-process-sentinel
			 proc
			 #'(lambda (proc status)
			     (cond ((eq 'exit (process-status proc))
				    (set-process-sentinel proc nil)
				    (throw 'call-process-done
					   (process-exit-status proc)))
				   ((eq 'signal (process-status proc))
				    (set-process-sentinel proc nil)
				    (throw 'call-process-done status))))))
		      (when inbuf
			(process-send-region proc 1
					     (1+ (buffer-size inbuf)) inbuf))
		      (process-send-eof proc)
		      (when discard
			;; we're trying really really hard to emulate
			;; the old call-process.
			(if errbuf
			    (set-process-sentinel
			     proc
			     `(lambda (proc status)
				(write-region-internal
				 1 (1+ (buffer-size))
				 ,stderr
				 nil 'major-rms-kludge-city nil
				 coding-system-for-write))))
			(setq errbuf nil)
			(setq proc nil)
			(throw 'call-process-done nil))
		      (while t
			(accept-process-output proc)
			(if display (sit-for 0))))
		    (when errbuf
		      (with-current-buffer errbuf
			(write-region-internal 1 (1+ (buffer-size)) stderr
					       nil 'major-rms-kludge-city nil
					       coding-system-for-write))))
		(if proc (set-process-sentinel proc nil)))))
	(if inbuf (kill-buffer inbuf))
	(if errbuf (kill-buffer errbuf))
	(condition-case nil
	    (if (and proc (process-live-p proc)) (kill-process proc))
	  (error nil))))))

(defun call-process (program &optional infile buffer displayp &rest args)
  "Call PROGRAM synchronously in separate process.
The program's input comes from file INFILE (nil means `/dev/null').
Insert output in BUFFER before point; t means current buffer;
 nil for BUFFER means discard it; 0 means discard and don't wait.
BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case,
REAL-BUFFER says what to do with standard output, as above,
while STDERR-FILE says what to do with standard error in the child.
STDERR-FILE may be nil (discard standard error output),
t (mix it with ordinary output), or a file name string.

Fourth arg DISPLAYP non-nil means redisplay buffer as output is inserted.
Remaining arguments are strings passed as command arguments to PROGRAM.

If BUFFER is 0, `call-process' returns immediately with value nil.
Otherwise it waits for PROGRAM to terminate and returns a numeric exit status
 or a signal description string.
If you quit, the process is killed with SIGINT, or SIGKILL if you
 quit again."
  (apply 'call-process-internal program infile buffer displayp args))

(defun call-process-region (start end program
                            &optional deletep buffer displayp
                            &rest args)
  "Send text from START to END to a synchronous process running PROGRAM.
Delete the text if fourth arg DELETEP is non-nil.

Insert output in BUFFER before point; t means current buffer;
 nil for BUFFER means discard it; 0 means discard and don't wait.
BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case,
REAL-BUFFER says what to do with standard output, as above,
while STDERR-FILE says what to do with standard error in the child.
STDERR-FILE may be nil (discard standard error output),
t (mix it with ordinary output), or a file name string.

Sixth arg DISPLAYP non-nil means redisplay buffer as output is inserted.
Remaining args are passed to PROGRAM at startup as command args.

If BUFFER is 0, returns immediately with value nil.
Otherwise waits for PROGRAM to terminate
and returns a numeric exit status or a signal description string.
If you quit, the process is first killed with SIGINT, then with SIGKILL if
you quit again before the process exits."
  (let ((temp
	 (make-temp-name
	  (concat (file-name-as-directory (temp-directory)) "emacs"))))
    (unwind-protect
	(progn
	  (write-region start end temp nil 'silent)
	  (if deletep (delete-region start end))
	  (apply #'call-process program temp buffer displayp args))
      (ignore-file-errors (delete-file temp)))))


(defun shell-command (command &optional output-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.

Otherwise, COMMAND is executed synchronously.  The output appears in the
buffer `*Shell Command Output*'.
If the output is one line, it is displayed in the echo area *as well*,
but it is nonetheless available in buffer `*Shell Command Output*',
even though that buffer is not automatically displayed.
If there is no output, or if output is inserted in the current buffer,
then `*Shell Command Output*' is deleted.

The optional second argument OUTPUT-BUFFER, if non-nil,
says to put the output in some other buffer.
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)."
  (interactive (list (read-shell-command "Shell command: ")
		     current-prefix-arg))
  (if (and output-buffer
	   (not (or (bufferp output-buffer)  (stringp output-buffer))))
      (progn (barf-if-buffer-read-only)
	     (push-mark nil (not (interactive-p)))
	     ;; We do not use -f for csh; we will not support broken use of
	     ;; .cshrcs.  Even the BSD csh manual says to use
	     ;; "if ($?prompt) exit" before things which are not useful
	     ;; non-interactively.  Besides, if someone wants their other
	     ;; aliases for shell commands then they can still have them.
	     (call-process shell-file-name nil t nil
			   shell-command-switch command)
	     (exchange-point-and-mark t))
    ;; Preserve the match data in case called from a program.
    (save-match-data
      (if (string-match "[ \t]*&[ \t]*$" command)
	  ;; Command ending with ampersand means asynchronous.
	  (progn
	    (background (substring command 0 (match-beginning 0))))
	(shell-command-on-region (point) (point) command output-buffer)))))

;; We have a sentinel to prevent insertion of a termination message
;; in the buffer itself.
(defun shell-command-sentinel (process signal)
  (if (memq (process-status process) '(exit signal))
      (message "%s: %s."
	       (car (cdr (cdr (process-command process))))
	       (substring signal 0 -1))))

(defun shell-command-on-region (start end command
				      &optional output-buffer replace)
  "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.

The noninteractive arguments are START, END, COMMAND, OUTPUT-BUFFER, REPLACE.
If REPLACE is non-nil, that means insert the output
in place of text from START to END, putting point and mark around it.

If the output is one line, it is displayed in the echo area,
but it is nonetheless available in buffer `*Shell Command Output*'
even though that buffer is not automatically displayed.
If there is no output, or if output is inserted in the current buffer,
then `*Shell Command Output*' is deleted.

If the optional fourth argument OUTPUT-BUFFER is non-nil,
that says to put the output in some other buffer.
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)."
  (interactive (let ((string
		      ;; Do this before calling region-beginning
		      ;; and region-end, in case subprocess output
		      ;; relocates them while we are in the minibuffer.
		      (read-shell-command "Shell command on region: ")))
		 ;; call-interactively recognizes region-beginning and
		 ;; region-end specially, leaving them in the history.
		 (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)))
      ;; 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) (max 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))))))))


(defun start-process (name buffer program &rest program-args)
  "Start a program in a subprocess.  Return the process object for it.
Args are NAME BUFFER PROGRAM &rest PROGRAM-ARGS
NAME is name for process.  It is modified if necessary to make it unique.
BUFFER is the buffer or (buffer-name) to associate with the process.
 Process output goes at end of that buffer, unless you specify
 an output stream or filter function to handle the output.
 BUFFER may be also nil, meaning that this process is not associated
 with any buffer
Third arg is program file name.  It is searched for as in the shell.
Remaining arguments are strings to give program as arguments."
  (apply 'start-process-internal name buffer program program-args))

(defun open-network-stream (name buffer host service &optional protocol)
  "Open a TCP connection for a service to a host.
Returns a process object to represent the connection.
Input and output work as for subprocesses; `delete-process' closes it.
Args are NAME BUFFER HOST SERVICE.
NAME is name for process.  It is modified if necessary to make it unique.
BUFFER is the buffer (or buffer-name) to associate with the process.
 Process output goes at end of that buffer, unless you specify
 an output stream or filter function to handle the output.
 BUFFER may be also nil, meaning that this process is not associated
 with any buffer
Third arg is name of the host to connect to, or its IP address.
Fourth arg SERVICE is name of the service desired, or an integer
 specifying a port number to connect to.
Fifth argument PROTOCOL is a network protocol.  Currently 'tcp
 (Transmission Control Protocol) and 'udp (User Datagram Protocol) are
 supported.  When omitted, 'tcp is assumed.

Output via `process-send-string' and input via buffer or filter (see
`set-process-filter') are stream-oriented.  That means UDP datagrams are
not guaranteed to be sent and received in discrete packets. (But small
datagrams around 500 bytes that are not truncated by `process-send-string'
are usually fine.)  Note further that UDP protocol does not guard against
lost packets."
  (open-network-stream-internal name buffer host service protocol))

(defun shell-quote-argument (argument)
  "Quote an argument for passing as argument to an inferior shell."
  (if (and (eq system-type 'windows-nt)
	   (let ((progname (downcase (file-name-nondirectory
				      shell-file-name))))
	     (or (equal progname "command.com")
		 (equal progname "cmd.exe"))))
      ;; the expectation is that you can take the result of
      ;; shell-quote-argument and pass it to as an arg to
      ;; (start-process shell-quote-argument ...) and have it end
      ;; up as-is in the program's argv[] array.  to do this, we
      ;; need to protect against both the shell's and the program's
      ;; quoting conventions (and our own conventions in
      ;; mswindows-construct-process-command-line!).  Putting quotes
      ;; around shell metachars gets through the last two, and applying
      ;; the normal VC runtime quoting works with practically all apps.
      (mswindows-quote-one-vc-runtime-arg argument t)
    ;; Quote everything except POSIX filename characters.
    ;; This should be safe enough even for really weird shells.
    (let ((result "") (start 0) end)
      (while (string-match "[^-0-9a-zA-Z_./]" argument start)
	(setq end (match-beginning 0)
	      result (concat result (substring argument start end)
			     "\\" (substring argument end (1+ end)))
	      start (1+ end)))
      (concat result (substring argument start)))))

(defun shell-command-to-string (command)
  "Execute shell command COMMAND and return its output as a string."
  (with-output-to-string
    (call-process shell-file-name nil t nil shell-command-switch command)))

(defalias 'exec-to-string 'shell-command-to-string)

;;; process.el ends here