Changeset 9657


Ignore:
Timestamp:
Jun 2, 2008, 3:28:05 PM (11 years ago)
Author:
andreas
Message:

Implement substitute for missing mktemp, and thus input redirection for RUN-APPLICATION.
Make sure there's always a process status there, even when program launch fails.

File:
1 edited

Legend:

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

    r9647 r9657  
    12791279#+windows-target
    12801280(progn
     1281(defun temp-file-name (prefix)
     1282  "Returns a unique name for a temporary file, residing in system temp
     1283space, and prefixed with PREFIX."
     1284  (rlet ((buffer (:array :wchar_t #.#$MAX_PATH)))
     1285    (#_GetTempPathW #$MAX_PATH buffer)
     1286    (with-filename-cstrs ((c-prefix prefix))
     1287      (#_GetTempFileNameW buffer c-prefix 0 buffer)
     1288      (%get-native-utf-16-cstring buffer))))
     1289
    12811290(defun get-descriptor-for (object proc close-in-parent close-on-error
    12821291                                  &rest keys &key direction (element-type 'character)
     
    13371346     (ecase direction
    13381347       (: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)))))
     1348        (let* ((tempname (temp-file-name "lisp-temp"))
     1349               (fd (fd-open tempname #$O_RDWR)))
     1350          (if (< fd 0)
     1351            (%errno-disp fd))
     1352          (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)))))
     1365          (fd-lseek fd 0 #$SEEK_SET)
     1366          (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
    13591367       (:output
    13601368        (multiple-value-bind (read-pipe write-pipe) (pipe)
     
    13851393  watched-stream
    13861394  )
     1395
     1396(defun external-process-status (proc)
     1397  "Return information about whether an OS subprocess is running; or, if
     1398not, why not; and what its result code was if it completed."
     1399  (require-type proc 'external-process)
     1400  (values (external-process-%status proc)
     1401          (external-process-%exit-code proc)))
     1402
    13871403
    13881404(defmethod print-object ((p external-process) stream)
     
    14621478          (dolist (fd close-on-error) (fd-close fd))
    14631479          (error "Process execution failed"))))
    1464     (and (external-process-pid proc) proc)))
     1480    proc))
    14651481
    14661482(let* ((external-processes ())
     
    14921508        (signal-semaphore (external-process-signal proc))
    14931509        (monitor-external-process proc))
    1494     (error (condition) (signal-semaphore (external-process-signal proc)))))
     1510    (error (condition)
     1511      (setf (external-process-%status proc) :failed)
     1512      (signal-semaphore (external-process-signal proc)))))
    14951513
    14961514(defun join-strings (strings)
     
    15381556           (if in-fd (fd-close in-fd))
    15391557           (setq in-fd nil)
     1558           (rlet ((code #>DWORD))
     1559             (#_GetExitCodeProcess (external-process-pid p) code)
     1560             (setf (external-process-%exit-code p) (pref code #>DWORD)))
    15401561           (#_CloseHandle (external-process-pid p))
    15411562           (setf (external-process-pid p) nil)
Note: See TracChangeset for help on using the changeset viewer.