Changeset 12211


Ignore:
Timestamp:
Jun 6, 2009, 8:11:12 PM (10 years ago)
Author:
gz
Message:

Merge from trunk: r11280 r11309 r11440 r11448 r11516 r11759 r11816 r11953 r12085

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-1/linux-files.lisp

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