/[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.22.2.2 by pw, Sat Mar 23 18:50:10 2002 UTC revision 1.32 by rtoy, Mon Sep 20 13:50:52 2010 UTC
# Line 19  Line 19 
19  ;;;  ;;;
20    
21  (in-package "EXTENSIONS")  (in-package "EXTENSIONS")
22    (intl:textdomain "cmucl")
23    
24  (export '(run-program process-status process-exit-code process-core-dumped  (export '(run-program process-status process-exit-code process-core-dumped
25            process-wait process-kill process-input process-output process-plist            process-wait process-kill process-input process-output process-plist
# Line 140  Line 141 
141                           unix:TIOCGPGRP                           unix:TIOCGPGRP
142                           (alien:alien-sap (alien:addr result)))                           (alien:alien-sap (alien:addr result)))
143        (unless wonp        (unless wonp
144          (error "TIOCPGRP ioctl failed: ~S"          (error (intl:gettext "TIOCPGRP ioctl failed: ~S")
145                 (unix:get-unix-error-msg error)))                 (unix:get-unix-error-msg error)))
146        result))        result))
147    (process-pid proc))    (process-pid proc))
# Line 267  Line 268 
268  ;;;  ;;;
269  #-irix  #-irix
270  (defun find-a-pty ()  (defun find-a-pty ()
271    "Returns the master fd, the slave fd, and the name of the tty"    _N"Returns the master fd, the slave fd, and the name of the tty"
272    (dolist (char '(#\p #\q))    (multiple-value-bind (error master-fd slave-fd)
273      (dotimes (digit 16)        (unix:unix-openpty nil nil nil)
274        (let* ((master-name (format nil "/dev/pty~C~X" char digit))      (when (zerop error)
275               (master-fd (unix:unix-open master-name        #-glibc2
276                                          unix:o_rdwr        (alien:with-alien ((stuff (alien:struct unix:sgttyb)))
277                                          #o666)))          (let ((sap (alien:alien-sap stuff)))
278          (when master-fd            (unix:unix-ioctl slave-fd unix:TIOCGETP sap)
279            (let* ((slave-name (format nil "/dev/tty~C~X" char digit))            (setf (alien:slot stuff 'unix:sg-flags) #o300) ; EVENP|ODDP
280                   (slave-fd (unix:unix-open slave-name            (unix:unix-ioctl slave-fd unix:TIOCSETP sap)
281                                             unix:o_rdwr            (unix:unix-ioctl master-fd unix:TIOCGETP sap)
282                                             #o666)))            (setf (alien:slot stuff 'unix:sg-flags)
283              (when slave-fd                  (logand (alien:slot stuff 'unix:sg-flags)
284                ; Maybe put a vhangup here?                          (lognot 8)))    ; ~ECHO
285                #-glibc2            (unix:unix-ioctl master-fd unix:TIOCSETP sap)))
286                (alien:with-alien ((stuff (alien:struct unix:sgttyb)))        (return-from find-a-pty
287                  (let ((sap (alien:alien-sap stuff)))                     (values master-fd
288                    (unix:unix-ioctl slave-fd unix:TIOCGETP sap)                             slave-fd
289                    (setf (alien:slot stuff 'unix:sg-flags) #o300) ; EVENP|ODDP                             (unix:unix-ttyname slave-fd))))
290                    (unix:unix-ioctl slave-fd unix:TIOCSETP sap)      (error (intl:gettext "Could not find a pty."))))
                   (unix:unix-ioctl master-fd unix:TIOCGETP sap)  
                   (setf (alien:slot stuff 'unix:sg-flags)  
                         (logand (alien:slot stuff 'unix:sg-flags)  
                                 (lognot 8))) ; ~ECHO  
                   (unix:unix-ioctl master-fd unix:TIOCSETP sap)))  
               (return-from find-a-pty  
                            (values master-fd  
                                    slave-fd  
                                    slave-name)))  
           (unix:unix-close master-fd))))))  
   (error "Could not find a pty."))  
291    
292  #+irix  #+irix
293  (alien:def-alien-routine ("_getpty" c-getpty) c-call:c-string  (alien:def-alien-routine ("_getpty" c-getpty) c-call:c-string
# Line 308  Line 298 
298    
299  #+irix  #+irix
300  (defun find-a-pty ()  (defun find-a-pty ()
301    "Returns the master fd, the slave fd, and the name of the tty"    _N"Returns the master fd, the slave fd, and the name of the tty"
302    (multiple-value-bind (line master-fd)    (multiple-value-bind (line master-fd)
303      (c-getpty (logior unix:o_rdwr unix:o_ndelay) #o600 0)      (c-getpty (logior unix:o_rdwr unix:o_ndelay) #o600 0)
304      (let* ((slave-name line)      (let* ((slave-name line)
# Line 331  Line 321 
321                               slave-fd                               slave-fd
322                               slave-name))))                               slave-name))))
323      (unix:unix-close master-fd))      (unix:unix-close master-fd))
324    (error "Could not find a pty."))    (error (intl:gettext "Could not find a pty.")))
325    
326  ;;; OPEN-PTY -- internal  ;;; OPEN-PTY -- internal
327  ;;;  ;;;
328  (defun open-pty (pty cookie)  (defun open-pty (pty cookie &optional (external-format :default))
329    (when pty    (when pty
330      (multiple-value-bind      (multiple-value-bind
331          (master slave name)          (master slave name)
# Line 345  Line 335 
335        (when (streamp pty)        (when (streamp pty)
336          (multiple-value-bind (new-fd errno) (unix:unix-dup master)          (multiple-value-bind (new-fd errno) (unix:unix-dup master)
337            (unless new-fd            (unless new-fd
338              (error "Could not UNIX:UNIX-DUP ~D: ~A"              (error (intl:gettext "Could not UNIX:UNIX-DUP ~D: ~A")
339                     master (unix:get-unix-error-msg errno)))                     master (unix:get-unix-error-msg errno)))
340            (push new-fd *close-on-error*)            (push new-fd *close-on-error*)
341            (copy-descriptor-to-stream new-fd pty cookie)))            (copy-descriptor-to-stream new-fd pty cookie)))
342        (values name        (values name
343                (system:make-fd-stream master :input t :output t)))))                (system:make-fd-stream master :input t :output t
344                                         :external-format external-format)))))
345    
346    
347  (defmacro round-bytes-to-words (n)  (defmacro round-bytes-to-words (n)
# Line 381  Line 372 
372          (let ((n (length s)))          (let ((n (length s)))
373            ;;            ;;
374            ;; Blast the string into place            ;; Blast the string into place
375              #-unicode
376            (kernel:copy-to-system-area (the simple-string s)            (kernel:copy-to-system-area (the simple-string s)
377                                        (* vm:vector-data-offset vm:word-bits)                                        (* vm:vector-data-offset vm:word-bits)
378                                        string-sap 0                                        string-sap 0
379                                        (* (1+ n) vm:byte-bits))                                        (* (1+ n) vm:byte-bits))
380              #+unicode
381              (progn
382                ;; FIXME: Do we need to apply some kind of transformation
383                ;; to convert Lisp unicode strings to C strings?  Utf-8?
384                (dotimes (k n)
385                  (setf (sap-ref-8 string-sap k)
386                        (logand #xff (char-code (aref s k)))))
387                (setf (sap-ref-8 string-sap n) 0))
388            ;;            ;;
389            ;; Blast the pointer to the string into place            ;; Blast the pointer to the string into place
390            (setf (sap-ref-sap vec-sap i) string-sap)            (setf (sap-ref-sap vec-sap i) string-sap)
# Line 421  Line 421 
421  ;;;   RUN-PROGRAM uses fork and execve to run a different program. Strange  ;;;   RUN-PROGRAM uses fork and execve to run a different program. Strange
422  ;;; stuff happens to keep the unix state of the world coherent.  ;;; stuff happens to keep the unix state of the world coherent.
423  ;;;  ;;;
424  ;;; The child process needs to get it's input from somewhere, and send it's  ;;; The child process needs to get its input from somewhere, and send its
425  ;;; output (both standard and error) to somewhere. We have to do different  ;;; output (both standard and error) to somewhere. We have to do different
426  ;;; things depending on where these somewheres really are.  ;;; things depending on where these somewheres really are.
427  ;;;  ;;;
# Line 455  Line 455 
455  (defun run-program (program args  (defun run-program (program args
456                      &key (env *environment-list*) (wait t) pty input                      &key (env *environment-list*) (wait t) pty input
457                      if-input-does-not-exist output (if-output-exists :error)                      if-input-does-not-exist output (if-output-exists :error)
458                      (error :output) (if-error-exists :error) status-hook)                      (error :output) (if-error-exists :error) status-hook
459    "Run-program creates a new process and runs the unix progam in the                      (external-format :default))
460     file specified by the simple-string program.  Args are the standard    "RUN-PROGRAM creates a new process and runs the unix program in the
461       file specified by the simple-string PROGRAM.  ARGS are the standard
462     arguments that can be passed to a Unix program, for no arguments     arguments that can be passed to a Unix program, for no arguments
463     use NIL (which means just the name of the program is passed as arg 0).     use NIL (which means just the name of the program is passed as arg 0).
464    
465     Run program will either return NIL or a PROCESS structure.  See the CMU     RUN-PROGRAM will either return NIL or a PROCESS structure.  See the CMU
466     Common Lisp Users Manual for details about the PROCESS structure.     Common Lisp Users Manual for details about the PROCESS structure.
467    
468     The keyword arguments have the following meanings:     The keyword arguments have the following meanings:
# Line 495  Line 496 
496          all the output from the process is written to this stream. If          all the output from the process is written to this stream. If
497          :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can          :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
498          be read to get the output. Defaults to NIL.          be read to get the output. Defaults to NIL.
499       :if-output-exists (when :input is the name of a file) -       :if-output-exists (when :output is the name of a file) -
500          can be one of:          can be one of:
501             :error (default) - generates an error if the file already exists.             :error (default) - generates an error if the file already exists.
502             :supersede - output from the program supersedes the file.             :supersede - output from the program supersedes the file.
# Line 507  Line 508 
508          same place as normal output.          same place as normal output.
509       :status-hook -       :status-hook -
510          This is a function the system calls whenever the status of the          This is a function the system calls whenever the status of the
511          process changes.  The function takes the process as an argument."          process changes.  The function takes the process as an argument.
512         :external-format -
513            This is the external-format used for communication with the subprocess."
514    
515    ;; Make sure the interrupt handler is installed.    ;; Make sure the interrupt handler is installed.
516    (system:enable-interrupt unix:sigchld #'sigchld-handler)    (system:enable-interrupt unix:sigchld #'sigchld-handler)
517    ;; Make sure all the args are okay.    ;; Make sure all the args are okay.
518    (unless (every #'simple-string-p args)    (unless (every #'simple-string-p args)
519      (error "All args to program must be simple strings -- ~S." args))      (error (intl:gettext "All args to program must be simple strings -- ~S.") args))
520    ;; Pre-pend the program to the argument list.    ;; Prepend the program to the argument list.
521    (push (namestring program) args)    (push (namestring program) args)
522    ;; Clear random specials used by GET-DESCRIPTOR-FOR to communicate cleanup    ;; Clear random specials used by GET-DESCRIPTOR-FOR to communicate cleanup
523    ;; info.  Also, establish proc at this level so we can return it.    ;; info.  Also, establish proc at this level so we can return it.
# Line 523  Line 526 
526          (let ((pfile (unix-namestring (merge-pathnames program "path:") t t))          (let ((pfile (unix-namestring (merge-pathnames program "path:") t t))
527                (cookie (list 0)))                (cookie (list 0)))
528            (unless pfile            (unless pfile
529              (error "No such program: ~S" program))              (error (intl:gettext "No such program: ~S") program))
530            (multiple-value-bind            (multiple-value-bind
531                (stdin input-stream)                (stdin input-stream)
532                (get-descriptor-for input cookie :direction :input                (get-descriptor-for input cookie :direction :input
533                                    :if-does-not-exist if-input-does-not-exist)                                    :if-does-not-exist if-input-does-not-exist
534                                      :external-format external-format)
535              (multiple-value-bind              (multiple-value-bind
536                  (stdout output-stream)                  (stdout output-stream)
537                  (get-descriptor-for output cookie :direction :output                  (get-descriptor-for output cookie :direction :output
538                                      :if-exists if-output-exists)                                      :if-does-not-exist :create
539                                        :if-exists if-output-exists
540                                        :external-format external-format)
541                (multiple-value-bind                (multiple-value-bind
542                    (stderr error-stream)                    (stderr error-stream)
543                    (if (eq error :output)                    (if (eq error :output)
544                        (values stdout output-stream)                        (values stdout output-stream)
545                        (get-descriptor-for error cookie :direction :output                        (get-descriptor-for error cookie :direction :output
546                                            :if-exists if-error-exists))                                            :if-does-not-exist :create
547                                              :if-exists if-error-exists
548                                              :external-format external-format))
549                  (multiple-value-bind (pty-name pty-stream)                  (multiple-value-bind (pty-name pty-stream)
550                                       (open-pty pty cookie)                                       (open-pty pty cookie external-format)
551                    ;; Make sure we are not notified about the child death before                    ;; Make sure we are not notified about the child death before
552                    ;; we have installed the process struct in *active-processes*                    ;; we have installed the process struct in *active-processes*
553                    (system:without-interrupts                    (system:without-interrupts
# Line 557  Line 565 
565                                  (spawn pfile argv envp pty-name                                  (spawn pfile argv envp pty-name
566                                         stdin stdout stderr))))                                         stdin stdout stderr))))
567                            (when (< child-pid 0)                            (when (< child-pid 0)
568                              (error "Could not fork child process: ~A"                              (error (intl:gettext "Could not fork child process: ~A")
569                                     (unix:get-unix-error-msg)))                                     (unix:get-unix-error-msg)))
570                            (setf proc (make-process :pid child-pid                            (setf proc (make-process :pid child-pid
571                                                     :%status :running                                                     :%status :running
# Line 600  Line 608 
608                        (unix:unix-select (1+ descriptor) (ash 1 descriptor)                        (unix:unix-select (1+ descriptor) (ash 1 descriptor)
609                                          0 0 0)                                          0 0 0)
610                      (cond ((null result)                      (cond ((null result)
611                             (error "Could not select on sub-process: ~A"                             (error (intl:gettext "Could not select on sub-process: ~A")
612                                    (unix:get-unix-error-msg readable/errno)))                                    (unix:get-unix-error-msg readable/errno)))
613                            ((zerop result)                            ((zerop result)
614                             (return))))                             (return))))
# Line 620  Line 628 
628                               (system:remove-fd-handler handler)                               (system:remove-fd-handler handler)
629                               (setf handler nil)                               (setf handler nil)
630                               (decf (car cookie))                               (decf (car cookie))
631                               (error "Could not read input from sub-process: ~A"                               (error (intl:gettext "Could not read input from sub-process: ~A")
632                                      (unix:get-unix-error-msg errno)))                                      (unix:get-unix-error-msg errno)))
633                              (t                              (t
634                                 #-unicode
635                               (kernel:copy-from-system-area                               (kernel:copy-from-system-area
636                                (alien-sap buf) 0                                (alien-sap buf) 0
637                                string (* vm:vector-data-offset vm:word-bits)                                string (* vm:vector-data-offset vm:word-bits)
638                                (* count vm:byte-bits))                                (* count vm:byte-bits))
639                                 #+unicode
640                                 (let ((sap (alien-sap buf)))
641                                   (dotimes (k count)
642                                     (setf (aref string k)
643                                           (code-char (sap-ref-8 sap k)))))
644                               (write-string string stream                               (write-string string stream
645                                             :end count)))))))))))                                             :end count)))))))))))
646    
# Line 637  Line 651 
651  ;;; second value.  ;;; second value.
652  ;;;  ;;;
653  (defun get-descriptor-for (object cookie &rest keys &key direction  (defun get-descriptor-for (object cookie &rest keys &key direction
654                                                             external-format
655                                    &allow-other-keys)                                    &allow-other-keys)
656    (cond ((eq object t)    (cond ((eq object t)
657           ;; No new descriptor is needed.           ;; No new descriptor is needed.
# Line 652  Line 667 
667                                 (t unix:o_rdwr))                                 (t unix:o_rdwr))
668                               #o666)                               #o666)
669             (unless fd             (unless fd
670               (error "Could not open \"/dev/null\": ~A"               (error (intl:gettext "Could not open \"/dev/null\": ~A")
671                      (unix:get-unix-error-msg errno)))                      (unix:get-unix-error-msg errno)))
672             (push fd *close-in-parent*)             (push fd *close-in-parent*)
673             (values fd nil)))             (values fd nil)))
# Line 661  Line 676 
676               (read-fd write-fd)               (read-fd write-fd)
677               (unix:unix-pipe)               (unix:unix-pipe)
678             (unless read-fd             (unless read-fd
679               (error "Could not create pipe: ~A"               (error (intl:gettext "Could not create pipe: ~A")
680                      (unix:get-unix-error-msg write-fd)))                      (unix:get-unix-error-msg write-fd)))
681             (case direction             (case direction
682               (:input               (:input
683                (push read-fd *close-in-parent*)                (push read-fd *close-in-parent*)
684                (push write-fd *close-on-error*)                (push write-fd *close-on-error*)
685                (let ((stream (system:make-fd-stream write-fd :output t)))                (let ((stream (system:make-fd-stream write-fd :output t
686                                                       :external-format
687                                                       external-format)))
688                  (values read-fd stream)))                  (values read-fd stream)))
689               (:output               (:output
690                (push read-fd *close-on-error*)                (push read-fd *close-on-error*)
691                (push write-fd *close-in-parent*)                (push write-fd *close-in-parent*)
692                (let ((stream (system:make-fd-stream read-fd :input t)))                (let ((stream (system:make-fd-stream read-fd :input t
693                                                       :external-format
694                                                       external-format)))
695                  (values write-fd stream)))                  (values write-fd stream)))
696               (t               (t
697                (unix:unix-close read-fd)                (unix:unix-close read-fd)
698                (unix:unix-close write-fd)                (unix:unix-close write-fd)
699                (error "Direction must be either :INPUT or :OUTPUT, not ~S"                (error (intl:gettext "Direction must be either :INPUT or :OUTPUT, not ~S")
700                       direction)))))                       direction)))))
701          ((or (pathnamep object) (stringp object))          ((or (pathnamep object) (stringp object))
702           (with-open-stream (file (apply #'open object keys))           (with-open-stream (file (apply #'open object keys))
# Line 688  Line 707 
707                      (push fd *close-in-parent*)                      (push fd *close-in-parent*)
708                      (values fd nil))                      (values fd nil))
709                     (t                     (t
710                      (error "Could not duplicate file descriptor: ~A"                      (error (intl:gettext "Could not duplicate file descriptor: ~A")
711                             (unix:get-unix-error-msg errno)))))))                             (unix:get-unix-error-msg errno)))))))
712          ((system:fd-stream-p object)          ((system:fd-stream-p object)
713           (values (system:fd-stream-fd object) nil))           (values (system:fd-stream-fd object) nil))
# Line 697  Line 716 
716             (:input             (:input
717              (dotimes (count              (dotimes (count
718                        256                        256
719                        (error "Could not open a temporary file in /tmp"))                        (error (intl:gettext "Could not open a temporary file in /tmp")))
720                (let* ((name (format nil "/tmp/.run-program-~D" count))                (let* ((name (format nil "/tmp/.run-program-~D" count))
721                       (fd (unix:unix-open name                       (fd (unix:unix-open name
722                                           (logior unix:o_rdwr                                           (logior unix:o_rdwr
# Line 724  Line 743 
743              (multiple-value-bind (read-fd write-fd)              (multiple-value-bind (read-fd write-fd)
744                                   (unix:unix-pipe)                                   (unix:unix-pipe)
745                (unless read-fd                (unless read-fd
746                  (error "Cound not create pipe: ~A"                  (error (intl:gettext "Cound not create pipe: ~A")
747                         (unix:get-unix-error-msg write-fd)))                         (unix:get-unix-error-msg write-fd)))
748                (copy-descriptor-to-stream read-fd object cookie)                (copy-descriptor-to-stream read-fd object cookie)
749                (push read-fd *close-on-error*)                (push read-fd *close-on-error*)
750                (push write-fd *close-in-parent*)                (push write-fd *close-in-parent*)
751                (values write-fd nil)))))                (values write-fd nil)))))
752          (t          (t
753           (error "Invalid option to run-program: ~S" object))))           (error (intl:gettext "Invalid option to run-program: ~S") object))))
754    

Legend:
Removed from v.1.22.2.2  
changed lines
  Added in v.1.32

  ViewVC Help
Powered by ViewVC 1.1.5