Changeset 11816


Ignore:
Timestamp:
Mar 14, 2009, 8:33:25 AM (10 years ago)
Author:
gb
Message:

Try to ensure that exported EXTERNAL-PROCESS functions are defined
unconditionally. (EXTERNAL-PROCESS-SIGNAL is exported; it's not
clear that it can do anything useful on Windows.)

If there's an error creating a process on Windows, set the status to
:ERROR and the exit code to the value returned by #_GetLastError, then
signal the semaphores; don't signal an error in the calling thread,
and don't wait for I/O in the background thread.

When copying process output to a lisp stream on Windows, filter
out #\Return characters. (Not exactly the same as turning CRLF
into LF, but easier and usually has the same effect.)

File:
1 edited

Legend:

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

    r11759 r11816  
    517517  (declare (ignore direction))
    518518  (rlet ((handle #>HANDLE))
    519     (#_DuplicateHandle (#_GetCurrentProcess)
    520                        fd
    521                        (#_GetCurrentProcess)
    522                        handle
    523                        0
    524                        (if inheritable #$TRUE #$FALSE)
    525                        #$DUPLICATE_SAME_ACCESS)))
     519    (if (eql 0 (#_DuplicateHandle (#_GetCurrentProcess)
     520                                  (%int-to-ptr fd)
     521                                  (#_GetCurrentProcess)
     522                                  handle
     523                                  0
     524                                  (if inheritable #$TRUE #$FALSE)
     525                                  #$DUPLICATE_SAME_ACCESS))
     526      (%windows-error-disp (#_GetLastError))
     527      (pref handle #>DWORD))))
    526528
    527529
     
    13871389                           t))))))
    13881390
    1389   (defun external-process-status (proc)
    1390     "Return information about whether an OS subprocess is running; or, if
    1391 not, why not; and what its result code was if it completed."
    1392     (require-type proc 'external-process)
    1393     (values (external-process-%status proc)
    1394             (external-process-%exit-code proc)))
    1395 
    1396   (defun external-process-input-stream (proc)
    1397     "Return the lisp stream which is used to write input to a given OS
    1398 subprocess, if it has one."
    1399     (require-type proc 'external-process)
    1400     (external-process-input proc))
    1401 
    1402   (defun external-process-output-stream (proc)
    1403     "Return the lisp stream which is used to read output from a given OS
    1404 subprocess, if there is one."
    1405     (require-type proc 'external-process)
    1406     (external-process-output proc))
     1391
     1392
     1393
    14071394
    14081395  (defun external-process-error-stream (proc)
     
    14121399    (external-process-error proc))
    14131400
    1414   (defun external-process-id (proc)
    1415     "Return the process id of an OS subprocess, a positive integer which
    1416 identifies it."
    1417     (require-type proc 'external-process)
    1418     (external-process-pid proc))
     1401
    14191402 
    14201403  (defun signal-external-process (proc signal)
     
    15541537    )
    15551538
    1556   (defun external-process-status (proc)
    1557     "Return information about whether an OS subprocess is running; or, if
    1558 not, why not; and what its result code was if it completed."
    1559     (require-type proc 'external-process)
    1560     (values (external-process-%status proc)
    1561             (external-process-%exit-code proc)))
    15621539
    15631540
     
    16401617                (wait-on-semaphore (external-process-completed proc))))
    16411618          (progn
    1642             (dolist (fd close-on-error) (fd-close fd))
    1643             (error "Process execution failed"))))
     1619            (dolist (fd close-on-error) (fd-close fd)))))
    16441620      proc))
    16451621
     
    17071683            (setf (external-process-%status proc) :error
    17081684                  (external-process-%exit-code proc) (#_GetLastError))
    1709             (signal-semaphore (external-process-completed proc)))
    1710           (#_CloseHandle (pref proc-info #>PROCESS_INFORMATION.hThread)))
    1711         (pref proc-info #>PROCESS_INFORMATION.hProcess))))
     1685            (signal-semaphore (external-process-signal proc))
     1686            (signal-semaphore (external-process-completed proc))
     1687            nil)
     1688          (progn
     1689            (#_CloseHandle (pref proc-info #>PROCESS_INFORMATION.hThread))
     1690            (pref proc-info #>PROCESS_INFORMATION.hProcess))))))
    17121691
    17131692  (defun fd-uninheritable (fd &key direction)
     
    17801759                       (setf (car p) nil changed t)))
    17811760
    1782                     (let* ((string (make-string 1024)))
    1783                       (declare (dynamic-extent string))
    1784                       (%str-from-ptr buf n string)
    1785                       (write-sequence string out-stream :end n))))))))
     1761                    (let* ((string (make-string n))
     1762                           (m 0))
     1763                      (declare (dynamic-extent string)
     1764                               (fixmum m))
     1765                      ;; Not quite right: we really want to map
     1766                      ;; CRLF to #\Newline, but stripping #\Return
     1767                      ;; is usually the same thing and easier.
     1768                      (dotimes (i n)
     1769                        (let* ((code (%get-unsigned-byte buf i)))
     1770                          (unless (eql code (char-code #\Return))
     1771                            (setf (schar string m) (code-char code))
     1772                            (incf m))))
     1773                      (write-sequence string out-stream :end m)
     1774                      (force-output out-stream))))))))
    17861775        (unless terminated
    17871776          (setq terminated (eql (#_WaitForSingleObjectEx
     
    17921781 
    17931782
    1794   )                                     ; #+windows-target (progn
     1783  (defun signal-external-process (proc signal)
     1784    "Does nothing on Windows"
     1785    (declare (ignore signal))
     1786    (require-type proc 'external-process)
     1787    nil) 
     1788
     1789
     1790)
     1791                                        ;#+windows-target (progn
     1792
     1793
     1794(defun external-process-input-stream (proc)
     1795  "Return the lisp stream which is used to write input to a given OS
     1796subprocess, if it has one."
     1797  (require-type proc 'external-process)
     1798  (external-process-input proc))
     1799
     1800(defun external-process-output-stream (proc)
     1801  "Return the lisp stream which is used to read output from a given OS
     1802subprocess, if there is one."
     1803  (require-type proc 'external-process)
     1804  (external-process-output proc))
     1805
     1806
     1807(defun external-process-id (proc)
     1808  "Return the process id of an OS subprocess, a positive integer which
     1809identifies it."
     1810  (require-type proc 'external-process)
     1811  (external-process-pid proc))
     1812
     1813(defun external-process-status (proc)
     1814  "Return information about whether an OS subprocess is running; or, if
     1815not, why not; and what its result code was if it completed."
     1816  (require-type proc 'external-process)
     1817  (values (external-process-%status proc)
     1818          (external-process-%exit-code proc)))
    17951819
    17961820;;; EOF on a TTY is transient, but I'm less sure of other cases.
Note: See TracChangeset for help on using the changeset viewer.