Ignore:
Timestamp:
Dec 1, 2008, 2:31:46 PM (11 years ago)
Author:
gb
Message:

Get RUN-PROGRAM to handle multiple (:output, :error) pipes on Windows, too.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/linux-files.lisp

    r11440 r11448  
    17171717      new-fd))
    17181718
     1719 
     1720  (defun data-available-on-pipe-p (hpipe)
     1721    (rlet ((navail #>DWORD 0))
     1722      (unless (eql 0 (#_PeekNamedPipe (if (typep hpipe 'macptr)
     1723                                        hpipe
     1724                                        (%int-to-ptr hpipe))
     1725                                      (%null-ptr)
     1726                                      0
     1727                                      (%null-ptr)
     1728                                      navail
     1729                                      (%null-ptr)))
     1730        (not (eql 0 (pref navail #>DWORD))))))
     1731   
     1732
     1733  ;;; There doesn't seem to be any way to wait on input from an
     1734  ;;; anonymous pipe in Windows (that would, after all, make too
     1735  ;;; much sense.)  We -can- check for pending unread data on
     1736  ;;; pipes, and can expect to eventually get EOF on a pipe.
     1737  ;;; So, this tries to loop until the process handle is signaled and
     1738  ;;; all data has been read.
    17191739  (defun monitor-external-process (p)
    17201740    (let* ((in-fds (external-process-watched-fds p))
    17211741           (out-streams (external-process-watched-streams p))
    17221742           (token (external-process-token p))
    1723            (terminated))
     1743           (terminated)
     1744           (changed)
     1745           (pairs (pairlis in-fds out-streams))
     1746           )
    17241747      (loop
    1725         (when terminated
     1748        (when changed
     1749          (setq pairs (pairlis in-fds out-streams)
     1750                changed nil))
     1751        (when (and terminated (null pairs))
    17261752          (without-interrupts
    1727            (decf (car token))
    1728            (if in-fd (fd-close in-fd))
    1729            (setq in-fd nil)
    17301753           (rlet ((code #>DWORD))
    17311754             (loop
    17321755               (#_GetExitCodeProcess (external-process-pid p) code)
    17331756               (unless (eql (pref code #>DWORD) #$STILL_ACTIVE)
    1734                  (return)))
    1735              (#_SleepEx 10 #$TRUE)
     1757                 (return))
     1758               (#_SleepEx 10 #$TRUE))
    17361759             (setf (external-process-%exit-code p) (pref code #>DWORD)))
    17371760           (#_CloseHandle (external-process-pid p))
     
    17431766           (remove-external-process p)
    17441767           (signal-semaphore (external-process-completed p))
    1745            (return)))   
    1746         (if in-fd
    1747           (rlet ((handles (:array #>HANDLE 2)))
    1748             (setf (paref handles (:array #>HANDLE) 0) (external-process-pid p))
    1749             (setf (paref handles (:array #>HANDLE) 1) (#__get_osfhandle in-fd))
    1750             (let ((rc (ignoring-eintr
    1751                        (let* ((code (#_WaitForMultipleObjectsEx 2 handles #$FALSE #$INFINITE #$true)))
    1752                          (if (eql code #$WAIT_IO_COMPLETION)
    1753                            (- #$EINTR)
    1754                            code)))))
    1755               (if (eq rc #$WAIT_OBJECT_0)
    1756                 (setf terminated t)
    1757                 (%stack-block ((buf 1024))
    1758                   (let* ((n (fd-read in-fd buf 1024)))
     1768           (return)))
     1769        (dolist (p pairs)
     1770          (let* ((in-fd (car p))
     1771                 (out-stream (cdr p)))
     1772            (when (or terminated (data-available-on-pipe-p in-fd))
     1773              (%stack-block ((buf 1024))
     1774                (let* ((n (fd-read in-fd buf 1024)))
    17591775                    (declare (fixnum n))
    17601776                    (if (<= n 0)
    1761                       (setf terminated t)
     1777                      (progn
     1778                        (without-interrupts
     1779                         (decf (car token))
     1780                         (fd-close in-fd)
     1781                         (setq in-fds (delete in-fd in-fds)
     1782                               out-streams (delete out-stream out-streams)
     1783                               changed t)))
     1784
    17621785                      (let* ((string (make-string 1024)))
    17631786                        (declare (dynamic-extent string))
    17641787                        (%str-from-ptr buf n string)
    17651788                        (write-sequence string out-stream :end n))))))))
    1766           (progn
    1767             (ignoring-eintr
    1768              (let* ((code (#_WaitForSingleObjectEx (external-process-pid p) #$INFINITE #$true)))
    1769                (if (eql code #$WAIT_IO_COMPLETION)
    1770                  (- #$EINTR)
    1771                  code)))
    1772             (setf terminated t))))))
     1789        (unless terminated
     1790          (setq terminated (eql (#_WaitForSingleObjectEx
     1791                                 (external-process-pid p)
     1792                                 1000
     1793                                 #$true)
     1794                                #$WAIT_OBJECT_0))))))
    17731795 
    17741796
Note: See TracChangeset for help on using the changeset viewer.