Ignore:
Timestamp:
Nov 27, 2008, 6:14:20 PM (11 years ago)
Author:
gb
Message:

Try to address ticket:216 (:sharing in streams created by RUN-PROGRAM)
and ticket:318 (handling of internal pipes when :output and :error
are specified and disjoint.)

N.B. : the Windows code is half-implemented; need to check this in
to get it working on Windows.

File:
1 edited

Legend:

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

    r11309 r11440  
    974974#-windows-target
    975975(progn
    976 (defun %execvp (argv)
    977   (#_execvp (%get-ptr argv) argv)
    978   (#_exit #$EX_OSERR))
    979 
    980 (defun exec-with-io-redirection (new-in new-out new-err argv)
    981   (#_setpgid 0 0)
    982   (if new-in (#_dup2 new-in 0))
    983   (if new-out (#_dup2 new-out 1))
    984   (if new-err (#_dup2 new-err 2))
    985   (do* ((fd 3 (1+ fd)))
    986        ((= fd *max-os-open-files*) (%execvp argv))
    987     (declare (fixnum fd))
    988     (#_close fd)))
    989 
    990 
    991 
    992 
    993 
    994 (defstruct external-process
    995   pid
    996   %status
    997   %exit-code
    998   pty
    999   input
    1000   output
    1001   error
    1002   status-hook
    1003   plist
    1004   token
    1005   core
    1006   args
    1007   (signal (make-semaphore))
    1008   (completed (make-semaphore))
    1009   watched-fd
    1010   watched-stream
    1011   )
    1012 
    1013 (defmethod print-object ((p external-process) stream)
    1014   (print-unreadable-object (p stream :type t :identity t)
    1015     (let* ((status (external-process-%status p)))
    1016       (let* ((*print-length* 3))
    1017         (format stream "~a" (external-process-args p)))
    1018       (format stream "[~d] (~a" (external-process-pid p) status)
    1019       (unless (eq status :running)
    1020         (format stream " : ~d" (external-process-%exit-code p)))
    1021       (format stream ")"))))
    1022 
    1023 (defun get-descriptor-for (object proc close-in-parent close-on-error
    1024                                   &rest keys &key direction (element-type 'character)
    1025                                   &allow-other-keys)
    1026   (etypecase object
    1027     ((eql t)
    1028      (values nil nil close-in-parent close-on-error))
    1029     (null
    1030      (let* ((null-device #+windows-target "nul" #-windows-target "/dev/null")
    1031             (fd (fd-open null-device (case direction
    1032                                        (:input #$O_RDONLY)
    1033                                        (:output #$O_WRONLY)
    1034                                        (t #$O_RDWR)))))
    1035        (if (< fd 0)
    1036          (signal-file-error fd null-device))
    1037        (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
    1038     ((eql :stream)
    1039      (multiple-value-bind (read-pipe write-pipe) (pipe)
    1040        (case direction
    1041          (:input
    1042           (values read-pipe
    1043                   (make-fd-stream write-pipe
    1044                                   :direction :output
    1045                                   :element-type element-type
    1046                                   :interactive nil
    1047                                   :basic t
    1048                                   :auto-close t)
    1049                   (cons read-pipe close-in-parent)
    1050                   (cons write-pipe close-on-error)))
    1051          (:output
    1052           (values write-pipe
    1053                   (make-fd-stream read-pipe
    1054                                   :direction :input
    1055                                   :element-type element-type
    1056                                   :interactive nil
    1057                                   :basic t
    1058                                   :auto-close t)
    1059                   (cons write-pipe close-in-parent)
    1060                   (cons read-pipe close-on-error)))
    1061          (t
    1062           (fd-close read-pipe)
    1063           (fd-close write-pipe)
    1064           (report-bad-arg direction '(member :input :output))))))
    1065     ((or pathname string)
    1066      (with-open-stream (file (apply #'open object keys))
    1067        (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t)))))
     976  (defun %execvp (argv)
     977    (#_execvp (%get-ptr argv) argv)
     978    (#_exit #$EX_OSERR))
     979
     980  (defun exec-with-io-redirection (new-in new-out new-err argv)
     981    (#_setpgid 0 0)
     982    (if new-in (#_dup2 new-in 0))
     983    (if new-out (#_dup2 new-out 1))
     984    (if new-err (#_dup2 new-err 2))
     985    (do* ((fd 3 (1+ fd)))
     986         ((= fd *max-os-open-files*) (%execvp argv))
     987      (declare (fixnum fd))
     988      (#_close fd)))
     989
     990
     991
     992
     993
     994  (defstruct external-process
     995    pid
     996    %status
     997    %exit-code
     998    pty
     999    input
     1000    output
     1001    error
     1002    status-hook
     1003    plist
     1004    token                               
     1005    core
     1006    args
     1007    (signal (make-semaphore))
     1008    (completed (make-semaphore))
     1009    watched-fds
     1010    watched-streams
     1011    )
     1012
     1013  (defmethod print-object ((p external-process) stream)
     1014    (print-unreadable-object (p stream :type t :identity t)
     1015      (let* ((status (external-process-%status p)))
     1016        (let* ((*print-length* 3))
     1017          (format stream "~a" (external-process-args p)))
     1018        (format stream "[~d] (~a" (external-process-pid p) status)
     1019        (unless (eq status :running)
     1020          (format stream " : ~d" (external-process-%exit-code p)))
     1021        (format stream ")"))))
     1022
     1023  (defun get-descriptor-for (object proc close-in-parent close-on-error
     1024                                    &rest keys
     1025                                    &key direction (element-type 'character)
     1026                                    (sharing :private)
     1027                                    &allow-other-keys)
     1028    (etypecase object
     1029      ((eql t)
     1030       (values nil nil close-in-parent close-on-error))
     1031      (null
     1032       (let* ((null-device #+windows-target "nul" #-windows-target "/dev/null")
     1033              (fd (fd-open null-device (case direction
     1034                                         (:input #$O_RDONLY)
     1035                                         (:output #$O_WRONLY)
     1036                                         (t #$O_RDWR)))))
     1037         (if (< fd 0)
     1038           (signal-file-error fd null-device))
     1039         (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
     1040      ((eql :stream)
     1041       (multiple-value-bind (read-pipe write-pipe) (pipe)
     1042         (case direction
     1043           (:input
     1044            (values read-pipe
     1045                    (make-fd-stream write-pipe
     1046                                    :direction :output
     1047                                    :element-type element-type
     1048                                    :interactive nil
     1049                                    :sharing sharing
     1050                                    :basic t
     1051                                    :auto-close t)
     1052                    (cons read-pipe close-in-parent)
     1053                    (cons write-pipe close-on-error)))
     1054           (:output
     1055            (values write-pipe
     1056                    (make-fd-stream read-pipe
     1057                                    :direction :input
     1058                                    :element-type element-type
     1059                                    :interactive nil
     1060                                    :basic t
     1061                                    :sharing sharing
     1062                                    :auto-close t)
     1063                    (cons write-pipe close-in-parent)
     1064                    (cons read-pipe close-on-error)))
     1065           (t
     1066            (fd-close read-pipe)
     1067            (fd-close write-pipe)
     1068            (report-bad-arg direction '(member :input :output))))))
     1069      ((or pathname string)
     1070       (with-open-stream (file (apply #'open object keys))
     1071         (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t)))))
     1072           (values fd
     1073                   nil
     1074                   (cons fd close-in-parent)
     1075                   (cons fd close-on-error)))))
     1076      (fd-stream
     1077       (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
    10681078         (values fd
    10691079                 nil
    10701080                 (cons fd close-in-parent)
    1071                  (cons fd close-on-error)))))
    1072     (fd-stream
    1073      (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
    1074        (values fd
    1075                nil
    1076                (cons fd close-in-parent)
    1077                (cons fd close-on-error))))
    1078     (stream
    1079      (ecase direction
    1080        (:input
    1081         (with-cstrs ((template "/tmp/lisp-tempXXXXXX"))
    1082           (let* ((fd (#_mkstemp template)))
    1083             (if (< fd 0)
    1084               (%errno-disp fd))
    1085             (#_unlink template)
    1086             (loop
     1081                 (cons fd close-on-error))))
     1082      (stream
     1083       (ecase direction
     1084         (:input
     1085          (with-cstrs ((template "/tmp/lisp-tempXXXXXX"))
     1086            (let* ((fd (#_mkstemp template)))
     1087              (if (< fd 0)
     1088                (%errno-disp fd))
     1089              (#_unlink template)
     1090              (loop
     1091                (multiple-value-bind (line no-newline)
     1092                    (read-line object nil nil)
     1093                  (unless line
     1094                    (return))
     1095                  (let* ((len (length line)))
     1096                    (%stack-block ((buf (1+ len)))
     1097                      (%cstr-pointer line buf)
     1098                      (fd-write fd buf len)
     1099                      (if no-newline
     1100                        (return))
     1101                      (setf (%get-byte buf) (char-code #\newline))
     1102                      (fd-write fd buf 1)))))
     1103              (fd-lseek fd 0 #$SEEK_SET)
     1104              (values fd nil (cons fd close-in-parent) (cons fd close-on-error)))))
     1105         (:output
     1106          (multiple-value-bind (read-pipe write-pipe) (pipe)
     1107            (push read-pipe (external-process-watched-fds proc))
     1108            (push object (external-process-watched-streams proc))
     1109            (incf (car (external-process-token proc)))
     1110            (values write-pipe
     1111                    nil
     1112                    (cons write-pipe close-in-parent)
     1113                    (cons read-pipe close-on-error))))))))
     1114
     1115  (let* ((external-processes ())
     1116         (external-processes-lock (make-lock)))
     1117    (defun add-external-process (p)
     1118      (with-lock-grabbed (external-processes-lock)
     1119        (push p external-processes)))
     1120    (defun remove-external-process (p)
     1121      (with-lock-grabbed (external-processes-lock)
     1122        (setq external-processes (delete p external-processes))))
     1123    ;; Likewise
     1124    (defun external-processes ()
     1125      (with-lock-grabbed (external-processes-lock)
     1126        (copy-list external-processes)))
     1127    )
     1128
     1129
     1130  (defmacro wtermsig (status)
     1131    `(ldb (byte 7 0) ,status))
     1132
     1133  (defmacro wexitstatus (status)
     1134    `(ldb (byte 8 8) (the fixnum ,status)))
     1135
     1136  (defmacro wstopsig (status)
     1137    `(wexitstatus ,status))
     1138
     1139  (defmacro wifexited (status)
     1140    `(eql (wtermsig ,status) 0))
     1141
     1142  (defmacro wifstopped (status)
     1143    `(eql #x7f (ldb (byte 7 0) (the fixnum ,status))))
     1144
     1145  (defun monitor-external-process (p)
     1146    (let* ((in-fds (external-process-watched-fds p))
     1147           (out-streams (external-process-watched-streams p))
     1148           (token (external-process-token p))
     1149           (terminated)
     1150           (changed)
     1151           (maxfd 0)
     1152           (pairs (pairlis in-fds out-streams)))
     1153      (%stack-block ((in-fd-set *fd-set-size*))
     1154        (rlet ((tv #>timeval))
     1155          (loop
     1156            (when changed
     1157              (setq pairs (pairlis in-fds out-streams)
     1158                    changed nil))
     1159            (when (and terminated (null pairs))
     1160              (signal-semaphore (external-process-completed p))
     1161              (return))
     1162            (when pairs
     1163              (fd-zero in-fd-set)
     1164              (setq maxfd 0)
     1165              (dolist (p pairs)
     1166                (let* ((fd (car p)))
     1167                  (when (> fd maxfd)
     1168                    (setq maxfd fd))
     1169                  (fd-set fd in-fd-set)))
     1170              (setf (pref tv #>timeval.tv_sec) 1
     1171                    (pref tv #>timeval.tv_usec) 0)
     1172              (when (> (#_select (1+ maxfd) in-fd-set (%null-ptr) (%null-ptr) tv)
     1173                       0)
     1174                (dolist (p pairs)
     1175                  (let* ((in-fd (car p))
     1176                         (out-stream (cdr p)))
     1177                    (when (fd-is-set in-fd in-fd-set)
     1178                      (%stack-block ((buf 1024))
     1179                        (let* ((n (fd-read in-fd buf 1024)))
     1180                          (declare (fixnum n))
     1181                          (if (<= n 0)
     1182                            (progn
     1183                              (without-interrupts
     1184                               (decf (car token))
     1185                               (fd-close in-fd)
     1186                               (setq in-fds (delete in-fd in-fds)
     1187                                     out-streams (delete out-stream out-streams)
     1188                                     changed t)))
     1189                            (let* ((string (make-string 1024)))
     1190                              (declare (dynamic-extent string))
     1191                              (%str-from-ptr buf n string)
     1192                              (write-sequence string out-stream :end n))))))))))
     1193            (let* ((statusflags (check-pid (external-process-pid p)
     1194                                           (logior
     1195                                            (if in-fds #$WNOHANG 0)
     1196                                            #$WUNTRACED)))
     1197                   (oldstatus (external-process-%status p)))
     1198              (cond ((null statusflags)
     1199                     (remove-external-process p)
     1200                     (setq terminated t))
     1201                    ((eq statusflags t)) ; Running.
     1202                    (t
     1203                     (multiple-value-bind (status code core)
     1204                         (cond ((wifstopped statusflags)
     1205                                (values :stopped (wstopsig statusflags)))
     1206                               ((wifexited statusflags)
     1207                                (values :exited (wexitstatus statusflags)))
     1208                               (t
     1209                                (let* ((signal (wtermsig statusflags)))
     1210                                  (declare (fixnum signal))
     1211                                  (values
     1212                                   (if (or (= signal #$SIGSTOP)
     1213                                           (= signal #$SIGTSTP)
     1214                                           (= signal #$SIGTTIN)
     1215                                           (= signal #$SIGTTOU))
     1216                                     :stopped
     1217                                     :signaled)
     1218                                   signal
     1219                                   (logtest #-solaris-target #$WCOREFLAG
     1220                                            #+solaris-target #$WCOREFLG
     1221                                            statusflags)))))
     1222                       (setf (external-process-%status p) status
     1223                             (external-process-%exit-code p) code
     1224                             (external-process-core p) core)
     1225                       (let* ((status-hook (external-process-status-hook p)))
     1226                         (when (and status-hook (not (eq oldstatus status)))
     1227                           (funcall status-hook p)))
     1228                       (when (or (eq status :exited)
     1229                                 (eq status :signaled))
     1230                         (remove-external-process p)
     1231                         (setq terminated t)))))))))))
     1232     
     1233  (defun run-external-process (proc in-fd out-fd error-fd argv &optional env)
     1234    (let* ((signaled nil))
     1235      (unwind-protect
     1236           (let* ((child-pid (#-solaris-target #_fork #+solaris-target #_forkall)))
     1237             (declare (fixnum child-pid))
     1238             (cond ((zerop child-pid)
     1239                    ;; Running in the child; do an exec
     1240                    (setq signaled t)
     1241                    (dolist (pair env)
     1242                      (setenv (string (car pair)) (cdr pair)))
     1243                    (without-interrupts
     1244                     (exec-with-io-redirection
     1245                      in-fd out-fd error-fd argv)))
     1246                   ((> child-pid 0)
     1247                    ;; Running in the parent: success
     1248                    (setf (external-process-pid proc) child-pid)
     1249                    (add-external-process proc)
     1250                    (signal-semaphore (external-process-signal proc))
     1251                    (setq signaled t)
     1252                    (monitor-external-process proc))
     1253                   (t
     1254                    ;; Fork failed
     1255                    (setf (external-process-%status proc) :error
     1256                          (external-process-%exit-code proc) (%get-errno))
     1257                    (signal-semaphore (external-process-signal proc))
     1258                    (setq signaled t))))
     1259        (unless signaled
     1260          (setf (external-process-%status proc) :error
     1261                (external-process-%exit-code proc) -1)
     1262          (signal-semaphore (external-process-signal proc))))))
     1263
     1264  (defparameter *silently-ignore-catastrophic-failure-in-run-program*
     1265    #+ccl-0711 t #-ccl-0711 nil
     1266    "If NIL, signal an error if run-program is unable to start the program.
     1267If non-NIL, treat failure to start the same as failure from the program
     1268itself, by setting the status and exit-code fields.")
     1269
     1270  (defun run-program (program args &key
     1271                              (wait t) pty
     1272                              input if-input-does-not-exist
     1273                              output (if-output-exists :error)
     1274                              (error :output) (if-error-exists :error)
     1275                              status-hook (element-type 'character)
     1276                              env
     1277                              (sharing :private)
     1278                              (silently-ignore-catastrophic-failures
     1279                               *silently-ignore-catastrophic-failure-in-run-program*))
     1280    "Invoke an external program as an OS subprocess of lisp."
     1281    (declare (ignore pty))
     1282    (unless (every #'(lambda (a) (typep a 'simple-string)) args)
     1283      (error "Program args must all be simple strings : ~s" args))
     1284    (dolist (pair env)
     1285      (destructuring-bind (var . val) pair
     1286        (check-type var (or string symbol character))
     1287        (check-type val string)))
     1288    (push (native-untranslated-namestring program) args)
     1289    (let* ((token (list 0))
     1290           (in-fd nil)
     1291           (in-stream nil)
     1292           (out-fd nil)
     1293           (out-stream nil)
     1294           (error-fd nil)
     1295           (error-stream nil)
     1296           (close-in-parent nil)
     1297           (close-on-error nil)
     1298           (proc
     1299            (make-external-process
     1300             :pid nil
     1301             :args args
     1302             :%status :running
     1303             :input nil
     1304             :output nil
     1305             :error nil
     1306             :token token
     1307             :status-hook status-hook)))
     1308      (unwind-protect
     1309           (progn
     1310             (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
     1311               (get-descriptor-for input proc  nil nil :direction :input
     1312                                   :if-does-not-exist if-input-does-not-exist
     1313                                   :element-type element-type
     1314                                   :sharing sharing))
     1315             (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
     1316               (get-descriptor-for output proc close-in-parent close-on-error
     1317                                   :direction :output
     1318                                   :if-exists if-output-exists
     1319                                   :element-type element-type
     1320                                   :sharing sharing))
     1321             (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
     1322               (if (eq error :output)
     1323                 (values out-fd out-stream close-in-parent close-on-error)
     1324                 (get-descriptor-for error proc close-in-parent close-on-error
     1325                                     :direction :output
     1326                                     :if-exists if-error-exists
     1327                                     :sharing sharing
     1328                                     :element-type element-type)))
     1329             (setf (external-process-input proc) in-stream
     1330                   (external-process-output proc) out-stream
     1331                   (external-process-error proc) error-stream)
     1332             (call-with-string-vector
     1333              #'(lambda (argv)
     1334                  (process-run-function
     1335                   (list :name
     1336                         (format nil "Monitor thread for external process ~a" args)
     1337                         :stack-size (ash 128 10)
     1338                         :vstack-size (ash 128 10)
     1339                         :tstack-size (ash 128 10))
     1340                   #'run-external-process proc in-fd out-fd error-fd argv env)
     1341                  (wait-on-semaphore (external-process-signal proc)))
     1342              args))
     1343        (dolist (fd close-in-parent) (fd-close fd))
     1344        (unless (external-process-pid proc)
     1345          (dolist (fd close-on-error) (fd-close fd)))
     1346        (when (and wait (external-process-pid proc))
     1347          (with-interrupts-enabled
     1348              (wait-on-semaphore (external-process-completed proc)))))
     1349      (unless (external-process-pid proc)
     1350        ;; something is wrong
     1351        (if (eq (external-process-%status proc) :error)
     1352          ;; Fork failed
     1353          (unless silently-ignore-catastrophic-failures
     1354            (cerror "Pretend the program ran and failed" 'external-process-creation-failure :proc proc))
     1355          ;; Currently can't happen.
     1356          (error "Bug: fork failed but status field not set?")))
     1357      proc))
     1358
     1359
     1360
     1361  (defmacro wifsignaled (status)
     1362    (let* ((statname (gensym)))
     1363      `(let* ((,statname ,status))
     1364        (and (not (wifstopped ,statname)) (not (wifexited ,statname))))))
     1365
     1366
     1367  (defun check-pid (pid &optional (flags (logior  #$WNOHANG #$WUNTRACED)))
     1368    (declare (fixnum pid))
     1369    (rlet ((status :signed))
     1370      (let* ((retval (ff-call-ignoring-eintr (#_waitpid pid status flags))))
     1371        (declare (fixnum retval))
     1372        (if (= retval pid)
     1373          (pref status :signed)
     1374          (zerop retval)))))
     1375
     1376
     1377
     1378
     1379
     1380  (defun external-process-wait (proc &optional check-stopped)
     1381    (process-wait "external-process-wait"
     1382                  #'(lambda ()
     1383                      (case (external-process-%status proc)
     1384                        (:running)
     1385                        (:stopped
     1386                         (when check-stopped
     1387                           t))
     1388                        (t
     1389                         (when (zerop (car (external-process-token proc)))
     1390                           t))))))
     1391
     1392  (defun external-process-status (proc)
     1393    "Return information about whether an OS subprocess is running; or, if
     1394not, why not; and what its result code was if it completed."
     1395    (require-type proc 'external-process)
     1396    (values (external-process-%status proc)
     1397            (external-process-%exit-code proc)))
     1398
     1399  (defun external-process-input-stream (proc)
     1400    "Return the lisp stream which is used to write input to a given OS
     1401subprocess, if it has one."
     1402    (require-type proc 'external-process)
     1403    (external-process-input proc))
     1404
     1405  (defun external-process-output-stream (proc)
     1406    "Return the lisp stream which is used to read output from a given OS
     1407subprocess, if there is one."
     1408    (require-type proc 'external-process)
     1409    (external-process-output proc))
     1410
     1411  (defun external-process-error-stream (proc)
     1412    "Return the stream which is used to read error output from a given OS
     1413subprocess, if it has one."
     1414    (require-type proc 'external-process)
     1415    (external-process-error proc))
     1416
     1417  (defun external-process-id (proc)
     1418    "Return the process id of an OS subprocess, a positive integer which
     1419identifies it."
     1420    (require-type proc 'external-process)
     1421    (external-process-pid proc))
     1422 
     1423  (defun signal-external-process (proc signal)
     1424    "Send the specified signal to the specified external process.  (Typically,
     1425it would only be useful to call this function if the EXTERNAL-PROCESS was
     1426created with :WAIT NIL.) Return T if successful; NIL if the process wasn't
     1427created successfully, and signal an error otherwise."
     1428    (require-type proc 'external-process)
     1429    (let* ((pid (external-process-pid proc)))
     1430      (when pid
     1431        (let ((error (int-errno-call (#_kill pid signal))))
     1432          (or (eql error 0)
     1433              (%errno-disp error))))))
     1434
     1435  )                                     ; #-windows-target (progn
     1436
     1437#+windows-target
     1438(progn
     1439  (defun temp-file-name (prefix)
     1440    "Returns a unique name for a temporary file, residing in system temp
     1441space, and prefixed with PREFIX."
     1442    (rlet ((buffer (:array :wchar_t #.#$MAX_PATH)))
     1443      (#_GetTempPathW #$MAX_PATH buffer)
     1444      (with-filename-cstrs ((c-prefix prefix))
     1445        (#_GetTempFileNameW buffer c-prefix 0 buffer)
     1446        (%get-native-utf-16-cstring buffer))))
     1447 
     1448  (defun get-descriptor-for (object proc close-in-parent close-on-error
     1449                                    &rest keys
     1450                                    &key
     1451                                    direction (element-type 'character)
     1452                                    (sharing :private)
     1453                                    &allow-other-keys)
     1454    (etypecase object
     1455      ((eql t)
     1456       (values nil nil close-in-parent close-on-error))
     1457      (null
     1458       (let* ((null-device "nul")
     1459              (fd (fd-open null-device (case direction
     1460                                         (:input #$O_RDONLY)
     1461                                         (:output #$O_WRONLY)
     1462                                         (t #$O_RDWR)))))
     1463         (if (< fd 0)
     1464           (signal-file-error fd null-device))
     1465         (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
     1466      ((eql :stream)
     1467       (multiple-value-bind (read-pipe write-pipe) (pipe)
     1468         (case direction
     1469           (:input
     1470            (values read-pipe
     1471                    (make-fd-stream (fd-uninheritable write-pipe :direction :output)
     1472                                    :direction :output
     1473                                    :element-type element-type
     1474                                    :interactive nil
     1475                                    :basic t
     1476                                    :sharing sharing
     1477                                    :auto-close t)
     1478                    (cons read-pipe close-in-parent)
     1479                    (cons write-pipe close-on-error)))
     1480           (:output
     1481            (values write-pipe
     1482                    (make-fd-stream (fd-uninheritable read-pipe :direction :input)
     1483                                    :direction :input
     1484                                    :element-type element-type
     1485                                    :interactive nil
     1486                                    :basic t
     1487                                    :sharing sharing
     1488                                    :auto-close t)
     1489                    (cons write-pipe close-in-parent)
     1490                    (cons read-pipe close-on-error)))
     1491           (t
     1492            (fd-close read-pipe)
     1493            (fd-close write-pipe)
     1494            (report-bad-arg direction '(member :input :output))))))
     1495      ((or pathname string)
     1496       (with-open-stream (file (apply #'open object keys))
     1497         (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t)) :direction direction :inheritable t)))
     1498           (values fd
     1499                   nil
     1500                   (cons fd close-in-parent)
     1501                   (cons fd close-on-error)))))
     1502      (fd-stream
     1503       (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
     1504         (values fd
     1505                 nil
     1506                 (cons fd close-in-parent)
     1507                 (cons fd close-on-error))))
     1508      (stream
     1509       (ecase direction
     1510         (:input
     1511          (let* ((tempname (temp-file-name "lisp-temp"))
     1512                 (fd (fd-open tempname #$O_RDWR)))
     1513            (if (< fd 0)
     1514              (%errno-disp fd))
     1515            (loop
    10871516              (multiple-value-bind (line no-newline)
    10881517                  (read-line object nil nil)
     
    10971526                    (setf (%get-byte buf) (char-code #\newline))
    10981527                    (fd-write fd buf 1)))))
    1099             (fd-lseek fd 0 #$SEEK_SET)
    1100             (values fd nil (cons fd close-in-parent) (cons fd close-on-error)))))
    1101        (:output
    1102         (multiple-value-bind (read-pipe write-pipe) (pipe)
    1103           (setf (external-process-watched-fd proc) read-pipe
    1104                 (external-process-watched-stream proc) object)
    1105           (incf (car (external-process-token proc)))
    1106           (values write-pipe
    1107                   nil
    1108                   (cons write-pipe close-in-parent)
    1109                   (cons read-pipe close-on-error))))))))
    1110 
    1111 (let* ((external-processes ())
    1112        (external-processes-lock (make-lock)))
    1113   (defun add-external-process (p)
    1114     (with-lock-grabbed (external-processes-lock)
    1115       (push p external-processes)))
    1116   (defun remove-external-process (p)
    1117     (with-lock-grabbed (external-processes-lock)
    1118       (setq external-processes (delete p external-processes))))
    1119   ;; Likewise
    1120   (defun external-processes ()
    1121     (with-lock-grabbed (external-processes-lock)
    1122       (copy-list external-processes)))
    1123   )
    1124 
    1125 
    1126 (defmacro wtermsig (status)
    1127   `(ldb (byte 7 0) ,status))
    1128 
    1129 (defmacro wexitstatus (status)
    1130   `(ldb (byte 8 8) (the fixnum ,status)))
    1131 
    1132 (defmacro wstopsig (status)
    1133   `(wexitstatus ,status))
    1134 
    1135 (defmacro wifexited (status)
    1136   `(eql (wtermsig ,status) 0))
    1137 
    1138 (defmacro wifstopped (status)
    1139   `(eql #x7f (ldb (byte 7 0) (the fixnum ,status))))
    1140 
    1141 (defun monitor-external-process (p)
    1142   (let* ((in-fd (external-process-watched-fd p))
    1143          (out-stream (external-process-watched-stream p))
    1144          (token (external-process-token p))
    1145          (terminated))
    1146     (loop
    1147       (when (and terminated (null in-fd))
    1148         (signal-semaphore (external-process-completed p))
    1149         (return))
    1150       (when in-fd
    1151         (when (fd-input-available-p in-fd 1000)
    1152           (%stack-block ((buf 1024))
    1153             (let* ((n (fd-read in-fd buf 1024)))
    1154               (declare (fixnum n))
    1155               (if (<= n 0)
    1156                 (progn
    1157                   (without-interrupts
    1158                    (decf (car token))
    1159                    (fd-close in-fd)
    1160                    (setq in-fd nil)))
    1161                 (let* ((string (make-string 1024)))
    1162                   (declare (dynamic-extent string))
    1163                   (%str-from-ptr buf n string)
    1164                   (write-sequence string out-stream :end n)))))))
    1165       (let* ((statusflags (check-pid (external-process-pid p)
    1166                                      (logior
    1167                                       (if in-fd #$WNOHANG 0)
    1168                                       #$WUNTRACED)))
    1169              (oldstatus (external-process-%status p)))
    1170         (cond ((null statusflags)
    1171                (remove-external-process p)
    1172                (setq terminated t))
    1173               ((eq statusflags t))      ; Running.
    1174               (t
    1175                (multiple-value-bind (status code core)
    1176                    (cond ((wifstopped statusflags)
    1177                           (values :stopped (wstopsig statusflags)))
    1178                          ((wifexited statusflags)
    1179                           (values :exited (wexitstatus statusflags)))
    1180                          (t
    1181                           (let* ((signal (wtermsig statusflags)))
    1182                             (declare (fixnum signal))
    1183                             (values
    1184                              (if (or (= signal #$SIGSTOP)
    1185                                      (= signal #$SIGTSTP)
    1186                                      (= signal #$SIGTTIN)
    1187                                      (= signal #$SIGTTOU))
    1188                                :stopped
    1189                                :signaled)
    1190                              signal
    1191                              (logtest #-solaris-target #$WCOREFLAG
    1192                                       #+solaris-target #$WCOREFLG
    1193                                       statusflags)))))
    1194                  (setf (external-process-%status p) status
    1195                        (external-process-%exit-code p) code
    1196                        (external-process-core p) core)
    1197                  (let* ((status-hook (external-process-status-hook p)))
    1198                    (when (and status-hook (not (eq oldstatus status)))
    1199                      (funcall status-hook p)))
    1200                  (when (or (eq status :exited)
    1201                            (eq status :signaled))
    1202                    (remove-external-process p)
    1203                    (setq terminated t)))))))))
    1204      
    1205 (defun run-external-process (proc in-fd out-fd error-fd argv &optional env)
    1206   (let* ((signaled nil))
    1207     (unwind-protect
    1208          (let* ((child-pid (#-solaris-target #_fork #+solaris-target #_forkall)))
    1209            (declare (fixnum child-pid))
    1210            (cond ((zerop child-pid)
    1211                   ;; Running in the child; do an exec
    1212                   (setq signaled t)
    1213                   (dolist (pair env)
    1214                     (setenv (string (car pair)) (cdr pair)))
    1215                   (without-interrupts
    1216                     (exec-with-io-redirection
    1217                      in-fd out-fd error-fd argv)))
    1218                  ((> child-pid 0)
    1219                   ;; Running in the parent: success
    1220                   (setf (external-process-pid proc) child-pid)
    1221                   (add-external-process proc)
    1222                   (signal-semaphore (external-process-signal proc))
    1223                   (setq signaled t)
    1224                   (monitor-external-process proc))
    1225                  (t
    1226                   ;; Fork failed
    1227                   (setf (external-process-%status proc) :error
    1228                         (external-process-%exit-code proc) (%get-errno))
    1229                   (signal-semaphore (external-process-signal proc))
    1230                   (setq signaled t))))
    1231       (unless signaled
    1232         (setf (external-process-%status proc) :error
    1233               (external-process-%exit-code proc) -1)
    1234         (signal-semaphore (external-process-signal proc))))))
    1235 
    1236 (defparameter *silently-ignore-catastrophic-failure-in-run-program*
    1237   #+ccl-0711 t #-ccl-0711 nil
    1238   "If NIL, signal an error if run-program is unable to start the program.
    1239 If non-NIL, treat failure to start the same as failure from the program
    1240 itself, by setting the status and exit-code fields.")
    1241 
    1242 (defun run-program (program args &key
    1243                             (wait t) pty
    1244                             input if-input-does-not-exist
    1245                             output (if-output-exists :error)
    1246                             (error :output) (if-error-exists :error)
    1247                             status-hook (element-type 'character)
    1248                             env
    1249                             (silently-ignore-catastrophic-failures
    1250                              *silently-ignore-catastrophic-failure-in-run-program*))
    1251   "Invoke an external program as an OS subprocess of lisp."
    1252   (declare (ignore pty))
    1253   (unless (every #'(lambda (a) (typep a 'simple-string)) args)
    1254     (error "Program args must all be simple strings : ~s" args))
    1255   (dolist (pair env)
    1256     (destructuring-bind (var . val) pair
    1257       (check-type var (or string symbol character))
    1258       (check-type val string)))
    1259   (push (native-untranslated-namestring program) args)
    1260   (let* ((token (list 0))
    1261          (in-fd nil)
    1262          (in-stream nil)
    1263          (out-fd nil)
    1264          (out-stream nil)
    1265          (error-fd nil)
    1266          (error-stream nil)
    1267          (close-in-parent nil)
    1268          (close-on-error nil)
    1269          (proc
    1270           (make-external-process
    1271            :pid nil
    1272            :args args
    1273            :%status :running
    1274            :input nil
    1275            :output nil
    1276            :error nil
    1277            :token token
    1278            :status-hook status-hook)))
    1279     (unwind-protect
    1280          (progn
    1281            (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
    1282              (get-descriptor-for input proc  nil nil :direction :input
    1283                                  :if-does-not-exist if-input-does-not-exist
    1284                                  :element-type element-type))
    1285            (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
    1286              (get-descriptor-for output proc close-in-parent close-on-error
    1287                                  :direction :output
    1288                                  :if-exists if-output-exists
    1289                                  :element-type element-type))
    1290            (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
    1291              (if (eq error :output)
    1292                (values out-fd out-stream close-in-parent close-on-error)
    1293                (get-descriptor-for error proc close-in-parent close-on-error
    1294                                    :direction :output
    1295                                    :if-exists if-error-exists
    1296                                    :element-type element-type)))
    1297            (setf (external-process-input proc) in-stream
    1298                  (external-process-output proc) out-stream
    1299                  (external-process-error proc) error-stream)
    1300            (call-with-string-vector
    1301             #'(lambda (argv)
    1302                 (process-run-function
    1303                  (list :name
    1304                        (format nil "Monitor thread for external process ~a" args)
    1305                        :stack-size (ash 128 10)
    1306                        :vstack-size (ash 128 10)
    1307                        :tstack-size (ash 128 10))
    1308                  #'run-external-process proc in-fd out-fd error-fd argv env)
    1309                 (wait-on-semaphore (external-process-signal proc)))
    1310             args))
    1311       (dolist (fd close-in-parent) (fd-close fd))
    1312       (unless (external-process-pid proc)
    1313         (dolist (fd close-on-error) (fd-close fd)))
    1314       (when (and wait (external-process-pid proc))
    1315         (with-interrupts-enabled
    1316           (wait-on-semaphore (external-process-completed proc)))))
    1317     (unless (external-process-pid proc)
    1318       ;; something is wrong
    1319       (if (eq (external-process-%status proc) :error)
    1320         ;; Fork failed
    1321         (unless silently-ignore-catastrophic-failures
    1322           (cerror "Pretend the program ran and failed" 'external-process-creation-failure :proc proc))
    1323         ;; Currently can't happen.
    1324         (error "Bug: fork failed but status field not set?")))
    1325     proc))
    1326 
    1327 
    1328 
    1329 (defmacro wifsignaled (status)
    1330   (let* ((statname (gensym)))
    1331     `(let* ((,statname ,status))
    1332       (and (not (wifstopped ,statname)) (not (wifexited ,statname))))))
    1333 
    1334 
    1335 (defun check-pid (pid &optional (flags (logior  #$WNOHANG #$WUNTRACED)))
    1336   (declare (fixnum pid))
    1337   (rlet ((status :signed))
    1338     (let* ((retval (ff-call-ignoring-eintr (#_waitpid pid status flags))))
    1339       (declare (fixnum retval))
    1340       (if (= retval pid)
    1341         (pref status :signed)
    1342         (zerop retval)))))
    1343 
    1344 
    1345 
    1346 
    1347 
    1348 (defun external-process-wait (proc &optional check-stopped)
    1349   (process-wait "external-process-wait"
    1350                 #'(lambda ()
    1351                     (case (external-process-%status proc)
    1352                       (:running)
    1353                       (:stopped
    1354                        (when check-stopped
    1355                          t))
    1356                       (t
    1357                        (when (zerop (car (external-process-token proc)))
    1358                          t))))))
    1359 
    1360 (defun external-process-status (proc)
    1361   "Return information about whether an OS subprocess is running; or, if
     1528            (fd-lseek fd 0 #$SEEK_SET)
     1529            (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
     1530         (:output
     1531          (multiple-value-bind (read-pipe write-pipe) (pipe)
     1532            (push read-pipe (external-process-watched-fds proc))
     1533            (push object (external-process-watched-streams proc))
     1534            (incf (car (external-process-token proc)))
     1535            (values write-pipe
     1536                    nil
     1537                    (cons write-pipe close-in-parent)
     1538                    (cons read-pipe close-on-error))))))))
     1539
     1540  (defstruct external-process
     1541    pid
     1542    %status
     1543    %exit-code
     1544    pty
     1545    input
     1546    output
     1547    error
     1548    status-hook
     1549    plist
     1550    token
     1551    core
     1552    args
     1553    (signal (make-semaphore))
     1554    (completed (make-semaphore))
     1555    watched-fds
     1556    watched-streams
     1557    )
     1558
     1559  (defun external-process-status (proc)
     1560    "Return information about whether an OS subprocess is running; or, if
    13621561not, why not; and what its result code was if it completed."
    1363   (require-type proc 'external-process)
    1364   (values (external-process-%status proc)
    1365           (external-process-%exit-code proc)))
    1366 
    1367 (defun external-process-input-stream (proc)
    1368   "Return the lisp stream which is used to write input to a given OS
    1369 subprocess, if it has one."
    1370   (require-type proc 'external-process)
    1371   (external-process-input proc))
    1372 
    1373 (defun external-process-output-stream (proc)
    1374   "Return the lisp stream which is used to read output from a given OS
    1375 subprocess, if there is one."
    1376   (require-type proc 'external-process)
    1377   (external-process-output proc))
    1378 
    1379 (defun external-process-error-stream (proc)
    1380   "Return the stream which is used to read error output from a given OS
    1381 subprocess, if it has one."
    1382   (require-type proc 'external-process)
    1383   (external-process-error proc))
    1384 
    1385 (defun external-process-id (proc)
    1386   "Return the process id of an OS subprocess, a positive integer which
    1387 identifies it."
    1388   (require-type proc 'external-process)
    1389   (external-process-pid proc))
     1562    (require-type proc 'external-process)
     1563    (values (external-process-%status proc)
     1564            (external-process-%exit-code proc)))
     1565
     1566
     1567  (defmethod print-object ((p external-process) stream)
     1568    (print-unreadable-object (p stream :type t :identity t)
     1569      (let* ((status (external-process-%status p)))
     1570        (let* ((*print-length* 3))
     1571          (format stream "~a" (external-process-args p)))
     1572        (format stream "[~d] (~a" (external-process-pid p) status)
     1573        (unless (eq status :running)
     1574          (format stream " : ~d" (external-process-%exit-code p)))
     1575        (format stream ")"))))
     1576
     1577  (defun run-program (program args &key
     1578                              (wait t) pty
     1579                              input if-input-does-not-exist
     1580                              output (if-output-exists :error)
     1581                              (error :output) (if-error-exists :error)
     1582                              status-hook (element-type 'character)
     1583                              (sharing :private)
     1584                              env)
     1585    "Invoke an external program as an OS subprocess of lisp."
     1586    (declare (ignore pty))
     1587    (unless (every #'(lambda (a) (typep a 'simple-string)) args)
     1588      (error "Program args must all be simple strings : ~s" args))
     1589    (push program args)
     1590    (let* ((token (list 0))
     1591           (in-fd nil)
     1592           (in-stream nil)
     1593           (out-fd nil)
     1594           (out-stream nil)
     1595           (error-fd nil)
     1596           (error-stream nil)
     1597           (close-in-parent nil)
     1598           (close-on-error nil)
     1599           (proc
     1600            (make-external-process
     1601             :pid nil
     1602             :args args
     1603             :%status :running
     1604             :input nil
     1605             :output nil
     1606             :error nil
     1607             :token token
     1608             :status-hook status-hook)))
     1609      (unwind-protect
     1610           (progn
     1611             (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
     1612               (get-descriptor-for input proc  nil nil :direction :input
     1613                                   :if-does-not-exist if-input-does-not-exist
     1614                                   :sharing sharing
     1615                                   :element-type element-type))
     1616             (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
     1617               (get-descriptor-for output proc close-in-parent close-on-error
     1618                                   :direction :output
     1619                                   :if-exists if-output-exists
     1620                                   :sharing sharing
     1621                                   :element-type element-type))
     1622             (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
     1623               (if (eq error :output)
     1624                 (values out-fd out-stream close-in-parent close-on-error)
     1625                 (get-descriptor-for error proc close-in-parent close-on-error
     1626                                     :direction :output
     1627                                     :if-exists if-error-exists
     1628                                     :sharing sharing
     1629                                     :element-type element-type)))
     1630             (setf (external-process-input proc) in-stream
     1631                   (external-process-output proc) out-stream
     1632                   (external-process-error proc) error-stream)
     1633             (process-run-function
     1634              (format nil "Monitor thread for external process ~a" args)
     1635                   
     1636              #'run-external-process proc in-fd out-fd error-fd env)
     1637             (wait-on-semaphore (external-process-signal proc))
     1638             )
     1639        (dolist (fd close-in-parent) (fd-close fd))
     1640        (if (external-process-pid proc)
     1641          (when (and wait (external-process-pid proc))
     1642            (with-interrupts-enabled
     1643                (wait-on-semaphore (external-process-completed proc))))
     1644          (progn
     1645            (dolist (fd close-on-error) (fd-close fd))
     1646            (error "Process execution failed"))))
     1647      proc))
     1648
     1649  (let* ((external-processes ())
     1650         (external-processes-lock (make-lock)))
     1651    (defun add-external-process (p)
     1652      (with-lock-grabbed (external-processes-lock)
     1653        (push p external-processes)))
     1654    (defun remove-external-process (p)
     1655      (with-lock-grabbed (external-processes-lock)
     1656        (setq external-processes (delete p external-processes))))
     1657    ;; Likewise
     1658    (defun external-processes ()
     1659      (with-lock-grabbed (external-processes-lock)
     1660        (copy-list external-processes)))
     1661    )
     1662
     1663
     1664
     1665
     1666  (defun run-external-process (proc in-fd out-fd error-fd &optional env)
     1667    (let* ((args (external-process-args proc))
     1668           (child-pid (exec-with-io-redirection in-fd out-fd error-fd args proc env)))
     1669      (when child-pid
     1670        (setf (external-process-pid proc) child-pid)
     1671        (add-external-process proc)
     1672        (signal-semaphore (external-process-signal proc))
     1673        (monitor-external-process proc))))
     1674
     1675  (defun join-strings (strings)
     1676    (reduce (lambda (left right) (concatenate 'string left " " right)) strings))
     1677
     1678  (defun exec-with-io-redirection (new-in new-out new-err args proc &optional env)
     1679    (declare (ignore env))              ; until we can do better.
     1680    (with-filename-cstrs ((command (join-strings args)))
     1681      (rletz ((proc-info #>PROCESS_INFORMATION)
     1682              (si #>STARTUPINFO))
     1683        (setf (pref si #>STARTUPINFO.cb) (record-length #>STARTUPINFO))
     1684        (setf (pref si #>STARTUPINFO.dwFlags)
     1685              (logior #$STARTF_USESTDHANDLES #$STARTF_USESHOWWINDOW))
     1686        (setf (pref si #>STARTUPINFO.wShowWindow) #$SW_HIDE)
     1687        (setf (pref si #>STARTUPINFO.hStdInput)
     1688              (if new-in
     1689                (%int-to-ptr new-in)
     1690                (#_GetStdHandle #$STD_INPUT_HANDLE)))
     1691        (setf (pref si #>STARTUPINFO.hStdOutput)
     1692              (if new-out
     1693                (%int-to-ptr new-out)
     1694                (#_GetStdHandle #$STD_OUTPUT_HANDLE)))
     1695        (setf (pref si #>STARTUPINFO.hStdError)
     1696              (if new-err
     1697                (%int-to-ptr new-err)
     1698                (#_GetStdHandle #$STD_ERROR_HANDLE)))
     1699        (if (zerop (#_CreateProcessW (%null-ptr)
     1700                                     command
     1701                                     (%null-ptr)
     1702                                     (%null-ptr)
     1703                                     1
     1704                                     #$CREATE_NEW_CONSOLE
     1705                                     (%null-ptr)
     1706                                     (%null-ptr)
     1707                                     si
     1708                                     proc-info))
     1709          (setf (external-process-%status proc) :error
     1710                (external-process-%exit-code proc) (#_GetLastError))
     1711          (#_CloseHandle (pref proc-info #>PROCESS_INFORMATION.hThread)))
     1712        (pref proc-info #>PROCESS_INFORMATION.hProcess))))
     1713
     1714  (defun fd-uninheritable (fd &key direction)
     1715    (let ((new-fd (fd-dup fd :direction direction)))
     1716      (fd-close fd)
     1717      new-fd))
     1718
     1719  (defun monitor-external-process (p)
     1720    (let* ((in-fds (external-process-watched-fds p))
     1721           (out-streams (external-process-watched-streams p))
     1722           (token (external-process-token p))
     1723           (terminated))
     1724      (loop
     1725        (when terminated
     1726          (without-interrupts
     1727           (decf (car token))
     1728           (if in-fd (fd-close in-fd))
     1729           (setq in-fd nil)
     1730           (rlet ((code #>DWORD))
     1731             (loop
     1732               (#_GetExitCodeProcess (external-process-pid p) code)
     1733               (unless (eql (pref code #>DWORD) #$STILL_ACTIVE)
     1734                 (return)))
     1735             (#_SleepEx 10 #$TRUE)
     1736             (setf (external-process-%exit-code p) (pref code #>DWORD)))
     1737           (#_CloseHandle (external-process-pid p))
     1738           (setf (external-process-pid p) nil)
     1739           (setf (external-process-%status p) :exited)
     1740           (let ((status-hook (external-process-status-hook p)))
     1741             (when status-hook
     1742               (funcall status-hook p)))
     1743           (remove-external-process p)
     1744           (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)))
     1759                    (declare (fixnum n))
     1760                    (if (<= n 0)
     1761                      (setf terminated t)
     1762                      (let* ((string (make-string 1024)))
     1763                        (declare (dynamic-extent string))
     1764                        (%str-from-ptr buf n string)
     1765                        (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))))))
    13901773 
    1391 (defun signal-external-process (proc signal)
    1392   "Send the specified signal to the specified external process.  (Typically,
    1393 it would only be useful to call this function if the EXTERNAL-PROCESS was
    1394 created with :WAIT NIL.) Return T if successful; NIL if the process wasn't
    1395 created successfully, and signal an error otherwise."
    1396   (require-type proc 'external-process)
    1397   (let* ((pid (external-process-pid proc)))
    1398     (when pid
    1399       (let ((error (int-errno-call (#_kill pid signal))))
    1400         (or (eql error 0)
    1401             (%errno-disp error))))))
    1402 
    1403 ) ; #-windows-target (progn
    1404 
    1405 #+windows-target
    1406 (progn
    1407 (defun temp-file-name (prefix)
    1408   "Returns a unique name for a temporary file, residing in system temp
    1409 space, and prefixed with PREFIX."
    1410   (rlet ((buffer (:array :wchar_t #.#$MAX_PATH)))
    1411     (#_GetTempPathW #$MAX_PATH buffer)
    1412     (with-filename-cstrs ((c-prefix prefix))
    1413       (#_GetTempFileNameW buffer c-prefix 0 buffer)
    1414       (%get-native-utf-16-cstring buffer))))
    1415  
    1416 (defun get-descriptor-for (object proc close-in-parent close-on-error
    1417                                   &rest keys &key direction (element-type 'character)
    1418                                   &allow-other-keys)
    1419   (etypecase object
    1420     ((eql t)
    1421      (values nil nil close-in-parent close-on-error))
    1422     (null
    1423      (let* ((null-device "nul")
    1424             (fd (fd-open null-device (case direction
    1425                                        (:input #$O_RDONLY)
    1426                                        (:output #$O_WRONLY)
    1427                                        (t #$O_RDWR)))))
    1428        (if (< fd 0)
    1429          (signal-file-error fd null-device))
    1430        (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
    1431     ((eql :stream)
    1432      (multiple-value-bind (read-pipe write-pipe) (pipe)
    1433        (case direction
    1434          (:input
    1435           (values read-pipe
    1436                   (make-fd-stream (fd-uninheritable write-pipe :direction :output)
    1437                                   :direction :output
    1438                                   :element-type element-type
    1439                                   :interactive nil
    1440                                   :basic t
    1441                                   :auto-close t)
    1442                   (cons read-pipe close-in-parent)
    1443                   (cons write-pipe close-on-error)))
    1444          (:output
    1445           (values write-pipe
    1446                   (make-fd-stream (fd-uninheritable read-pipe :direction :input)
    1447                                   :direction :input
    1448                                   :element-type element-type
    1449                                   :interactive nil
    1450                                   :basic t
    1451                                   :auto-close t)
    1452                   (cons write-pipe close-in-parent)
    1453                   (cons read-pipe close-on-error)))
    1454          (t
    1455           (fd-close read-pipe)
    1456           (fd-close write-pipe)
    1457           (report-bad-arg direction '(member :input :output))))))
    1458     ((or pathname string)
    1459      (with-open-stream (file (apply #'open object keys))
    1460        (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t)) :direction direction :inheritable t)))
    1461          (values fd
    1462                  nil
    1463                  (cons fd close-in-parent)
    1464                  (cons fd close-on-error)))))
    1465     (fd-stream
    1466      (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
    1467        (values fd
    1468                nil
    1469                (cons fd close-in-parent)
    1470                (cons fd close-on-error))))
    1471     (stream
    1472      (ecase direction
    1473        (:input
    1474         (let* ((tempname (temp-file-name "lisp-temp"))
    1475                (fd (fd-open tempname #$O_RDWR)))
    1476           (if (< fd 0)
    1477             (%errno-disp fd))
    1478           (loop
    1479             (multiple-value-bind (line no-newline)
    1480                 (read-line object nil nil)
    1481               (unless line
    1482                 (return))
    1483               (let* ((len (length line)))
    1484                 (%stack-block ((buf (1+ len)))
    1485                   (%cstr-pointer line buf)
    1486                   (fd-write fd buf len)
    1487                   (if no-newline
    1488                     (return))
    1489                   (setf (%get-byte buf) (char-code #\newline))
    1490                   (fd-write fd buf 1)))))
    1491           (fd-lseek fd 0 #$SEEK_SET)
    1492           (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
    1493        (:output
    1494         (multiple-value-bind (read-pipe write-pipe) (pipe)
    1495           (setf (external-process-watched-fd proc) read-pipe
    1496                 (external-process-watched-stream proc) object)
    1497           (incf (car (external-process-token proc)))
    1498           (values write-pipe
    1499                   nil
    1500                   (cons write-pipe close-in-parent)
    1501                   (cons read-pipe close-on-error))))))))
    1502 
    1503 (defstruct external-process
    1504   pid
    1505   %status
    1506   %exit-code
    1507   pty
    1508   input
    1509   output
    1510   error
    1511   status-hook
    1512   plist
    1513   token
    1514   core
    1515   args
    1516   (signal (make-semaphore))
    1517   (completed (make-semaphore))
    1518   watched-fd
    1519   watched-stream
    1520   )
    1521 
    1522 (defun external-process-status (proc)
    1523   "Return information about whether an OS subprocess is running; or, if
    1524 not, why not; and what its result code was if it completed."
    1525   (require-type proc 'external-process)
    1526   (values (external-process-%status proc)
    1527           (external-process-%exit-code proc)))
    1528 
    1529 
    1530 (defmethod print-object ((p external-process) stream)
    1531   (print-unreadable-object (p stream :type t :identity t)
    1532     (let* ((status (external-process-%status p)))
    1533       (let* ((*print-length* 3))
    1534         (format stream "~a" (external-process-args p)))
    1535       (format stream "[~d] (~a" (external-process-pid p) status)
    1536       (unless (eq status :running)
    1537         (format stream " : ~d" (external-process-%exit-code p)))
    1538       (format stream ")"))))
    1539 
    1540 (defun run-program (program args &key
    1541                             (wait t) pty
    1542                             input if-input-does-not-exist
    1543                             output (if-output-exists :error)
    1544                             (error :output) (if-error-exists :error)
    1545                             status-hook (element-type 'character)
    1546                             env)
    1547   "Invoke an external program as an OS subprocess of lisp."
    1548   (declare (ignore pty))
    1549   (unless (every #'(lambda (a) (typep a 'simple-string)) args)
    1550     (error "Program args must all be simple strings : ~s" args))
    1551   (push program args)
    1552   (let* ((token (list 0))
    1553          (in-fd nil)
    1554          (in-stream nil)
    1555          (out-fd nil)
    1556          (out-stream nil)
    1557          (error-fd nil)
    1558          (error-stream nil)
    1559          (close-in-parent nil)
    1560          (close-on-error nil)
    1561          (proc
    1562           (make-external-process
    1563            :pid nil
    1564            :args args
    1565            :%status :running
    1566            :input nil
    1567            :output nil
    1568            :error nil
    1569            :token token
    1570            :status-hook status-hook)))
    1571     (unwind-protect
    1572          (progn
    1573            (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
    1574              (get-descriptor-for input proc  nil nil :direction :input
    1575                                  :if-does-not-exist if-input-does-not-exist
    1576                                  :element-type element-type))
    1577            (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
    1578              (get-descriptor-for output proc close-in-parent close-on-error
    1579                                  :direction :output
    1580                                  :if-exists if-output-exists
    1581                                  :element-type element-type))
    1582            (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
    1583              (if (eq error :output)
    1584                (values out-fd out-stream close-in-parent close-on-error)
    1585                (get-descriptor-for error proc close-in-parent close-on-error
    1586                                    :direction :output
    1587                                    :if-exists if-error-exists
    1588                                    :element-type element-type)))
    1589            (setf (external-process-input proc) in-stream
    1590                  (external-process-output proc) out-stream
    1591                  (external-process-error proc) error-stream)
    1592            (process-run-function
    1593             (format nil "Monitor thread for external process ~a" args)
    1594                    
    1595             #'run-external-process proc in-fd out-fd error-fd env)
    1596            (wait-on-semaphore (external-process-signal proc))
    1597            )
    1598       (dolist (fd close-in-parent) (fd-close fd))
    1599       (if (external-process-pid proc)
    1600         (when (and wait (external-process-pid proc))
    1601           (with-interrupts-enabled
    1602               (wait-on-semaphore (external-process-completed proc))))
    1603         (progn
    1604           (dolist (fd close-on-error) (fd-close fd))
    1605           (error "Process execution failed"))))
    1606     proc))
    1607 
    1608 (let* ((external-processes ())
    1609        (external-processes-lock (make-lock)))
    1610   (defun add-external-process (p)
    1611     (with-lock-grabbed (external-processes-lock)
    1612       (push p external-processes)))
    1613   (defun remove-external-process (p)
    1614     (with-lock-grabbed (external-processes-lock)
    1615       (setq external-processes (delete p external-processes))))
    1616   ;; Likewise
    1617   (defun external-processes ()
    1618     (with-lock-grabbed (external-processes-lock)
    1619       (copy-list external-processes)))
    1620   )
    1621 
    1622 
    1623 
    1624 
    1625 (defun run-external-process (proc in-fd out-fd error-fd &optional env)
    1626   (let* ((args (external-process-args proc))
    1627          (child-pid (exec-with-io-redirection in-fd out-fd error-fd args proc env)))
    1628     (when child-pid
    1629       (setf (external-process-pid proc) child-pid)
    1630       (add-external-process proc)
    1631       (signal-semaphore (external-process-signal proc))
    1632       (monitor-external-process proc))))
    1633 
    1634 (defun join-strings (strings)
    1635   (reduce (lambda (left right) (concatenate 'string left " " right)) strings))
    1636 
    1637 (defun exec-with-io-redirection (new-in new-out new-err args proc &optional env)
    1638   (declare (ignore env))                ; until we can do better.
    1639   (with-filename-cstrs ((command (join-strings args)))
    1640     (rletz ((proc-info #>PROCESS_INFORMATION)
    1641             (si #>STARTUPINFO))
    1642       (setf (pref si #>STARTUPINFO.cb) (record-length #>STARTUPINFO))
    1643       (setf (pref si #>STARTUPINFO.dwFlags)
    1644             (logior #$STARTF_USESTDHANDLES #$STARTF_USESHOWWINDOW))
    1645       (setf (pref si #>STARTUPINFO.wShowWindow) #$SW_HIDE)
    1646       (setf (pref si #>STARTUPINFO.hStdInput)
    1647             (if new-in
    1648               (%int-to-ptr new-in)
    1649               (#_GetStdHandle #$STD_INPUT_HANDLE)))
    1650       (setf (pref si #>STARTUPINFO.hStdOutput)
    1651             (if new-out
    1652               (%int-to-ptr new-out)
    1653               (#_GetStdHandle #$STD_OUTPUT_HANDLE)))
    1654       (setf (pref si #>STARTUPINFO.hStdError)
    1655             (if new-err
    1656               (%int-to-ptr new-err)
    1657               (#_GetStdHandle #$STD_ERROR_HANDLE)))
    1658       (if (zerop (#_CreateProcessW (%null-ptr)
    1659                                    command
    1660                                    (%null-ptr)
    1661                                    (%null-ptr)
    1662                                    1
    1663                                    #$CREATE_NEW_CONSOLE
    1664                                    (%null-ptr)
    1665                                    (%null-ptr)
    1666                                    si
    1667                                    proc-info))
    1668         (setf (external-process-%status proc) :error
    1669               (external-process-%exit-code proc) (#_GetLastError))
    1670         (#_CloseHandle (pref proc-info #>PROCESS_INFORMATION.hThread)))
    1671       (pref proc-info #>PROCESS_INFORMATION.hProcess))))
    1672 
    1673 (defun fd-uninheritable (fd &key direction)
    1674   (let ((new-fd (fd-dup fd :direction direction)))
    1675     (fd-close fd)
    1676     new-fd))
    1677 
    1678 (defun monitor-external-process (p)
    1679   (let* ((in-fd (external-process-watched-fd p))
    1680          (out-stream (external-process-watched-stream p))
    1681          (token (external-process-token p))
    1682          (terminated))
    1683     (loop
    1684       (when terminated
    1685         (without-interrupts
    1686          (decf (car token))
    1687          (if in-fd (fd-close in-fd))
    1688          (setq in-fd nil)
    1689          (rlet ((code #>DWORD))
    1690            (loop
    1691              (#_GetExitCodeProcess (external-process-pid p) code)
    1692              (unless (eql (pref code #>DWORD) #$STILL_ACTIVE)
    1693                (return)))
    1694            (#_SleepEx 10 #$TRUE)
    1695            (setf (external-process-%exit-code p) (pref code #>DWORD)))
    1696          (#_CloseHandle (external-process-pid p))
    1697          (setf (external-process-pid p) nil)
    1698          (setf (external-process-%status p) :exited)
    1699          (let ((status-hook (external-process-status-hook p)))
    1700            (when status-hook
    1701              (funcall status-hook p)))
    1702          (remove-external-process p)
    1703          (signal-semaphore (external-process-completed p))
    1704          (return)))     
    1705       (if in-fd
    1706         (rlet ((handles (:array #>HANDLE 2)))
    1707           (setf (paref handles (:array #>HANDLE) 0) (external-process-pid p))
    1708           (setf (paref handles (:array #>HANDLE) 1) (#__get_osfhandle in-fd))
    1709           (let ((rc (ignoring-eintr
    1710                      (let* ((code (#_WaitForMultipleObjectsEx 2 handles #$FALSE #$INFINITE #$true)))
    1711                        (if (eql code #$WAIT_IO_COMPLETION)
    1712                          (- #$EINTR)
    1713                          code)))))
    1714             (if (eq rc #$WAIT_OBJECT_0)
    1715               (setf terminated t)
    1716               (%stack-block ((buf 1024))
    1717                 (let* ((n (fd-read in-fd buf 1024)))
    1718                   (declare (fixnum n))
    1719                   (if (<= n 0)
    1720                     (setf terminated t)
    1721                     (let* ((string (make-string 1024)))
    1722                       (declare (dynamic-extent string))
    1723                       (%str-from-ptr buf n string)
    1724                       (write-sequence string out-stream :end n))))))))
    1725         (progn
    1726           (ignoring-eintr
    1727            (let* ((code (#_WaitForSingleObjectEx (external-process-pid p) #$INFINITE #$true)))
    1728              (if (eql code #$WAIT_IO_COMPLETION)
    1729                (- #$EINTR)
    1730                code)))
    1731           (setf terminated t))))))
    1732  
    1733 
    1734 )                                   ; #+windows-target (progn
     1774
     1775  )                                     ; #+windows-target (progn
    17351776
    17361777;;; EOF on a TTY is transient, but I'm less sure of other cases.
Note: See TracChangeset for help on using the changeset viewer.