1#| -*-Scheme-*- 2 3Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts 6 Institute of Technology 7 8This file is part of MIT/GNU Scheme. 9 10MIT/GNU Scheme is free software; you can redistribute it and/or modify 11it under the terms of the GNU General Public License as published by 12the Free Software Foundation; either version 2 of the License, or (at 13your option) any later version. 14 15MIT/GNU Scheme is distributed in the hope that it will be useful, but 16WITHOUT ANY WARRANTY; without even the implied warranty of 17MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 18General Public License for more details. 19 20You should have received a copy of the GNU General Public License 21along with MIT/GNU Scheme; if not, write to the Free Software 22Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 23USA. 24 25|# 26 27;;;; Subprocess Support 28;; package: (edwin process) 29 30(declare (usual-integrations)) 31 32(define subprocesses-available? #t) 33 34(add-event-receiver! editor-initializations 35 (lambda () 36 (set! edwin-processes '()) 37 (set! process-input-queue (cons '() '())) 38 (set-variable! exec-path (os/exec-path)) 39 (set-variable! shell-file-name (os/shell-file-name)))) 40 41(define edwin-processes) 42 43(define-variable exec-path 44 "List of directories to search programs to run in subprocesses. 45Each element is a string (directory name) or #F (try default directory)." 46 '() 47 (lambda (exec-path) 48 (and (list? exec-path) 49 (for-all? exec-path 50 (lambda (element) 51 (or (not element) 52 (pathname? element))))))) 53 54(define-variable process-connection-type 55 "Control type of device used to communicate with subprocesses. 56Values are #f to use a pipe, #t for a pty (or pipe if ptys not supported). 57Value takes effect when `start-process' is called." 58 #t 59 boolean?) 60 61(define-variable delete-exited-processes 62 "True means delete processes immediately when they exit. 63False means don't delete them until \\[list-processes] is run." 64 #t 65 boolean?) 66 67(define-variable shell-file-name 68 "File name to load inferior shells from. 69Initialized from the SHELL environment variable." 70 "" 71 string?) 72 73(define-structure (process 74 (constructor %make-process (subprocess name %buffer))) 75 (subprocess #f read-only #t) 76 (name #f read-only #t) 77 %buffer 78 (mark #f) 79 (filter #f) 80 (sentinel #f) 81 (kill-without-query #f) 82 (notification-tick (cons #f #f)) 83 (input-registration #f)) 84 85(define-integrable (process-arguments process) 86 (subprocess-arguments (process-subprocess process))) 87 88(define-integrable (process-output-port process) 89 (subprocess-output-port (process-subprocess process))) 90 91(define-integrable (process-status-tick process) 92 (subprocess-status-tick (process-subprocess process))) 93 94(define-integrable (process-exit-reason process) 95 (subprocess-exit-reason (process-subprocess process))) 96 97(define (process-status process) 98 (status->emacs-status (subprocess-status (process-subprocess process)))) 99 100(define (status->emacs-status status) 101 (case status 102 ((RUNNING) 'RUN) 103 ((STOPPED) 'STOP) 104 ((EXITED) 'EXIT) 105 ((SIGNALLED) 'SIGNAL) 106 (else status))) 107 108(define (process-runnable? process) 109 (let ((status (subprocess-status (process-subprocess process)))) 110 (or (eq? 'RUNNING status) 111 (eq? 'STOPPED status)))) 112 113(define-integrable (process-buffer process) 114 (process-%buffer process)) 115 116(define (set-process-buffer! process buffer) 117 (without-interrupts 118 (lambda () 119 (if (not (eq? buffer (process-buffer process))) 120 (begin 121 (set-process-%buffer! process buffer) 122 (update-process-mark! process)))))) 123 124(define (update-process-mark! process) 125 (set-process-mark! 126 process 127 (let ((buffer (process-buffer process))) 128 (and buffer 129 (mark-right-inserting-copy (buffer-end buffer)))))) 130 131(define (deregister-process-input process) 132 (let ((registration (process-input-registration process))) 133 (if registration 134 (begin 135 (set-process-input-registration! process #f) 136 (deregister-io-thread-event registration))))) 137 138(define (start-process name buffer environment program . arguments) 139 (let ((make-subprocess 140 (let ((directory (buffer-default-directory buffer))) 141 (let ((filename 142 (os/find-program program directory (ref-variable exec-path))) 143 (arguments (list->vector (cons program arguments))) 144 (pty? (ref-variable process-connection-type buffer))) 145 (lambda () 146 (start-subprocess filename 147 arguments 148 (cons environment (->namestring directory)) 149 pty?)))))) 150 (without-interrupts 151 (lambda () 152 (let ((subprocess (make-subprocess))) 153 (let ((process 154 (%make-process 155 subprocess 156 (do ((n 2 (+ n 1)) 157 (name* name 158 (string-append name 159 "<" (number->string n) ">"))) 160 ((not (get-process-by-name name*)) name*)) 161 buffer))) 162 (let ((channel (subprocess-input-channel subprocess))) 163 (if channel 164 (begin 165 (channel-nonblocking channel) 166 (register-process-input process channel)))) 167 (update-process-mark! process) 168 (subprocess-put! subprocess 'EDWIN-PROCESS process) 169 (set! edwin-processes (cons process edwin-processes)) 170 (buffer-modeline-event! buffer 'PROCESS-STATUS) 171 process)))))) 172 173(define (start-subprocess filename arguments environment pty?) 174 (if (and pty? ((ucode-primitive have-ptys? 0))) 175 (start-pty-subprocess filename arguments environment) 176 (start-pipe-subprocess filename arguments environment))) 177 178(define (delete-process process) 179 (let ((subprocess (process-subprocess process))) 180 (without-interrupts 181 (lambda () 182 (set! edwin-processes (delq! process edwin-processes)) 183 (subprocess-remove! subprocess 'EDWIN-PROCESS) 184 (if (process-runnable? process) 185 (begin 186 (subprocess-kill subprocess) 187 (%perform-status-notification process 'SIGNALLED #f))) 188 (deregister-process-input process) 189 (let ((buffer (process-buffer process))) 190 (if (buffer-alive? buffer) 191 (buffer-modeline-event! buffer 'PROCESS-STATUS))) 192 (subprocess-delete subprocess))))) 193 194(define (get-process-by-name name) 195 (let loop ((processes edwin-processes)) 196 (cond ((null? processes) #f) 197 ((string=? name (process-name (car processes))) (car processes)) 198 (else (loop (cdr processes)))))) 199 200(define (get-buffer-process buffer) 201 (let loop ((processes edwin-processes)) 202 (cond ((null? processes) #f) 203 ((eq? buffer (process-buffer (car processes))) (car processes)) 204 (else (loop (cdr processes)))))) 205 206(define (buffer-processes buffer) 207 (let loop ((processes edwin-processes)) 208 (cond ((null? processes) 209 '()) 210 ((eq? buffer (process-buffer (car processes))) 211 (cons (car processes) (loop (cdr processes)))) 212 (else 213 (loop (cdr processes)))))) 214 215;;;; Input and Output 216 217(define process-input-queue) 218 219(define (register-process-input process channel) 220 (set-process-input-registration! 221 process 222 (permanently-register-io-thread-event 223 (channel-descriptor-for-select channel) 224 'READ 225 (current-thread) 226 (lambda (mode) 227 mode 228 (let ((queue process-input-queue)) 229 (if (not (memq process (car queue))) 230 (let ((tail (list process))) 231 (if (null? (cdr queue)) 232 (set-car! queue tail) 233 (set-cdr! (cdr queue) tail)) 234 (set-cdr! queue tail)))))))) 235 236(define (process-output-available?) 237 (not (null? (car process-input-queue)))) 238 239(define (accept-process-output) 240 (let ((queue process-input-queue)) 241 (let loop ((output? #f)) 242 (if (null? (car queue)) 243 output? 244 (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) 245 (let ((process (caar queue))) 246 (set-car! queue (cdar queue)) 247 (if (null? (car queue)) 248 (set-cdr! queue '())) 249 (let ((output? 250 (if (poll-process-for-output process #t) #t output?))) 251 (set-interrupt-enables! interrupt-mask) 252 (loop output?)))))))) 253 254(define (poll-process-for-output process do-status?) 255 (and (let ((channel (subprocess-input-channel (process-subprocess process)))) 256 (and channel 257 (channel-open? channel))) 258 (let ((port (subprocess-input-port (process-subprocess process))) 259 (buffer (make-string 512)) 260 (output? #f)) 261 (let ((close-input 262 (lambda () 263 (deregister-process-input process) 264 (close-port port) 265 (if do-status? 266 (begin 267 (%update-global-notification-tick) 268 (if (poll-process-for-status-change process) 269 (set! output? #t))))))) 270 (let loop () 271 (let ((n 272 (call-with-current-continuation 273 (lambda (k) 274 (bind-condition-handler (list condition-type:port-error) 275 (lambda (condition) condition (k 0)) 276 (lambda () 277 (input-port/read-string! port buffer))))))) 278 (if n 279 (if (fix:= n 0) 280 (close-input) 281 (begin 282 (if (output-substring process buffer n) 283 (set! output? #t)) 284 (loop))))))) 285 output?))) 286 287(define (process-send-eof process) 288 (process-send-char process #\EOT)) 289 290(define (process-send-substring process string start end) 291 (let ((port (process-output-port process))) 292 (output-port/write-substring port string start end) 293 (output-port/flush-output port))) 294 295(define (process-send-string process string) 296 (let ((port (process-output-port process))) 297 (output-port/write-string port string) 298 (output-port/flush-output port))) 299 300(define (process-send-char process char) 301 (let ((port (process-output-port process))) 302 (output-port/write-char port char) 303 (output-port/flush-output port))) 304 305(define (process-status-changes?) 306 (without-interrupts 307 (lambda () 308 (not (eq? (subprocess-global-status-tick) global-notification-tick))))) 309 310(define (handle-process-status-changes) 311 (without-interrupts 312 (lambda () 313 (and (%update-global-notification-tick) 314 (let loop ((processes edwin-processes) (output? #f)) 315 (if (null? processes) 316 output? 317 (loop (cdr processes) 318 (if (poll-process-for-status-change (car processes)) 319 #t 320 output?)))))))) 321 322(define (%update-global-notification-tick) 323 (let ((tick (subprocess-global-status-tick))) 324 (and (not (eq? tick global-notification-tick)) 325 (begin 326 (set! global-notification-tick tick) 327 #t)))) 328 329(define global-notification-tick 330 (cons #f #f)) 331 332(define (poll-process-for-status-change process) 333 (let ((status (subprocess-status (process-subprocess process)))) 334 (and (not (eq? (process-notification-tick process) 335 (process-status-tick process))) 336 (perform-status-notification process 337 status 338 (process-exit-reason process))))) 339 340(define (perform-status-notification process status reason) 341 (poll-process-for-output process #f) 342 (let ((value (%perform-status-notification process status reason))) 343 (if (and (or (eq? 'EXITED status) 344 (eq? 'SIGNALLED status)) 345 (ref-variable delete-exited-processes)) 346 (delete-process process)) 347 value)) 348 349(define (%perform-status-notification process status reason) 350 (set-process-notification-tick! process (process-status-tick process)) 351 (cond ((process-sentinel process) 352 => 353 (lambda (sentinel) 354 (sentinel process (status->emacs-status status) reason) 355 #t)) 356 ((eq? status 'RUNNING) 357 #f) 358 (else 359 (let ((message 360 (string-append "\nProcess " 361 (process-name process) 362 " " 363 (process-status-message 364 (status->emacs-status status) 365 reason) 366 "\n"))) 367 (output-substring process 368 message 369 (string-length message)))))) 370 371(define (process-status-message status reason) 372 (let ((message-with-reason 373 (lambda (prefix connective) 374 (if reason 375 (string-append prefix 376 (if connective (string-append " " connective) "") 377 " " 378 (number->string reason)) 379 prefix)))) 380 (case status 381 ((RUN) "running") 382 ((STOP) (message-with-reason "stopped by signal" #f)) 383 ((EXIT) 384 (if (zero? reason) 385 "finished" 386 (message-with-reason "exited abnormally" "with code"))) 387 ((SIGNAL) (message-with-reason "terminated by signal" #f)) 388 (else (error "illegal process status" status))))) 389 390(define (output-substring process string length) 391 (cond ((process-filter process) 392 => 393 (lambda (filter) 394 (filter process string 0 length))) 395 ((process-mark process) 396 => 397 (lambda (mark) 398 (let ((index (mark-index mark))) 399 (group-insert-substring! (mark-group mark) index string 0 length) 400 (set-mark-index! mark (+ index length))) 401 #t)) 402 (else #f))) 403 404(define (add-process-filter process filter) 405 (let ((filter* (process-filter process))) 406 (if (filter-dispatcher? filter*) 407 (add-filter-to-dispatcher filter* filter) 408 (set-process-filter! process 409 (make-filter-dispatcher (if filter* 410 (list filter* filter) 411 (list filter))))))) 412 413(define (remove-process-filter process filter) 414 (set-process-filter! 415 process 416 (let ((filter* (process-filter process))) 417 (cond ((eq? filter filter*) #f) 418 ((filter-dispatcher? filter*) 419 (remove-filter-from-dispatcher filter* filter)) 420 (else filter*))))) 421 422(define (make-filter-dispatcher filters) 423 (make-entity filter-dispatcher-procedure filters)) 424 425(define (filter-dispatcher? object) 426 (and (entity? object) 427 (eq? filter-dispatcher-procedure (entity-procedure object)))) 428 429(define (filter-dispatcher-procedure dispatcher process string start end) 430 (let loop ((filters (entity-extra dispatcher))) 431 (and (not (null? filters)) 432 (or ((car filters) process string start end) 433 (loop (cdr filters)))))) 434 435(define (add-filter-to-dispatcher dispatcher filter) 436 (let ((filters (entity-extra dispatcher))) 437 (if (pair? filters) 438 (set-cdr! (last-pair filters) (list filter)) 439 (set-entity-extra! dispatcher (list filter))))) 440 441(define (remove-filter-from-dispatcher dispatcher filter) 442 (let ((filters (delq! filter (entity-extra dispatcher)))) 443 (set-entity-extra! dispatcher filters) 444 (and (not (null? filters)) 445 dispatcher))) 446 447(define (standard-process-filter filter) 448 (lambda (process string start end) 449 (let ((mark (process-mark process))) 450 (and mark 451 (begin 452 (filter mark string start end) 453 #t))))) 454 455;;;; Signals 456 457(define (signal-process process signal group?) 458 (let ((process (process-subprocess process))) 459 (let ((pty-master (and group? (subprocess-pty-master process)))) 460 (if pty-master 461 (pty-master-send-signal pty-master signal) 462 (subprocess-signal process signal))))) 463 464(define (interrupt-process process group?) 465 (let ((process (process-subprocess process))) 466 (let ((pty-master (and group? (subprocess-pty-master process)))) 467 (if pty-master 468 (pty-master-interrupt pty-master) 469 (subprocess-interrupt process))))) 470 471(define (quit-process process group?) 472 (let ((process (process-subprocess process))) 473 (let ((pty-master (and group? (subprocess-pty-master process)))) 474 (if pty-master 475 (pty-master-quit pty-master) 476 (subprocess-quit process))))) 477 478(define (hangup-process process group?) 479 (let ((process (process-subprocess process))) 480 (let ((pty-master (and group? (subprocess-pty-master process)))) 481 (if pty-master 482 (pty-master-hangup pty-master) 483 (subprocess-hangup process))))) 484 485(define (stop-process process group?) 486 (let ((process (process-subprocess process))) 487 (let ((pty-master (and group? (subprocess-pty-master process)))) 488 (if pty-master 489 (pty-master-stop pty-master) 490 (subprocess-stop process))))) 491 492(define (continue-process process group?) 493 (let ((process (process-subprocess process))) 494 (let ((pty-master (and group? (subprocess-pty-master process)))) 495 (if pty-master 496 (pty-master-continue pty-master) 497 (subprocess-continue-background process))))) 498 499(define (kill-process process group?) 500 (let ((process (process-subprocess process))) 501 (let ((pty-master (and group? (subprocess-pty-master process)))) 502 (if pty-master 503 (pty-master-kill pty-master) 504 (subprocess-kill process))))) 505 506;;;; LIST-PROCESSES 507 508(define-command list-processes 509 "Display a list of all processes. 510\(Any processes listed as exited or signalled are actually eliminated 511after the listing is made.)" 512 () 513 (lambda () 514 (let ((buffer (temporary-buffer "*Process List*"))) 515 (let ((point (buffer-point buffer))) 516 (let ((write-line 517 (lambda (process status buffer command) 518 (insert-string process point) 519 (insert-horizontal-space 13 point) 520 (insert-string status point) 521 (insert-horizontal-space 24 point) 522 (insert-string buffer point) 523 (insert-horizontal-space 40 point) 524 (insert-string command point) 525 (insert-newline point)))) 526 (write-line "Process" "Status" "Buffer" "Command") 527 (write-line "-------" "------" "------" "-------") 528 (do ((processes edwin-processes (cdr processes))) 529 ((null? processes)) 530 (let ((process (car processes))) 531 (write-line (or (process-name process) "") 532 (let ((status (process-status process))) 533 (let ((name (symbol-name status))) 534 (if (or (eq? 'EXIT status) 535 (eq? 'SIGNAL status)) 536 (let ((reason (process-exit-reason process))) 537 (delete-process process) 538 (if (and (eq? 'EXIT status) 539 (zero? reason)) 540 name 541 (string-append 542 name 543 " " 544 (number->string reason)))) 545 name))) 546 (let ((buffer (process-buffer process))) 547 (cond ((not buffer) "(none)") 548 ((buffer-alive? buffer) (buffer-name buffer)) 549 (else "(killed)"))) 550 (process-arguments->string 551 (process-arguments process))))))) 552 (set-buffer-point! buffer (buffer-start buffer)) 553 (buffer-not-modified! buffer) 554 (pop-up-buffer buffer #f)))) 555 556(define (process-arguments->string arguments) 557 (if (zero? (vector-length arguments)) 558 "" 559 (apply string-append 560 (let loop ((arguments (vector->list arguments))) 561 (cons (car arguments) 562 (if (null? (cdr arguments)) 563 '() 564 (cons " " (loop (cdr arguments))))))))) 565 566(define (process-list) 567 (list-copy edwin-processes)) 568 569;;;; Synchronous Subprocesses 570 571(define (run-synchronous-process input-region output-mark directory pty? 572 program . arguments) 573 (let ((input-port 574 (and input-region 575 (make-buffer-input-port (region-start input-region) 576 (region-end input-region)))) 577 (output-port 578 (and output-mark 579 (mark->output-port 580 (if (pair? output-mark) (car output-mark) output-mark))))) 581 (let ((result 582 (run-synchronous-process-1 output-port 583 (lambda () 584 (run-synchronous-subprocess 585 program arguments 586 'INPUT input-port 587 'OUTPUT output-port 588 'REDISPLAY-HOOK 589 (and (pair? output-mark) 590 (cdr output-mark) 591 (lambda () (update-screens! '(IGNORE-INPUT)))) 592 'WORKING-DIRECTORY directory 593 'USE-PTY? pty? 594 'LINE-ENDING 595 (if (cond (input-region 596 (ref-variable translate-file-data-on-output 597 (region-start input-region))) 598 (output-mark 599 (ref-variable translate-file-data-on-input 600 output-mark)) 601 (else #t)) 602 #f 603 'NEWLINE) 604 ))))) 605 (if input-port (close-port input-port)) 606 (if output-port (close-port output-port)) 607 result))) 608 609(define (run-synchronous-process-1 port thunk) 610 (call-with-current-continuation 611 (lambda (k) 612 (bind-condition-handler 613 (list condition-type:subprocess-abnormal-termination) 614 (lambda (condition) 615 (if port 616 (begin 617 (fresh-line port) 618 (newline port) 619 (write-condition-report condition port) 620 (newline port))) 621 (k 622 (cons (if (eq? condition-type:subprocess-stopped 623 (condition/type condition)) 624 'STOPPED 625 'SIGNALLED) 626 (access-condition condition 'REASON)))) 627 (lambda () 628 (let ((code (thunk))) 629 (if (and port (not (= 0 code))) 630 (begin 631 (fresh-line port) 632 (newline port) 633 (write-string "Subprocess exited abnormally with code " port) 634 (write code port) 635 (write-string "." port) 636 (newline port))) 637 (cons 'EXITED code))))))) 638 639;;;; Shell Commands 640 641(define-command shell-command 642 "Execute string COMMAND in inferior shell; display output, if any. 643Optional second arg true (prefix arg, if interactive) means 644insert output in current buffer after point (leave mark after it)." 645 (lambda () 646 (list (shell-command-prompt "Shell command") 647 (command-argument))) 648 (lambda (command insert-at-point?) 649 (let ((directory (buffer-default-directory (current-buffer)))) 650 (if insert-at-point? 651 (begin 652 (if (buffer-read-only? (current-buffer)) 653 (barf-if-read-only)) 654 (let ((point (current-point))) 655 (push-current-mark! point) 656 (shell-command #f point directory #f command)) 657 ((ref-command exchange-point-and-mark))) 658 (shell-command-pop-up-output 659 (lambda (output-mark) 660 (shell-command #f output-mark directory #f command))))))) 661 662(define-command shell-command-on-region 663 "Execute string COMMAND in inferior shell with region as input. 664Normally display output (if any) in temp buffer; 665Prefix arg means replace the region with it." 666 (lambda () 667 (list (current-region) 668 (shell-command-prompt "Shell command on region") 669 (command-argument))) 670 (lambda (region command replace-region?) 671 (let ((directory (buffer-default-directory (current-buffer)))) 672 (if replace-region? 673 (let ((point (current-point)) 674 (mark (current-mark))) 675 (let ((swap? (mark< point mark)) 676 (temp)) 677 (dynamic-wind 678 (lambda () 679 (set! temp (temporary-buffer " *shell-output*")) 680 unspecific) 681 (lambda () 682 (shell-command (make-region point mark) 683 (buffer-start temp) 684 directory 685 #f 686 command) 687 (without-interrupts 688 (lambda () 689 (delete-string point mark) 690 (insert-region (buffer-start temp) 691 (buffer-end temp) 692 (current-point))))) 693 (lambda () 694 (kill-buffer temp) 695 (set! temp) 696 unspecific)) 697 (if swap? ((ref-command exchange-point-and-mark))))) 698 (shell-command-pop-up-output 699 (lambda (output-mark) 700 (shell-command region output-mark directory #f command))))))) 701 702(define (shell-command-prompt prompt) 703 (prompt-for-string prompt #f 704 'DEFAULT-TYPE 'INSERTED-DEFAULT 705 'HISTORY 'SHELL-COMMAND)) 706 707(define (shell-command-pop-up-output generate-output) 708 (let ((buffer (temporary-buffer "*Shell Command Output*"))) 709 (let ((start (buffer-start buffer))) 710 (generate-output start) 711 (set-buffer-point! buffer start) 712 (if (mark< start (buffer-end buffer)) 713 (pop-up-buffer buffer #f) 714 (message "(Shell command completed with no output)"))))) 715 716(define (shell-command input-region output-mark directory pty? command) 717 (apply run-synchronous-process 718 input-region output-mark directory pty? 719 (ref-variable shell-file-name) 720 (os/form-shell-command command)))