Changeset 9550

Timestamp:

May 19, 2008, 1:32:37 PM (17 years ago)

Author:

andreas

Message:

Working MONITOR-FUNCTION for RUN-PROCESS.

File:

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

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

@@ -1449 +1449 @@
                  (external-process-output proc) out-stream
                  (external-process-error proc) error-stream)
-           (format t "~s ~s ~s" in-fd out-fd error-fd)
            (process-run-function
             (format nil "Monitor thread for external process ~a" args)
@@ -1487 +1486 @@
   ;; stub, stub
   (let* ((args (external-process-args proc))
-         (child-pid (exec-with-io-redirection in-fd out-fd error-fd (car args) (cdr args))))
+         (child-pid (exec-with-io-redirection in-fd out-fd error-fd args)))
     (setf (external-process-pid proc) child-pid)
     (add-external-process proc)
@@ -1493 +1492 @@
     (monitor-external-process proc)))
 
-(defun exec-with-io-redirection (new-in new-out new-err command args)
-  (with-filename-cstrs ((command command))
+(defun join-strings (strings)
+  (reduce (lambda (left right) (concatenate 'string left " " right)) strings))
+
+(defun exec-with-io-redirection (new-in new-out new-err args)
+  (with-filename-cstrs ((command (join-strings args)))
     (rletz ((proc-info #>PROCESS_INFORMATION)
             (si #>STARTUPINFO))
       (setf (pref si #>STARTUPINFO.cb) (record-length #>STARTUPINFO))
-      (setf (pref si #>STARTUPINFO.dwFlags) #$STARTF_USESTDHANDLES)
+      (setf (pref si #>STARTUPINFO.dwFlags)
+            (logior #$STARTF_USESTDHANDLES #$STARTF_USESHOWWINDOW))
+      (setf (pref si #>STARTUPINFO.wShowWindow) #$SW_HIDE)
       (setf (pref si #>STARTUPINFO.hStdInput) (#__get_osfhandle new-in))
       (setf (pref si #>STARTUPINFO.hStdOutput) (#__get_osfhandle new-out))
@@ -1513 +1517 @@
                                    proc-info))
           (error "Process creation failed"))
+      (#_CloseHandle (pref proc-info #>PROCESS_INFORMATION.hThread))
       (pref proc-info #>PROCESS_INFORMATION.hProcess))))
 
@@ -1526 +1531 @@
          (terminated))
     (loop
-      (when (and terminated (null in-fd))
-        (signal-semaphore (external-process-completed p))
-        (return))
-      (when in-fd
-        (when (fd-input-available-p in-fd 1000)
-          (%stack-block ((buf 1024))
-            (let* ((n (fd-read in-fd buf 1024)))
-              (declare (fixnum n))
-              (if (<= n 0)
-                (progn
-                  (without-interrupts
-                   (decf (car token))
-                   (fd-close in-fd)
-                   (setq terminated t) ; need equiv. of waitpid here
-                   (setq in-fd nil)))
-                (let* ((string (make-string 1024)))
-                  (declare (dynamic-extent string))
-                  (%str-from-ptr buf n string)
-                  (write-sequence string out-stream :end n))))))))))
+       (when terminated
+         (without-interrupts
+             (decf (car token))
+           (if in-fd (fd-close in-fd))
+           (setq in-fd nil)
+           (#_CloseHandle (external-process-pid p))
+           (setf (external-process-pid p) nil)
+           (setf (external-process-%status p) :exited)
+           (let ((status-hook (external-process-status-hook p)))
+             (when status-hook
+               (funcall status-hook p)))
+           (remove-external-process p)
+           (signal-semaphore (external-process-completed p))
+           (return)))    
+       (if in-fd
+         (rlet ((handles (:array #>HANDLE 2)))
+           (setf (paref handles (:array #>HANDLE) 0) (external-process-pid p))
+           (setf (paref handles (:array #>HANDLE) 1) (#__get_osfhandle in-fd))
+           (let ((rc (#_WaitForMultipleObjects 2 handles #$FALSE #$INFINITE)))
+             (if (eq rc #$WAIT_OBJECT_0)
+               (setf terminated t)
+               (%stack-block ((buf 1024))
+                 (let* ((n (fd-read in-fd buf 1024)))
+                   (declare (fixnum n))
+                   (if (<= n 0)
+                       (setf terminated t)
+                       (let* ((string (make-string 1024)))
+                         (declare (dynamic-extent string))
+                         (%str-from-ptr buf n string)
+                         (write-sequence string out-stream :end n))))))))
+         (progn
+           (#_WaitForSingleObject (external-process-pid p) #$INFINITE)
+           (setf terminated t))))))