Changeset 9657 for branches

Timestamp:

Jun 2, 2008, 8:28:05 AM (16 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:

• branches/win64/level-1/linux-files.lisp (modified) (6 diffs)

branches/win64/level-1/linux-files.lisp

@@ -1279 +1279 @@
 #+windows-target
 (progn
+(defun temp-file-name (prefix)
+  "Returns a unique name for a temporary file, residing in system temp
+space, and prefixed with PREFIX."
+  (rlet ((buffer (:array :wchar_t #.#$MAX_PATH)))
+    (#_GetTempPathW #$MAX_PATH buffer)
+    (with-filename-cstrs ((c-prefix prefix)) 
+      (#_GetTempFileNameW buffer c-prefix 0 buffer)
+      (%get-native-utf-16-cstring buffer))))
+
 (defun get-descriptor-for (object proc close-in-parent close-on-error
                                   &rest keys &key direction (element-type 'character)
@@ -1337 +1346 @@
      (ecase direction
        (:input
-        (with-cstrs ((template "lisp-tempXXXXXX"))
-          (let* ((fd (#_mktemp template)))
-            (if (< fd 0)
-              (%errno-disp fd))
-            (#_unlink template)
-            (loop
-              (multiple-value-bind (line no-newline)
-                  (read-line object nil nil)
-                (unless line
-                  (return))
-                (let* ((len (length line)))
-                  (%stack-block ((buf (1+ len)))
-                    (%cstr-pointer line buf)
-                    (fd-write fd buf len)
-                    (if no-newline
-                      (return))
-                    (setf (%get-byte buf) (char-code #\newline))
-                    (fd-write fd buf 1)))))
-            (fd-lseek fd 0 #$SEEK_SET)
-            (values fd nil (cons fd close-in-parent) (cons fd close-on-error)))))
+        (let* ((tempname (temp-file-name "lisp-temp"))
+               (fd (fd-open tempname #$O_RDWR)))
+          (if (< fd 0)
+            (%errno-disp fd))
+          (loop
+             (multiple-value-bind (line no-newline)
+                 (read-line object nil nil)
+               (unless line
+                 (return))
+               (let* ((len (length line)))
+                 (%stack-block ((buf (1+ len)))
+                   (%cstr-pointer line buf)
+                   (fd-write fd buf len)
+                   (if no-newline
+                     (return))
+                   (setf (%get-byte buf) (char-code #\newline))
+                   (fd-write fd buf 1)))))
+          (fd-lseek fd 0 #$SEEK_SET)
+          (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
        (:output
         (multiple-value-bind (read-pipe write-pipe) (pipe)
@@ -1385 +1393 @@
   watched-stream
   )
+
+(defun external-process-status (proc)
+  "Return information about whether an OS subprocess is running; or, if
+not, why not; and what its result code was if it completed."
+  (require-type proc 'external-process)
+  (values (external-process-%status proc)
+          (external-process-%exit-code proc)))
+
 
 (defmethod print-object ((p external-process) stream)
@@ -1462 +1478 @@
           (dolist (fd close-on-error) (fd-close fd))
           (error "Process execution failed"))))
-    (and (external-process-pid proc) proc)))
+    proc))
 
 (let* ((external-processes ())
@@ -1492 +1508 @@
         (signal-semaphore (external-process-signal proc))
         (monitor-external-process proc))
-    (error (condition) (signal-semaphore (external-process-signal proc)))))
+    (error (condition)
+      (setf (external-process-%status proc) :failed)
+      (signal-semaphore (external-process-signal proc)))))
 
 (defun join-strings (strings)
@@ -1538 +1556 @@
            (if in-fd (fd-close in-fd))
            (setq in-fd nil)
+           (rlet ((code #>DWORD))
+             (#_GetExitCodeProcess (external-process-pid p) code)
+             (setf (external-process-%exit-code p) (pref code #>DWORD)))
            (#_CloseHandle (external-process-pid p))
            (setf (external-process-pid p) nil)