/[cmucl]/src/code/run-program.lisp
ViewVC logotype

Diff of /src/code/run-program.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.7 by wlott, Fri Sep 27 10:24:58 1991 UTC revision 1.7.1.1 by wlott, Fri Jan 24 07:09:21 1992 UTC
# Line 30  Line 30 
30    
31  ;;;; Import WAIT3 from unix.  ;;;; Import WAIT3 from unix.
32    
33  (ext:def-c-pointer *wait (unsigned-byte 32))  (alien:def-alien-routine ("wait3" c-wait3) c-call:int
34      (status c-call:int :out)
35  (ext:def-c-routine ("wait3" c-wait3)    (options c-call:int)
36                     (int)    (rusage c-call:int))
     (status *wait :out)  
     (options int)  
     (rusage int))  
37    
38  (eval-when (load eval compile)  (eval-when (load eval compile)
39    (defconstant wait-wstopped #o177)    (defconstant wait-wstopped #o177)
# Line 68  Line 65 
65            (t            (t
66             (let ((signal (ldb (byte 7 0) status)))             (let ((signal (ldb (byte 7 0) status)))
67               (values pid               (values pid
68                       (if (or (eql signal mach:sigstop)                       (if (or (eql signal unix:sigstop)
69                               (eql signal mach:sigtstp)                               (eql signal unix:sigtstp)
70                               (eql signal mach:sigttin)                               (eql signal unix:sigttin)
71                               (eql signal mach:sigttou))                               (eql signal unix:sigttou))
72                         :stopped                         :stopped
73                         :signaled)                         :signaled)
74                       signal                       signal
# Line 135  Line 132 
132  ;;; Finds the current foreground process group id.  ;;; Finds the current foreground process group id.
133  ;;;  ;;;
134  (defun find-current-foreground-process (proc)  (defun find-current-foreground-process (proc)
135    (system:with-stack-alien (result (unsigned-byte 32) (long-words 1))    (alien:with-alien ((result c-call:int))
136      (multiple-value-bind      (multiple-value-bind
137          (wonp error)          (wonp error)
138          (mach:unix-ioctl (system:fd-stream-fd (ext:process-pty proc))          (unix:unix-ioctl (system:fd-stream-fd (ext:process-pty proc))
139                           mach:TIOCGPGRP                           unix:TIOCGPGRP
140                           (system:alien-sap (system:alien-value result)))                           (alien:alien-sap (alien:addr result)))
141        (unless wonp        (unless wonp
142          (error "TIOCPGRP ioctl failed: ~S"          (error "TIOCPGRP ioctl failed: ~S"
143                 (mach:get-unix-error-msg error)))                 (unix:get-unix-error-msg error)))
144        (system:alien-access (system:alien-value result)))))        result)))
145    
146  ;;; PROCESS-KILL -- public  ;;; PROCESS-KILL -- public
147  ;;;  ;;;
# Line 162  Line 159 
159                  (find-current-foreground-process proc)))))                  (find-current-foreground-process proc)))))
160      (multiple-value-bind (okay errno)      (multiple-value-bind (okay errno)
161                           (if (eq whom :pty-process-group)                           (if (eq whom :pty-process-group)
162                             (mach:unix-killpg pid signal)                             (unix:unix-killpg pid signal)
163                             (mach:unix-kill pid signal))                             (unix:unix-kill pid signal))
164        (cond ((not okay)        (cond ((not okay)
165               (values nil errno))               (values nil errno))
166              ((and (eql pid (process-pid proc))              ((and (eql pid (process-pid proc))
167                    (= (unix-signal-number signal) mach:sigcont))                    (= (unix-signal-number signal) unix:sigcont))
168               (setf (process-%status proc) :running)               (setf (process-%status proc) :running)
169               (setf (process-exit-code proc) nil)               (setf (process-exit-code proc) nil)
170               (when (process-status-hook proc)               (when (process-status-hook proc)
# Line 256  Line 253 
253    (dolist (char '(#\p #\q))    (dolist (char '(#\p #\q))
254      (dotimes (digit 16)      (dotimes (digit 16)
255        (let* ((master-name (format nil "/dev/pty~C~X" char digit))        (let* ((master-name (format nil "/dev/pty~C~X" char digit))
256               (master-fd (mach:unix-open master-name               (master-fd (unix:unix-open master-name
257                                          mach:o_rdwr                                          unix:o_rdwr
258                                          #o666)))                                          #o666)))
259          (when master-fd          (when master-fd
260            (let* ((slave-name (format nil "/dev/tty~C~X" char digit))            (let* ((slave-name (format nil "/dev/tty~C~X" char digit))
261                   (slave-fd (mach:unix-open slave-name                   (slave-fd (unix:unix-open slave-name
262                                             mach:o_rdwr                                             unix:o_rdwr
263                                             #o666)))                                             #o666)))
264              (when slave-fd              (when slave-fd
265                ; Maybe put a vhangup here?                ; Maybe put a vhangup here?
266                (with-stack-alien (stuff mach:sgtty (record-size 'mach:sgtty))                (alien:with-alien ((stuff (alien:struct unix:sgttyb)))
267                  (let ((sap (system:alien-sap (system:alien-value stuff))))                  (let ((sap (alien:alien-sap stuff)))
268                    (mach:unix-ioctl slave-fd mach:TIOCGETP sap)                    (unix:unix-ioctl slave-fd unix:TIOCGETP sap)
269                    (setf (system:alien-access                    (setf (alien:slot stuff 'unix:sg-flags) #o300) ; EVENP|ODDP
270                           (mach::sgtty-flags                    (unix:unix-ioctl slave-fd unix:TIOCSETP sap)
271                            (system:alien-value stuff)))                    (unix:unix-ioctl master-fd unix:TIOCGETP sap)
272                          #o300) ; EVENP|ODDP                    (setf (alien:slot stuff 'unix:sg-flags)
273                    (mach:unix-ioctl slave-fd mach:TIOCSETP sap)                          (logand (alien:slot stuff 'unix:sg-flags)
                   (mach:unix-ioctl master-fd mach:TIOCGETP sap)  
                   (setf (system:alien-access  
                          (mach::sgtty-flags  
                           (system:alien-value stuff)))  
                         (logand (system:alien-access  
                                  (mach::sgtty-flags  
                                   (system:alien-value stuff)))  
274                                  (lognot 8))) ; ~ECHO                                  (lognot 8))) ; ~ECHO
275                    (mach:unix-ioctl master-fd mach:TIOCSETP sap)))                    (unix:unix-ioctl master-fd unix:TIOCSETP sap)))
276                (return-from find-a-pty                (return-from find-a-pty
277                             (values master-fd                             (values master-fd
278                                     slave-fd                                     slave-fd
279                                     slave-name)))                                     slave-name)))
280            (mach:unix-close master-fd))))))            (unix:unix-close master-fd))))))
281    (error "Could not find a pty."))    (error "Could not find a pty."))
282    
283  ;;; OPEN-PTY -- internal  ;;; OPEN-PTY -- internal
# Line 300  Line 290 
290        (push master *close-on-error*)        (push master *close-on-error*)
291        (push slave *close-in-parent*)        (push slave *close-in-parent*)
292        (when (streamp pty)        (when (streamp pty)
293          (multiple-value-bind (won new-fd) (mach:unix-dup master)          (multiple-value-bind (won new-fd) (unix:unix-dup master)
294            (unless won            (unless won
295              (error "Could not MACH:UNIX-DUP ~D: ~A"              (error "Could not UNIX:UNIX-DUP ~D: ~A"
296                     master (mach:get-unix-error-msg new-fd)))                     master (unix:get-unix-error-msg new-fd)))
297            (push new-fd *close-on-error*)            (push new-fd *close-on-error*)
298            (copy-descriptor-to-stream new-fd pty cookie)))            (copy-descriptor-to-stream new-fd pty cookie)))
299        (values name        (values name
# Line 318  Line 308 
308    (unwind-protect    (unwind-protect
309        (handler-bind ((error #'(lambda (condition)        (handler-bind ((error #'(lambda (condition)
310                                  (declare (ignore condition))                                  (declare (ignore condition))
311                                  (mach:unix-exit 2))))                                  (unix:unix-exit 2))))
312          ;; Put us in our own pgrp.          ;; Put us in our own pgrp.
313          (mach:unix-setpgrp 0 (mach:unix-getpid))          (unix:unix-setpgrp 0 (unix:unix-getpid))
314          ;; If we want a pty, set it up.          ;; If we want a pty, set it up.
315          (when pty-name          (when pty-name
316            (let ((old-tty (mach:unix-open "/dev/tty" mach:o_rdwr 0)))            (let ((old-tty (unix:unix-open "/dev/tty" unix:o_rdwr 0)))
317              (when old-tty              (when old-tty
318                (mach:unix-ioctl old-tty mach:TIOCNOTTY 0)                (unix:unix-ioctl old-tty unix:TIOCNOTTY 0)
319                (mach:unix-close old-tty)))                (unix:unix-close old-tty)))
320            (let ((new-tty (mach:unix-open pty-name mach:o_rdwr 0)))            (let ((new-tty (unix:unix-open pty-name unix:o_rdwr 0)))
321              (when new-tty              (when new-tty
322                (mach:unix-dup2 new-tty 0)                (unix:unix-dup2 new-tty 0)
323                (mach:unix-dup2 new-tty 1)                (unix:unix-dup2 new-tty 1)
324                (mach:unix-dup2 new-tty 2))))                (unix:unix-dup2 new-tty 2))))
325          ;; Setup the three standard descriptors.          ;; Setup the three standard descriptors.
326          (when stdin          (when stdin
327            (mach:unix-dup2 stdin 0))            (unix:unix-dup2 stdin 0))
328          (when stdout          (when stdout
329            (mach:unix-dup2 stdout 1))            (unix:unix-dup2 stdout 1))
330          (when stderr          (when stderr
331            (mach:unix-dup2 stderr 2))            (unix:unix-dup2 stderr 2))
332          ;; Arange for all the unused FD's to be closed.          ;; Arange for all the unused FD's to be closed.
333          (do ((fd (1- (mach:unix-getdtablesize))          (do ((fd (1- (unix:unix-getdtablesize))
334                   (1- fd)))                   (1- fd)))
335              ((= fd 3))              ((= fd 3))
336            (mach:unix-fcntl fd mach:f-setfd 1))            (unix:unix-fcntl fd unix:f-setfd 1))
337          ;; Do the before-execve          ;; Do the before-execve
338          (when before-execve          (when before-execve
339            (funcall before-execve))            (funcall before-execve))
340          ;; Exec the program          ;; Exec the program
341          (multiple-value-bind          (multiple-value-bind
342              (okay errno)              (okay errno)
343              (mach:unix-execve pfile args env)              (unix:unix-execve pfile args env)
344            (declare (ignore okay))            (declare (ignore okay))
345            ;; If the magic number if bogus, try just a shell script.            ;; If the magic number if bogus, try just a shell script.
346            (when (eql errno mach:ENOEXEC)            (when (eql errno unix:ENOEXEC)
347              (mach:unix-execve "/bin/sh" (cons pfile args) env))))              (unix:unix-execve "/bin/sh" (cons pfile args) env))))
348      ;; If exec returns, we lose.      ;; If exec returns, we lose.
349      (mach:unix-exit 1)))      (unix:unix-exit 1)))
350    
351  ;;; RUN-PROGRAM -- public  ;;; RUN-PROGRAM -- public
352  ;;;  ;;;
# Line 456  Line 446 
446          process just before turning it into the specified program."          process just before turning it into the specified program."
447    
448    ;; Make sure the interrupt handler is installed.    ;; Make sure the interrupt handler is installed.
449    (system:enable-interrupt mach:sigchld #'sigchld-handler)    (system:enable-interrupt unix:sigchld #'sigchld-handler)
450    ;; Make sure all the args are okay.    ;; Make sure all the args are okay.
451    (unless (every #'simple-string-p args)    (unless (every #'simple-string-p args)
452      (error "All args to program must be simple strings -- ~S." args))      (error "All args to program must be simple strings -- ~S." args))
# Line 489  Line 479 
479                    (system:without-interrupts                    (system:without-interrupts
480                      (multiple-value-bind                      (multiple-value-bind
481                          (child-pid errno)                          (child-pid errno)
482                          (mach:unix-fork)                          (unix:unix-fork)
483                        (cond ((zerop child-pid)                        (cond ((zerop child-pid)
484                               ;; We are the child. Note: setup-child NEVER returns                               ;; We are the child. Note: setup-child NEVER returns
485                               (setup-child pfile args env stdin stdout stderr                               (setup-child pfile args env stdin stdout stderr
# Line 498  Line 488 
488                               ;; This should only happen if the bozo has too                               ;; This should only happen if the bozo has too
489                               ;; many running procs.                               ;; many running procs.
490                               (error "Could not fork child process: ~A"                               (error "Could not fork child process: ~A"
491                                      (mach:get-unix-error-msg errno)))                                      (unix:get-unix-error-msg errno)))
492                              (t                              (t
493                               ;; We are the parent.                               ;; We are the parent.
494                               (setf proc (make-process :pid child-pid                               (setf proc (make-process :pid child-pid
# Line 511  Line 501 
501                                                        :cookie cookie))                                                        :cookie cookie))
502                               (push proc *active-processes*))))))))))                               (push proc *active-processes*))))))))))
503        (dolist (fd *close-in-parent*)        (dolist (fd *close-in-parent*)
504          (mach:unix-close fd))          (unix:unix-close fd))
505        (unless proc        (unless proc
506          (dolist (fd *close-on-error*)          (dolist (fd *close-on-error*)
507            (mach:unix-close fd))            (unix:unix-close fd))
508          (dolist (handler *handlers-installed*)          (dolist (handler *handlers-installed*)
509            (system:remove-fd-handler handler))))            (system:remove-fd-handler handler))))
510      (when (and wait proc)      (when (and wait proc)
# Line 539  Line 529 
529                      (return))                      (return))
530                    (multiple-value-bind                    (multiple-value-bind
531                        (result readable/errno)                        (result readable/errno)
532                        (mach:unix-select (1+ descriptor) (ash 1 descriptor)                        (unix:unix-select (1+ descriptor) (ash 1 descriptor)
533                                          0 0 0)                                          0 0 0)
534                      (cond ((null result)                      (cond ((null result)
535                             (error "Could not select on sub-process: ~A"                             (error "Could not select on sub-process: ~A"
536                                    (mach:get-unix-error-msg readable/errno)))                                    (unix:get-unix-error-msg readable/errno)))
537                            ((zerop result)                            ((zerop result)
538                             (return))))                             (return))))
539                    (multiple-value-bind                    (multiple-value-bind
540                        (count errno)                        (count errno)
541                        (mach:unix-read descriptor                        (unix:unix-read descriptor
542                                        string                                        string
543                                        (length string))                                        (length string))
544                      (cond ((or (and (null count)                      (cond ((or (and (null count)
545                                      (eql errno mach:eio))                                      (eql errno unix:eio))
546                                 (eql count 0))                                 (eql count 0))
547                             (system:remove-fd-handler handler)                             (system:remove-fd-handler handler)
548                             (setf handler nil)                             (setf handler nil)
549                             (decf (car cookie))                             (decf (car cookie))
550                             (mach:unix-close descriptor)                             (unix:unix-close descriptor)
551                             (return))                             (return))
552                            ((null count)                            ((null count)
553                             (system:remove-fd-handler handler)                             (system:remove-fd-handler handler)
554                             (setf handler nil)                             (setf handler nil)
555                             (decf (car cookie))                             (decf (car cookie))
556                             (error "Could not read input from sub-process: ~A"                             (error "Could not read input from sub-process: ~A"
557                                    (mach:get-unix-error-msg errno)))                                    (unix:get-unix-error-msg errno)))
558                            (t                            (t
559                             (write-string string stream                             (write-string string stream
560                                           :end count))))))))))                                           :end count))))))))))
# Line 584  Line 574 
574           ;; Use /dev/null.           ;; Use /dev/null.
575           (multiple-value-bind           (multiple-value-bind
576               (fd errno)               (fd errno)
577               (mach:unix-open "/dev/null"               (unix:unix-open "/dev/null"
578                               (case direction                               (case direction
579                                 (:input mach:o_rdonly)                                 (:input unix:o_rdonly)
580                                 (:output mach:o_wronly)                                 (:output unix:o_wronly)
581                                 (t mach:o_rdwr))                                 (t unix:o_rdwr))
582                               #o666)                               #o666)
583             (unless fd             (unless fd
584               (error "Could not open \"/dev/null\": ~A"               (error "Could not open \"/dev/null\": ~A"
585                      (mach:get-unix-error-msg errno)))                      (unix:get-unix-error-msg errno)))
586             (push fd *close-in-parent*)             (push fd *close-in-parent*)
587             (values fd nil)))             (values fd nil)))
588          ((eq object :stream)          ((eq object :stream)
589           (multiple-value-bind           (multiple-value-bind
590               (read-fd write-fd)               (read-fd write-fd)
591               (mach:unix-pipe)               (unix:unix-pipe)
592             (unless read-fd             (unless read-fd
593               (error "Could not create pipe: ~A"               (error "Could not create pipe: ~A"
594                      (mach:get-unix-error-msg write-fd)))                      (unix:get-unix-error-msg write-fd)))
595             (case direction             (case direction
596               (:input               (:input
597                (push read-fd *close-in-parent*)                (push read-fd *close-in-parent*)
# Line 614  Line 604 
604                (let ((stream (system:make-fd-stream read-fd :input t)))                (let ((stream (system:make-fd-stream read-fd :input t)))
605                  (values write-fd stream)))                  (values write-fd stream)))
606               (t               (t
607                (mach:unix-close read-fd)                (unix:unix-close read-fd)
608                (mach:unix-close write-fd)                (unix:unix-close write-fd)
609                (error "Direction must be either :INPUT or :OUTPUT, not ~S"                (error "Direction must be either :INPUT or :OUTPUT, not ~S"
610                       direction)))))                       direction)))))
611          ((or (pathnamep object) (stringp object))          ((or (pathnamep object) (stringp object))
612           (with-open-stream (file (apply #'open object keys))           (with-open-stream (file (apply #'open object keys))
613             (multiple-value-bind (won fd)             (multiple-value-bind (won fd)
614                                  (mach:unix-dup (system:fd-stream-fd file))                                  (unix:unix-dup (system:fd-stream-fd file))
615               (cond (won               (cond (won
616                      (push fd *close-in-parent*)                      (push fd *close-in-parent*)
617                      (values fd nil))                      (values fd nil))
618                     (t                     (t
619                      (error "Could not duplicate file descriptor: ~A"                      (error "Could not duplicate file descriptor: ~A"
620                             (mach:get-unix-error-msg fd)))))))                             (unix:get-unix-error-msg fd)))))))
621          ((system:fd-stream-p object)          ((system:fd-stream-p object)
622           (values (system:fd-stream-fd object) nil))           (values (system:fd-stream-fd object) nil))
623          ((streamp object)          ((streamp object)
# Line 637  Line 627 
627                        256                        256
628                        (error "Could not open a temporary file in /tmp"))                        (error "Could not open a temporary file in /tmp"))
629                (let* ((name (format nil "/tmp/.run-program-~D" count))                (let* ((name (format nil "/tmp/.run-program-~D" count))
630                       (fd (mach:unix-open name                       (fd (unix:unix-open name
631                                           (logior mach:o_rdwr                                           (logior unix:o_rdwr
632                                                   mach:o_creat                                                   unix:o_creat
633                                                   mach:o_excl)                                                   unix:o_excl)
634                                           #o666)))                                           #o666)))
635                  (mach:unix-unlink name)                  (unix:unix-unlink name)
636                  (when fd                  (when fd
637                    (let ((newline (string #\Newline)))                    (let ((newline (string #\Newline)))
638                      (loop                      (loop
# Line 651  Line 641 
641                            (read-line object nil nil)                            (read-line object nil nil)
642                          (unless line                          (unless line
643                            (return))                            (return))
644                          (mach:unix-write fd line 0 (length line))                          (unix:unix-write fd line 0 (length line))
645                          (if no-cr                          (if no-cr
646                            (return)                            (return)
647                            (mach:unix-write fd newline 0 1)))))                            (unix:unix-write fd newline 0 1)))))
648                    (mach:unix-lseek fd 0 mach:l_set)                    (unix:unix-lseek fd 0 unix:l_set)
649                    (push fd *close-in-parent*)                    (push fd *close-in-parent*)
650                    (return (values fd nil))))))                    (return (values fd nil))))))
651             (:output             (:output
652              (multiple-value-bind (read-fd write-fd)              (multiple-value-bind (read-fd write-fd)
653                                   (mach:unix-pipe)                                   (unix:unix-pipe)
654                (unless read-fd                (unless read-fd
655                  (error "Cound not create pipe: ~A"                  (error "Cound not create pipe: ~A"
656                         (mach:get-unix-error-msg write-fd)))                         (unix:get-unix-error-msg write-fd)))
657                (copy-descriptor-to-stream read-fd object cookie)                (copy-descriptor-to-stream read-fd object cookie)
658                (push read-fd *close-on-error*)                (push read-fd *close-on-error*)
659                (push write-fd *close-in-parent*)                (push write-fd *close-in-parent*)

Legend:
Removed from v.1.7  
changed lines
  Added in v.1.7.1.1

  ViewVC Help
Powered by ViewVC 1.1.5