Mercurial > hg > xemacs-beta

comparison lisp/process.el @ 862:278c743f1578

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2002-06-03 12:23:49 by ben] process fixes process.el: Create new process-synchronize-point to avoid dynamic binding problems. Fix editing bogosity in setting process sentinels. process.c: Don't invalidate the process marker after the process has died to make point synchronization in `call-process-internal' possible.
author ben
date Mon, 03 Jun 2002 12:24:14 +0000
parents 84762348c6f9
children 5fc81edb7a38
comparison
equal deleted inserted replaced
861:9a116d92c011 862:278c743f1578
72 Wildcards and redirection are handled as usual in the shell." 72 Wildcards and redirection are handled as usual in the shell."
73 ;; We used to use `exec' to replace the shell with the command, 73 ;; We used to use `exec' to replace the shell with the command,
74 ;; but that failed to handle (...) and semicolon, etc. 74 ;; but that failed to handle (...) and semicolon, etc.
75 (start-process name buffer shell-file-name shell-command-switch 75 (start-process name buffer shell-file-name shell-command-switch
76 (mapconcat #'identity args " "))) 76 (mapconcat #'identity args " ")))
77
78 (defun process-synchronize-point (proc)
79 "Set the point(s) in buffer and stderr-buffer according to the process mark."
80 ;; We need this because the documentation says to insert *BEFORE* point,
81 ;; but we end up inserting after because only the process mark moves
82 ;; forward, not point. We synchronize after every place output might
83 ;; happen, in sentinels, and in an unwind-protect, to make *SURE* that
84 ;; point is correct. (We could do this more easily and perhaps more
85 ;; safely using a process filter, but that would create a LOT of garbage
86 ;; since all the data would get sent in strings.) We make this a separate
87 ;; function, not an flet, due to dynamic binding problems -- the flet may
88 ;; not still be in scope when the sentinel is called.
89 (let ((pb (process-buffer proc))
90 (pm (process-mark proc)))
91 (if (and pb (buffer-live-p pb) (marker-buffer pm))
92 (goto-char pm pb))
93 (if (process-has-separate-stderr-p proc)
94 (let ((pseb (process-stderr-buffer proc))
95 (psem (process-stderr-mark proc)))
96 (if (and pseb (not (eq pb pseb))
97 (buffer-live-p pseb)
98 (marker-buffer psem))
99 (goto-char psem pseb))))))
77 100
78 (defun call-process-internal (program &optional infile buffer display 101 (defun call-process-internal (program &optional infile buffer display
79 &rest args) 102 &rest args)
80 "Internal function to call PROGRAM synchronously in separate process. 103 "Internal function to call PROGRAM synchronously in separate process.
81 Lisp callers should use `call-process' or `call-process-region'. 104 Lisp callers should use `call-process' or `call-process-region'.
184 ;; end of buffer). 207 ;; end of buffer).
185 (if buffer 208 (if buffer
186 (set-marker (process-mark proc) (point buffer) buffer)) 209 (set-marker (process-mark proc) (point buffer) buffer))
187 (if errbuf 210 (if errbuf
188 (set-marker (process-stderr-mark proc) (point errbuf) errbuf)) 211 (set-marker (process-stderr-mark proc) (point errbuf) errbuf))
189 ;; bind a function to set the point(s) in buffer and
190 ;; stderr-buffer. this is because the documentation says to
191 ;; insert *BEFORE* point, but we end up inserting after because
192 ;; only the process mark moves forward, not point. we
193 ;; synchronize after every place output might happen, in
194 ;; sentinels, and in an unwind-protect, to make *SURE* that
195 ;; point is correct. (We could do this more easily and perhaps
196 ;; more safely using a process filter, but that would create a
197 ;; LOT of garbage since all the data would get sent in
198 ;; strings.)
199 (flet ((synchronize-point (proc)
200 (let ((pb (process-buffer proc))
201 (pm (process-mark proc)))
202 (if (and pb (buffer-live-p pb) (marker-buffer pm))
203 (goto-char pm pb))
204 (if (process-has-separate-stderr-p proc)
205 (let ((pseb (process-stderr-buffer proc))
206 (psem (process-stderr-mark proc)))
207 (if (and pseb (not (eq pb pseb))
208 (buffer-live-p pseb)
209 (marker-buffer psem))
210 (goto-char psem pseb)))))))
211 ;; now do I/O, very carefully! the unwind-protect makes sure 212 ;; now do I/O, very carefully! the unwind-protect makes sure
212 ;; to clear out the sentinel, since it does a `throw', which 213 ;; to clear out the sentinel, since it does a `throw', which
213 ;; would have no catch (or writes to a file -- we only want 214 ;; would have no catch (or writes to a file -- we only want
214 ;; this on normal exit) 215 ;; this on normal exit)
215 (unwind-protect 216 (unwind-protect
216 ;; if not NO-WAIT, set a sentinel to return the exit 217 ;; if not NO-WAIT, set a sentinel to return the exit
217 ;; status. it will throw to this catch so we can exit 218 ;; status. it will throw to this catch so we can exit
218 ;; properly. 219 ;; properly.
219 (catch 'call-process-done 220 (catch 'call-process-done
220 (set-process-sentinel 221 (set-process-sentinel
221 proc 222 proc
222 (if no-wait 223 (cond
223 ;; we're trying really really hard to emulate 224 ((and no-wait errbuf stderr)
224 ;; the old call-process, which would save the 225 ;; we're trying really really hard to emulate
225 ;; stderr to a file even if discarding output. so 226 ;; the old call-process, which would save the
226 ;; we set a sentinel to save the output when 227 ;; stderr to a file even if discarding output. so
227 ;; we finish. 228 ;; we set a sentinel to save the output when
228 ;; 229 ;; we finish.
229 ;; #### not clear if we should be doing this. 230 ;;
230 ;; 231 ;; #### not clear if we should be doing this.
231 ;; NOTE NOTE NOTE: Due to the total bogosity of 232 ;;
232 ;; dynamic scoping, and the lack of closures, we 233 ;; NOTE NOTE NOTE: Due to the total bogosity of
233 ;; have to be careful how we write the first 234 ;; dynamic scoping, and the lack of closures, we
234 ;; sentinel below since it may be executed after 235 ;; have to be careful how we write the first
235 ;; this function has returned -- thus we fake a 236 ;; sentinel below since it may be executed after
236 ;; closure. (This doesn't apply to the second one, 237 ;; this function has returned -- thus we fake a
237 ;; which only gets executed within the 238 ;; closure. (This doesn't apply to the second one,
238 ;; unwind-protect.) 239 ;; which only gets executed within the
239 (if (and errbuf stderr) 240 ;; unwind-protect.)
240 (set-process-sentinel 241 `(lambda (proc status)
241 proc 242 (set-process-sentinel proc nil)
242 `(lambda (proc status) 243 (process-synchronize-point proc)
243 (set-process-sentinel proc nil) 244 (with-current-buffer ,errbuf
244 (synchronize-point proc) 245 (write-region-internal
245 (with-current-buffer ,errbuf 246 1 (1+ (buffer-size))
246 (write-region-internal 247 ,stderr
247 1 (1+ (buffer-size)) 248 nil 'major-rms-kludge-city nil
248 ,stderr 249 coding-system-for-write))
249 nil 'major-rms-kludge-city nil 250 (kill-buffer ,errbuf)))
250 coding-system-for-write)) 251 (no-wait nil)
251 (kill-buffer ,errbuf)))) 252 (t
252 ;; normal sentinel: maybe write out stderr and return 253 ;; normal sentinel: maybe write out stderr and return
253 ;; status. 254 ;; status.
254 #'(lambda (proc status) 255 #'(lambda (proc status)
255 (synchronize-point proc) 256 (process-synchronize-point proc)
256 (when (and errbuf stderr) 257 (when (and errbuf stderr)
257 (with-current-buffer errbuf 258 (with-current-buffer errbuf
258 (write-region-internal 259 (write-region-internal
259 1 (1+ (buffer-size)) stderr 260 1 (1+ (buffer-size)) stderr
260 nil 'major-rms-kludge-city nil 261 nil 'major-rms-kludge-city nil
261 coding-system-for-write))) 262 coding-system-for-write)))
262 (cond ((eq 'exit (process-status proc)) 263 (cond ((eq 'exit (process-status proc))
263 (set-process-sentinel proc nil) 264 (set-process-sentinel proc nil)
264 (throw 'call-process-done 265 (throw 'call-process-done
265 (process-exit-status proc))) 266 (process-exit-status proc)))
266 ((eq 'signal (process-status proc)) 267 ((eq 'signal (process-status proc))
267 (set-process-sentinel proc nil) 268 (set-process-sentinel proc nil)
268 (throw 'call-process-done status)))))) 269 (throw 'call-process-done status)))))))
269 (if (not no-wait) 270 (if (not no-wait)
270 ;; we're waiting. send the input and loop forever, 271 ;; we're waiting. send the input and loop forever,
271 ;; handling process output and maybe redisplaying. 272 ;; handling process output and maybe redisplaying.
272 ;; exit happens through the sentinel or C-g. if 273 ;; exit happens through the sentinel or C-g. if
273 ;; C-g, send SIGINT the first time, EOF if not 274 ;; C-g, send SIGINT the first time, EOF if not
274 ;; already done so (might make the process exit), 275 ;; already done so (might make the process exit),
275 ;; and keep waiting. Another C-g will exit the 276 ;; and keep waiting. Another C-g will exit the
276 ;; whole function, and the unwind-protect will 277 ;; whole function, and the unwind-protect will
277 ;; kill the process. (Hence the documented semantics 278 ;; kill the process. (Hence the documented semantics
278 ;; of SIGINT/SIGKILL.) 279 ;; of SIGINT/SIGKILL.)
279 (let (eof-sent) 280 (let (eof-sent)
280 (condition-case nil 281 (condition-case nil
281 (progn 282 (progn
282 (when inbuf 283 (when inbuf
283 (process-send-region proc start end inbuf)) 284 (process-send-region proc start end inbuf))
284 (process-send-eof proc) 285 (process-send-eof proc)
285 (setq eof-sent t) 286 (setq eof-sent t)
286 (while t 287 (while t
287 (accept-process-output proc) 288 (accept-process-output proc)
288 (synchronize-point proc) 289 (process-synchronize-point proc)
289 (if display (sit-for 0)))) 290 (if display (sit-for 0))))
290 (quit 291 (quit
291 (process-send-signal 'SIGINT proc) 292 (process-send-signal 'SIGINT proc)
292 (unless eof-sent 293 (unless eof-sent
293 (process-send-eof proc)) 294 (process-send-eof proc))
294 (while t 295 (while t
295 (accept-process-output proc) 296 (accept-process-output proc)
296 (synchronize-point proc) 297 (process-synchronize-point proc)
297 (if display (sit-for 0)))))) 298 (if display (sit-for 0))))))
298 ;; discard and no wait: send the input, set PROC 299 ;; discard and no wait: send the input, set PROC
299 ;; and ERRBUF to nil so that the unwind-protect 300 ;; and ERRBUF to nil so that the unwind-protect
300 ;; forms don't erase the sentinel, kill the process, 301 ;; forms don't erase the sentinel, kill the process,
301 ;; or kill ERRBUF (the sentinel does that), and exit. 302 ;; or kill ERRBUF (the sentinel does that), and exit.
302 (when inbuf 303 (when inbuf
303 (process-send-region proc start end inbuf)) 304 (process-send-region proc start end inbuf))
304 (process-send-eof proc) 305 (process-send-eof proc)
305 (setq errbuf nil) 306 (setq errbuf nil)
306 (setq proc nil))) 307 (setq proc nil)))
307 ;; inner unwind-protect, once we're ready to do I/O. 308 ;; inner unwind-protect, once we're ready to do I/O.
308 (when proc 309 (when proc
309 (set-process-sentinel proc nil) 310 (set-process-sentinel proc nil)
310 (synchronize-point proc)))))) 311 (process-synchronize-point proc)))))
311 ;; outer unwind-protect forms, to make sure we always clean up. 312 ;; outer unwind-protect forms, to make sure we always clean up.
312 (if (and inbuf kill-inbuf) (kill-buffer inbuf)) 313 (if (and inbuf kill-inbuf) (kill-buffer inbuf))
313 (if (and errbuf kill-errbuf) (kill-buffer errbuf)) 314 (if (and errbuf kill-errbuf) (kill-buffer errbuf))
314 (condition-case nil 315 (condition-case nil
315 (if (and proc (process-live-p proc)) (kill-process proc)) 316 (if (and proc (process-live-p proc)) (kill-process proc))