Changeset 9815


Ignore:
Timestamp:
Jun 21, 2008, 9:51:24 PM (11 years ago)
Author:
gb
Message:

Don't "strip drive prefix" for Windows.
Try to make RUN-PROGRAM work better; note that #_GetExitCodeProcess()
an return #$STILL_ACTIVE even after the process handle is signaled.
Add CYGPATH, which translates a Windows-style path to something that
Cygwin programs can understand (by calling out to the "cygpath"
program.)
(RUN-PROGRAM should not error if it can't create a process/can't
find the executable; not sure how well this is handled yet.)

File:
1 edited

Legend:

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

    r9728 r9815  
    3939
    4040(defun strip-drive-for-now (string)
     41  string
     42  #+no
    4143  (or (and (> (length string) 2)
    4244           (eql (schar string 1) #\:)
    43            (subseq string 2))
     45           (let* ((copy (subseq string 0)))
     46             (setf (schar copy 0) (char-downcase (schar copy 0)))
     47             (setf (schar copy  1) #\|)
     48             copy))
    4449      string))
    4550           
     
    359364(defun windows-strip-trailing-slash (namestring)
    360365  (do* ((len (length namestring) (length namestring)))
    361        ((<= len 1) namestring)
     366       ((<= len 3) namestring)
    362367    (let* ((p (1- len))
    363368           (ch (char namestring p)))
     
    12871292      (#_GetTempFileNameW buffer c-prefix 0 buffer)
    12881293      (%get-native-utf-16-cstring buffer))))
    1289 
     1294 
    12901295(defun get-descriptor-for (object proc close-in-parent close-on-error
    1291                                   &rest keys &key direction (element-type 'character)
    1292                                   &allow-other-keys)
     1296                                  &rest keys &key direction (element-type 'character)
     1297                                  &allow-other-keys)
    12931298  (etypecase object
    12941299    ((eql t)
     
    13511356            (%errno-disp fd))
    13521357          (loop
    1353              (multiple-value-bind (line no-newline)
    1354                 (read-line object nil nil)
    1355                (unless line
    1356                 (return))
    1357                (let* ((len (length line)))
    1358                 (%stack-block ((buf (1+ len)))
    1359                    (%cstr-pointer line buf)
    1360                    (fd-write fd buf len)
    1361                    (if no-newline
    1362                      (return))
    1363                    (setf (%get-byte buf) (char-code #\newline))
    1364                    (fd-write fd buf 1)))))
     1358            (multiple-value-bind (line no-newline)
     1359                (read-line object nil nil)
     1360              (unless line
     1361                (return))
     1362              (let* ((len (length line)))
     1363                (%stack-block ((buf (1+ len)))
     1364                  (%cstr-pointer line buf)
     1365                  (fd-write fd buf len)
     1366                  (if no-newline
     1367                    (return))
     1368                  (setf (%get-byte buf) (char-code #\newline))
     1369                  (fd-write fd buf 1)))))
    13651370          (fd-lseek fd 0 #$SEEK_SET)
    13661371          (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
     
    14061411    (let* ((status (external-process-%status p)))
    14071412      (let* ((*print-length* 3))
    1408         (format stream "~a" (external-process-args p)))
     1413        (format stream "~a" (external-process-args p)))
    14091414      (format stream "[~d] (~a" (external-process-pid p) status)
    14101415      (unless (eq status :running)
    1411         (format stream " : ~d" (external-process-%exit-code p)))
     1416        (format stream " : ~d" (external-process-%exit-code p)))
    14121417      (format stream ")"))))
    14131418
    14141419(defun run-program (program args &key
    1415                             (wait t) pty
    1416                             input if-input-does-not-exist
    1417                             output (if-output-exists :error)
    1418                             (error :output) (if-error-exists :error)
    1419                             status-hook (element-type 'character)
     1420                            (wait t) pty
     1421                            input if-input-does-not-exist
     1422                            output (if-output-exists :error)
     1423                            (error :output) (if-error-exists :error)
     1424                            status-hook (element-type 'character)
    14201425                            env)
    14211426  "Invoke an external program as an OS subprocess of lisp."
     
    14251430  (push program args)
    14261431  (let* ((token (list 0))
    1427         (in-fd nil)
    1428         (in-stream nil)
    1429         (out-fd nil)
    1430         (out-stream nil)
    1431         (error-fd nil)
    1432         (error-stream nil)
    1433         (close-in-parent nil)
    1434         (close-on-error nil)
    1435         (proc
     1432        (in-fd nil)
     1433        (in-stream nil)
     1434        (out-fd nil)
     1435        (out-stream nil)
     1436        (error-fd nil)
     1437        (error-stream nil)
     1438        (close-in-parent nil)
     1439        (close-on-error nil)
     1440        (proc
    14361441          (make-external-process
    14371442           :pid nil
     
    14441449           :status-hook status-hook)))
    14451450    (unwind-protect
    1446         (progn
    1447            (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
    1448              (get-descriptor-for input proc  nil nil :direction :input
    1449                                 :if-does-not-exist if-input-does-not-exist
     1451        (progn
     1452           (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
     1453             (get-descriptor-for input proc  nil nil :direction :input
     1454                                :if-does-not-exist if-input-does-not-exist
    14501455                                 :element-type element-type))
    1451            (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
    1452              (get-descriptor-for output proc close-in-parent close-on-error
    1453                                 :direction :output
    1454                                 :if-exists if-output-exists
     1456           (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
     1457             (get-descriptor-for output proc close-in-parent close-on-error
     1458                                :direction :output
     1459                                :if-exists if-output-exists
    14551460                                 :element-type element-type))
    1456            (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
    1457              (if (eq error :output)
    1458                (values out-fd out-stream close-in-parent close-on-error)
    1459                (get-descriptor-for error proc close-in-parent close-on-error
    1460                                    :direction :output
    1461                                    :if-exists if-error-exists
     1461           (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
     1462             (if (eq error :output)
     1463               (values out-fd out-stream close-in-parent close-on-error)
     1464               (get-descriptor-for error proc close-in-parent close-on-error
     1465                                   :direction :output
     1466                                   :if-exists if-error-exists
    14621467                                   :element-type element-type)))
    1463            (setf (external-process-input proc) in-stream
     1468           (setf (external-process-input proc) in-stream
    14641469                 (external-process-output proc) out-stream
    14651470                 (external-process-error proc) error-stream)
     
    14721477      (dolist (fd close-in-parent) (fd-close fd))
    14731478      (if (external-process-pid proc)
    1474         (when (and wait (external-process-pid proc))
    1475           (with-interrupts-enabled
    1476               (wait-on-semaphore (external-process-completed proc))))
     1479        (when (and wait (external-process-pid proc))
     1480          (with-interrupts-enabled
     1481              (wait-on-semaphore (external-process-completed proc))))
    14771482        (progn
    1478           (dolist (fd close-on-error) (fd-close fd))
    1479           (error "Process execution failed"))))
     1483          (dolist (fd close-on-error) (fd-close fd))
     1484          (error "Process execution failed"))))
    14801485    proc))
    14811486
     
    15011506
    15021507(defun run-external-process (proc in-fd out-fd error-fd &optional env)
    1503   (handler-case
    1504       (let* ((args (external-process-args proc))
    1505              (child-pid (exec-with-io-redirection in-fd out-fd error-fd args)))
    1506         (setf (external-process-pid proc) child-pid)
    1507         (add-external-process proc)
    1508         (signal-semaphore (external-process-signal proc))
    1509         (monitor-external-process proc))
    1510     (error (condition)
    1511       (setf (external-process-%status proc) :failed)
    1512       (signal-semaphore (external-process-signal proc)))))
     1508  (let* ((args (external-process-args proc))
     1509         (child-pid (exec-with-io-redirection in-fd out-fd error-fd args proc)))
     1510    (when child-pid
     1511      (setf (external-process-pid proc) child-pid)
     1512      (add-external-process proc)
     1513      (signal-semaphore (external-process-signal proc))
     1514      (monitor-external-process proc))))
    15131515
    15141516(defun join-strings (strings)
    15151517  (reduce (lambda (left right) (concatenate 'string left " " right)) strings))
    15161518
    1517 (defun exec-with-io-redirection (new-in new-out new-err args)
     1519(defun exec-with-io-redirection (new-in new-out new-err args proc)
    15181520  (with-filename-cstrs ((command (join-strings args)))
    15191521    (rletz ((proc-info #>PROCESS_INFORMATION)
    1520             (si #>STARTUPINFO))
     1522            (si #>STARTUPINFO))
    15211523      (setf (pref si #>STARTUPINFO.cb) (record-length #>STARTUPINFO))
    15221524      (setf (pref si #>STARTUPINFO.dwFlags)
    1523             (logior #$STARTF_USESTDHANDLES #$STARTF_USESHOWWINDOW))
     1525            (logior #$STARTF_USESTDHANDLES #$STARTF_USESHOWWINDOW))
    15241526      (setf (pref si #>STARTUPINFO.wShowWindow) #$SW_HIDE)
    15251527      (setf (pref si #>STARTUPINFO.hStdInput)
     
    15301532            (%int-to-ptr (#__get_osfhandle (or new-err 2))))
    15311533      (if (zerop (#_CreateProcessW (%null-ptr)
    1532                                    command
    1533                                    (%null-ptr)
    1534                                    (%null-ptr)
    1535                                    1
    1536                                    #$CREATE_NEW_CONSOLE
    1537                                    (%null-ptr)
    1538                                    (%null-ptr)
    1539                                    si
    1540                                    proc-info))
    1541           (error "Process creation failed: ~d" (#_GetLastError)))
    1542       (#_CloseHandle (pref proc-info #>PROCESS_INFORMATION.hThread))
     1534                                   command
     1535                                   (%null-ptr)
     1536                                   (%null-ptr)
     1537                                   1
     1538                                   #$CREATE_NEW_CONSOLE
     1539                                   (%null-ptr)
     1540                                   (%null-ptr)
     1541                                   si
     1542                                   proc-info))
     1543        (setf (external-process-%status proc) :error
     1544              (external-process-%exit-code proc) (#_GetLastError))
     1545        (#_CloseHandle (pref proc-info #>PROCESS_INFORMATION.hThread)))
    15431546      (pref proc-info #>PROCESS_INFORMATION.hProcess))))
    15441547
     
    15541557         (terminated))
    15551558    (loop
    1556        (when terminated
    1557          (without-interrupts
    1558              (decf (car token))
    1559            (if in-fd (fd-close in-fd))
    1560            (setq in-fd nil)
    1561            (rlet ((code #>DWORD))
    1562              (#_GetExitCodeProcess (external-process-pid p) code)
    1563              (setf (external-process-%exit-code p) (pref code #>DWORD)))
    1564            (#_CloseHandle (external-process-pid p))
    1565            (setf (external-process-pid p) nil)
    1566            (setf (external-process-%status p) :exited)
    1567            (let ((status-hook (external-process-status-hook p)))
    1568              (when status-hook
    1569                (funcall status-hook p)))
    1570            (remove-external-process p)
    1571            (signal-semaphore (external-process-completed p))
    1572            (return)))   
    1573        (if in-fd
    1574          (rlet ((handles (:array #>HANDLE 2)))
    1575            (setf (paref handles (:array #>HANDLE) 0) (external-process-pid p))
    1576            (setf (paref handles (:array #>HANDLE) 1) (#__get_osfhandle in-fd))
    1577            (let ((rc (#_WaitForMultipleObjects 2 handles #$FALSE #$INFINITE)))
    1578              (if (eq rc #$WAIT_OBJECT_0)
    1579                (setf terminated t)
    1580                (%stack-block ((buf 1024))
    1581                  (let* ((n (fd-read in-fd buf 1024)))
    1582                    (declare (fixnum n))
    1583                    (if (<= n 0)
    1584                        (setf terminated t)
    1585                        (let* ((string (make-string 1024)))
    1586                          (declare (dynamic-extent string))
    1587                          (%str-from-ptr buf n string)
    1588                          (write-sequence string out-stream :end n))))))))
    1589          (progn
    1590            (#_WaitForSingleObject (external-process-pid p) #$INFINITE)
    1591            (setf terminated t))))))
     1559      (when terminated
     1560        (without-interrupts
     1561         (decf (car token))
     1562         (if in-fd (fd-close in-fd))
     1563         (setq in-fd nil)
     1564         (rlet ((code #>DWORD))
     1565           (loop
     1566             (#_GetExitCodeProcess (external-process-pid p) code)
     1567             (unless (eql (pref code #>DWORD) #$STILL_ACTIVE)
     1568               (return)))
     1569           (#_SleepEx 10 #$TRUE)
     1570           (setf (external-process-%exit-code p) (pref code #>DWORD)))
     1571         (#_CloseHandle (external-process-pid p))
     1572         (setf (external-process-pid p) nil)
     1573         (setf (external-process-%status p) :exited)
     1574         (let ((status-hook (external-process-status-hook p)))
     1575           (when status-hook
     1576             (funcall status-hook p)))
     1577         (remove-external-process p)
     1578         (signal-semaphore (external-process-completed p))
     1579         (return)))     
     1580      (if in-fd
     1581        (rlet ((handles (:array #>HANDLE 2)))
     1582          (setf (paref handles (:array #>HANDLE) 0) (external-process-pid p))
     1583          (setf (paref handles (:array #>HANDLE) 1) (#__get_osfhandle in-fd))
     1584          (let ((rc (#_WaitForMultipleObjects 2 handles #$FALSE #$INFINITE)))
     1585            (if (eq rc #$WAIT_OBJECT_0)
     1586              (setf terminated t)
     1587              (%stack-block ((buf 1024))
     1588                (let* ((n (fd-read in-fd buf 1024)))
     1589                  (declare (fixnum n))
     1590                  (if (<= n 0)
     1591                    (setf terminated t)
     1592                    (let* ((string (make-string 1024)))
     1593                      (declare (dynamic-extent string))
     1594                      (%str-from-ptr buf n string)
     1595                      (write-sequence string out-stream :end n))))))))
     1596        (progn
     1597          (#_WaitForSingleObject (external-process-pid p) #$INFINITE)
     1598          (setf terminated t))))))
    15921599 
    15931600
    1594 ) ; #+windows-target (progn
     1601)                                   ; #+windows-target (progn
    15951602
    15961603;;; EOF on a TTY is transient, but I'm less sure of other cases.
     
    19671974    (percentage-of-resident-pages address nbytes)))
    19681975)
    1969  
     1976
     1977#+windows-target
     1978(defun cygpath (winpath)
     1979  "Try to use the Cygwin \"cygpath\" program to map a Windows-style
     1980   pathname to a POSIX-stype Cygwin pathname."
     1981  (let* ((posix-path winpath))
     1982    (with-output-to-string (s)
     1983      (multiple-value-bind (status exit-code)
     1984          (external-process-status
     1985           (run-program "cygpath" (list "-u" winpath) :output s))
     1986        (when (and (eq status :exited)
     1987                   (eql exit-code 0))
     1988          (with-input-from-string (output (get-output-stream-string s))
     1989            (setq posix-path (read-line output nil nil))))))
     1990    posix-path))
     1991
     1992#-windows-target (defun cygpath (path) path)
     1993     
     1994
     1995
     1996
    19701997#+x86-target
    19711998(progn
Note: See TracChangeset for help on using the changeset viewer.