Changeset 9549


Ignore:
Timestamp:
May 19, 2008, 4:58:53 PM (11 years ago)
Author:
andreas
Message:

Stub for run-program implementation for Windows.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/win64/level-1/linux-files.lisp

    r9335 r9549  
    492492    (%uts-string (#___xuname #$SYS_NMLN buf) idx buf)))
    493493
     494#-windows-target
    494495(defun fd-dup (fd)
    495496  (int-errno-call (#_dup fd)))
     497
     498#+windows-target
     499(defun fd-dup (fd &key direction inheritable)
     500  (rlet ((handle #>LPHANDLE))
     501    (#_DuplicateHandle (#_GetCurrentProcess)
     502                       (#__get_osfhandle fd)
     503                       (#_GetCurrentProcess)
     504                       handle
     505                       0
     506                       (if inheritable #$TRUE #$FALSE)
     507                       #$DUPLICATE_SAME_ACCESS)
     508    (#__open_osfhandle (pref handle #>HANDLE) (case direction
     509                                                (:input #$O_RDONLY)
     510                                                (:output #$O_WRONLY)
     511                                                (t #$O_RDWR)))))
     512                       
    496513
    497514(defun fd-fsync (fd)
     
    12621279#+windows-target
    12631280(progn
    1264 #+windows-target
     1281(defun get-descriptor-for (object proc close-in-parent close-on-error
     1282                                  &rest keys &key direction (element-type 'character)
     1283                                  &allow-other-keys)
     1284  (etypecase object
     1285    ((eql t)
     1286     (values nil nil close-in-parent close-on-error))
     1287    (null
     1288     (let* ((null-device "nul")
     1289            (fd (fd-open null-device (case direction
     1290                                       (:input #$O_RDONLY)
     1291                                       (:output #$O_WRONLY)
     1292                                       (t #$O_RDWR)))))
     1293       (if (< fd 0)
     1294         (signal-file-error fd null-device))
     1295       (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
     1296    ((eql :stream)
     1297     (multiple-value-bind (read-pipe write-pipe) (pipe)
     1298       (case direction
     1299         (:input
     1300          (values read-pipe
     1301                  (make-fd-stream (fd-uninheritable write-pipe :direction :output)
     1302                                  :direction :output
     1303                                  :element-type element-type
     1304                                  :interactive nil
     1305                                  :basic t
     1306                                  :auto-close t)
     1307                  (cons read-pipe close-in-parent)
     1308                  (cons write-pipe close-on-error)))
     1309         (:output
     1310          (values write-pipe
     1311                  (make-fd-stream (fd-uninheritable read-pipe :direction :input)
     1312                                  :direction :input
     1313                                  :element-type element-type
     1314                                  :interactive nil
     1315                                  :basic t
     1316                                  :auto-close t)
     1317                  (cons write-pipe close-in-parent)
     1318                  (cons read-pipe close-on-error)))
     1319         (t
     1320          (fd-close read-pipe)
     1321          (fd-close write-pipe)
     1322          (report-bad-arg direction '(member :input :output))))))
     1323    ((or pathname string)
     1324     (with-open-stream (file (apply #'open object keys))
     1325       (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t)) :direction direction :inheritable t)))
     1326         (values fd
     1327                 nil
     1328                 (cons fd close-in-parent)
     1329                 (cons fd close-on-error)))))
     1330    (fd-stream
     1331     (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
     1332       (values fd
     1333               nil
     1334               (cons fd close-in-parent)
     1335               (cons fd close-on-error))))
     1336    (stream
     1337     (ecase direction
     1338       (:input
     1339        (with-cstrs ((template "lisp-tempXXXXXX"))
     1340          (let* ((fd (#_mktemp template)))
     1341            (if (< fd 0)
     1342              (%errno-disp fd))
     1343            (#_unlink template)
     1344            (loop
     1345              (multiple-value-bind (line no-newline)
     1346                  (read-line object nil nil)
     1347                (unless line
     1348                  (return))
     1349                (let* ((len (length line)))
     1350                  (%stack-block ((buf (1+ len)))
     1351                    (%cstr-pointer line buf)
     1352                    (fd-write fd buf len)
     1353                    (if no-newline
     1354                      (return))
     1355                    (setf (%get-byte buf) (char-code #\newline))
     1356                    (fd-write fd buf 1)))))
     1357            (fd-lseek fd 0 #$SEEK_SET)
     1358            (values fd nil (cons fd close-in-parent) (cons fd close-on-error)))))
     1359       (:output
     1360        (multiple-value-bind (read-pipe write-pipe) (pipe)
     1361          (setf (external-process-watched-fd proc) read-pipe
     1362                (external-process-watched-stream proc) object)
     1363          (incf (car (external-process-token proc)))
     1364          (values write-pipe
     1365                  nil
     1366                  (cons write-pipe close-in-parent)
     1367                  (cons read-pipe close-on-error))))))))
     1368
     1369(defstruct external-process
     1370  pid
     1371  %status
     1372  %exit-code
     1373  pty
     1374  input
     1375  output
     1376  error
     1377  status-hook
     1378  plist
     1379  token
     1380  core
     1381  args
     1382  (signal (make-semaphore))
     1383  (completed (make-semaphore))
     1384  watched-fd
     1385  watched-stream
     1386  )
     1387
     1388(defmethod print-object ((p external-process) stream)
     1389  (print-unreadable-object (p stream :type t :identity t)
     1390    (let* ((status (external-process-%status p)))
     1391      (let* ((*print-length* 3))
     1392        (format stream "~a" (external-process-args p)))
     1393      (format stream "[~d] (~a" (external-process-pid p) status)
     1394      (unless (eq status :running)
     1395        (format stream " : ~d" (external-process-%exit-code p)))
     1396      (format stream ")"))))
     1397
     1398(defun run-program (program args &key
     1399                            (wait t) pty
     1400                            input if-input-does-not-exist
     1401                            output (if-output-exists :error)
     1402                            (error :output) (if-error-exists :error)
     1403                            status-hook (element-type 'character)
     1404                            env)
     1405  "Invoke an external program as an OS subprocess of lisp."
     1406  (declare (ignore pty))
     1407  (unless (every #'(lambda (a) (typep a 'simple-string)) args)
     1408    (error "Program args must all be simple strings : ~s" args))
     1409;  (push (native-untranslated-namestring program) args)
     1410  (push program args)
     1411  (let* ((token (list 0))
     1412         (in-fd nil)
     1413         (in-stream nil)
     1414         (out-fd nil)
     1415         (out-stream nil)
     1416         (error-fd nil)
     1417         (error-stream nil)
     1418         (close-in-parent nil)
     1419         (close-on-error nil)
     1420         (proc
     1421          (make-external-process
     1422           :pid nil
     1423           :args args
     1424           :%status :running
     1425           :input nil
     1426           :output nil
     1427           :error nil
     1428           :token token
     1429           :status-hook status-hook)))
     1430    (unwind-protect
     1431         (progn
     1432           (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
     1433             (get-descriptor-for input proc  nil nil :direction :input
     1434                                 :if-does-not-exist if-input-does-not-exist
     1435                                 :element-type element-type))
     1436           (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
     1437             (get-descriptor-for output proc close-in-parent close-on-error
     1438                                 :direction :output
     1439                                 :if-exists if-output-exists
     1440                                 :element-type element-type))
     1441           (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
     1442             (if (eq error :output)
     1443               (values out-fd out-stream close-in-parent close-on-error)
     1444               (get-descriptor-for error proc close-in-parent close-on-error
     1445                                   :direction :output
     1446                                   :if-exists if-error-exists
     1447                                   :element-type element-type)))
     1448           (setf (external-process-input proc) in-stream
     1449                 (external-process-output proc) out-stream
     1450                 (external-process-error proc) error-stream)
     1451           (format t "~s ~s ~s" in-fd out-fd error-fd)
     1452           (process-run-function
     1453            (format nil "Monitor thread for external process ~a" args)
     1454                   
     1455            #'run-external-process proc in-fd out-fd error-fd env)
     1456           (wait-on-semaphore (external-process-signal proc))
     1457           )
     1458      (dolist (fd close-in-parent) (fd-close fd))
     1459      (unless (external-process-pid proc)
     1460        (dolist (fd close-on-error) (fd-close fd)))
     1461      (when (and wait (external-process-pid proc))
     1462        (with-interrupts-enabled
     1463            (wait-on-semaphore (external-process-completed proc)))))
     1464    (and (external-process-pid proc) proc)))
     1465
     1466(let* ((external-processes ())
     1467       (external-processes-lock (make-lock)))
     1468  (defun add-external-process (p)
     1469    (with-lock-grabbed (external-processes-lock)
     1470      (push p external-processes)))
     1471  (defun remove-external-process (p)
     1472    (with-lock-grabbed (external-processes-lock)
     1473      (setq external-processes (delete p external-processes))))
     1474  ;; Likewise
     1475  (defun external-processes ()
     1476    (with-lock-grabbed (external-processes-lock)
     1477      (copy-list external-processes)))
     1478  )
     1479
     1480
    12651481(defun pipe ()
    12661482  (%stack-block ((filedes 8))
    12671483    (syscall syscalls::pipe filedes)
    12681484    (values (paref filedes (:array :int)  0) (paref filedes (:array :int)  1))))
     1485
     1486(defun run-external-process (proc in-fd out-fd error-fd &optional env)
     1487  ;; stub, stub
     1488  (let* ((args (external-process-args proc))
     1489         (child-pid (exec-with-io-redirection in-fd out-fd error-fd (car args) (cdr args))))
     1490    (setf (external-process-pid proc) child-pid)
     1491    (add-external-process proc)
     1492    (signal-semaphore (external-process-signal proc))
     1493    (monitor-external-process proc)))
     1494
     1495(defun exec-with-io-redirection (new-in new-out new-err command args)
     1496  (with-filename-cstrs ((command command))
     1497    (rletz ((proc-info #>PROCESS_INFORMATION)
     1498            (si #>STARTUPINFO))
     1499      (setf (pref si #>STARTUPINFO.cb) (record-length #>STARTUPINFO))
     1500      (setf (pref si #>STARTUPINFO.dwFlags) #$STARTF_USESTDHANDLES)
     1501      (setf (pref si #>STARTUPINFO.hStdInput) (#__get_osfhandle new-in))
     1502      (setf (pref si #>STARTUPINFO.hStdOutput) (#__get_osfhandle new-out))
     1503      (setf (pref si #>STARTUPINFO.hStdError) (#__get_osfhandle new-err))
     1504      (if (zerop (#_CreateProcessW (%null-ptr)
     1505                                   command
     1506                                   (%null-ptr)
     1507                                   (%null-ptr)
     1508                                   1
     1509                                   #$CREATE_NEW_CONSOLE
     1510                                   (%null-ptr)
     1511                                   (%null-ptr)
     1512                                   si
     1513                                   proc-info))
     1514          (error "Process creation failed"))
     1515      (pref proc-info #>PROCESS_INFORMATION.hProcess))))
     1516
     1517(defun fd-uninheritable (fd &key direction)
     1518  (let ((new-fd (fd-dup fd :direction direction)))
     1519    (fd-close fd)
     1520    new-fd))
     1521
     1522(defun monitor-external-process (p)
     1523  (let* ((in-fd (external-process-watched-fd p))
     1524         (out-stream (external-process-watched-stream p))
     1525         (token (external-process-token p))
     1526         (terminated))
     1527    (loop
     1528      (when (and terminated (null in-fd))
     1529        (signal-semaphore (external-process-completed p))
     1530        (return))
     1531      (when in-fd
     1532        (when (fd-input-available-p in-fd 1000)
     1533          (%stack-block ((buf 1024))
     1534            (let* ((n (fd-read in-fd buf 1024)))
     1535              (declare (fixnum n))
     1536              (if (<= n 0)
     1537                (progn
     1538                  (without-interrupts
     1539                   (decf (car token))
     1540                   (fd-close in-fd)
     1541                   (setq terminated t) ; need equiv. of waitpid here
     1542                   (setq in-fd nil)))
     1543                (let* ((string (make-string 1024)))
     1544                  (declare (dynamic-extent string))
     1545                  (%str-from-ptr buf n string)
     1546                  (write-sequence string out-stream :end n))))))))))
     1547 
     1548
    12691549) ; #+windows-target (progn
    12701550
Note: See TracChangeset for help on using the changeset viewer.