/[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.31 by rtoy, Tue Apr 20 17:57:45 2010 UTC revision 1.32 by rtoy, Mon Sep 20 13:50:52 2010 UTC
# Line 325  Line 325 
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 340  Line 340 
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 454  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                        (external-format :default))
460    "RUN-PROGRAM creates a new process and runs the unix program in the    "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     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
# Line 506  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 (intl:gettext "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 526  Line 530 
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-does-not-exist :create                                      :if-does-not-exist :create
539                                      :if-exists if-output-exists)                                      :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-does-not-exist :create                                            :if-does-not-exist :create
547                                            :if-exists if-error-exists))                                            :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 644  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 674  Line 682 
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)

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

  ViewVC Help
Powered by ViewVC 1.1.5