Changeset 9549

Timestamp:

May 19, 2008, 9:58:53 AM (17 years ago)

Author:

andreas

Message:

Stub for run-program implementation for Windows.

File:

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

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

@@ -492 +492 @@
     (%uts-string (#___xuname #$SYS_NMLN buf) idx buf)))
 
+#-windows-target
 (defun fd-dup (fd)
   (int-errno-call (#_dup fd)))
+
+#+windows-target
+(defun fd-dup (fd &key direction inheritable)
+  (rlet ((handle #>LPHANDLE))
+    (#_DuplicateHandle (#_GetCurrentProcess)
+                       (#__get_osfhandle fd)
+                       (#_GetCurrentProcess) 
+                       handle
+                       0
+                       (if inheritable #$TRUE #$FALSE)
+                       #$DUPLICATE_SAME_ACCESS)
+    (#__open_osfhandle (pref handle #>HANDLE) (case direction
+                                                (:input #$O_RDONLY)
+                                                (:output #$O_WRONLY)
+                                                (t #$O_RDWR)))))
+                       
 
 (defun fd-fsync (fd)
@@ -1262 +1279 @@
 #+windows-target
 (progn
-#+windows-target
+(defun get-descriptor-for (object proc close-in-parent close-on-error
+                                  &rest keys &key direction (element-type 'character)
+                                  &allow-other-keys)
+  (etypecase object
+    ((eql t)
+     (values nil nil close-in-parent close-on-error))
+    (null
+     (let* ((null-device "nul")
+            (fd (fd-open null-device (case direction
+                                       (:input #$O_RDONLY)
+                                       (:output #$O_WRONLY)
+                                       (t #$O_RDWR)))))
+       (if (< fd 0)
+         (signal-file-error fd null-device))
+       (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
+    ((eql :stream)
+     (multiple-value-bind (read-pipe write-pipe) (pipe)
+       (case direction
+         (:input
+          (values read-pipe
+                  (make-fd-stream (fd-uninheritable write-pipe :direction :output)
+                                  :direction :output
+                                  :element-type element-type
+                                  :interactive nil
+                                  :basic t
+                                  :auto-close t)
+                  (cons read-pipe close-in-parent)
+                  (cons write-pipe close-on-error)))
+         (:output
+          (values write-pipe
+                  (make-fd-stream (fd-uninheritable read-pipe :direction :input)
+                                  :direction :input
+                                  :element-type element-type
+                                  :interactive nil
+                                  :basic t
+                                  :auto-close t)
+                  (cons write-pipe close-in-parent)
+                  (cons read-pipe close-on-error)))
+         (t
+          (fd-close read-pipe)
+          (fd-close write-pipe)
+          (report-bad-arg direction '(member :input :output))))))
+    ((or pathname string)
+     (with-open-stream (file (apply #'open object keys))
+       (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t)) :direction direction :inheritable t)))
+         (values fd
+                 nil
+                 (cons fd close-in-parent)
+                 (cons fd close-on-error)))))
+    (fd-stream
+     (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
+       (values fd
+               nil
+               (cons fd close-in-parent)
+               (cons fd close-on-error))))
+    (stream
+     (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)))))
+       (:output
+        (multiple-value-bind (read-pipe write-pipe) (pipe)
+          (setf (external-process-watched-fd proc) read-pipe
+                (external-process-watched-stream proc) object)
+          (incf (car (external-process-token proc)))
+          (values write-pipe
+                  nil
+                  (cons write-pipe close-in-parent)
+                  (cons read-pipe close-on-error))))))))
+
+(defstruct external-process
+  pid
+  %status
+  %exit-code
+  pty
+  input
+  output
+  error
+  status-hook
+  plist
+  token
+  core
+  args
+  (signal (make-semaphore))
+  (completed (make-semaphore))
+  watched-fd
+  watched-stream
+  )
+
+(defmethod print-object ((p external-process) stream)
+  (print-unreadable-object (p stream :type t :identity t)
+    (let* ((status (external-process-%status p)))
+      (let* ((*print-length* 3))
+        (format stream "~a" (external-process-args p)))
+      (format stream "[~d] (~a" (external-process-pid p) status)
+      (unless (eq status :running)
+        (format stream " : ~d" (external-process-%exit-code p)))
+      (format stream ")"))))
+
+(defun run-program (program args &key
+                            (wait t) pty
+                            input if-input-does-not-exist
+                            output (if-output-exists :error)
+                            (error :output) (if-error-exists :error)
+                            status-hook (element-type 'character)
+                            env)
+  "Invoke an external program as an OS subprocess of lisp."
+  (declare (ignore pty))
+  (unless (every #'(lambda (a) (typep a 'simple-string)) args)
+    (error "Program args must all be simple strings : ~s" args))
+;  (push (native-untranslated-namestring program) args)
+  (push program args)
+  (let* ((token (list 0))
+         (in-fd nil)
+         (in-stream nil)
+         (out-fd nil)
+         (out-stream nil)
+         (error-fd nil)
+         (error-stream nil)
+         (close-in-parent nil)
+         (close-on-error nil)
+         (proc
+          (make-external-process
+           :pid nil
+           :args args
+           :%status :running
+           :input nil
+           :output nil
+           :error nil
+           :token token
+           :status-hook status-hook)))
+    (unwind-protect
+         (progn
+           (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
+             (get-descriptor-for input proc  nil nil :direction :input
+                                 :if-does-not-exist if-input-does-not-exist
+                                 :element-type element-type))
+           (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
+             (get-descriptor-for output proc close-in-parent close-on-error
+                                 :direction :output
+                                 :if-exists if-output-exists
+                                 :element-type element-type))
+           (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
+             (if (eq error :output)
+               (values out-fd out-stream close-in-parent close-on-error)
+               (get-descriptor-for error proc close-in-parent close-on-error
+                                   :direction :output
+                                   :if-exists if-error-exists
+                                   :element-type element-type)))
+           (setf (external-process-input proc) in-stream
+                 (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)
+                    
+            #'run-external-process proc in-fd out-fd error-fd env)
+           (wait-on-semaphore (external-process-signal proc))
+           )
+      (dolist (fd close-in-parent) (fd-close fd))
+      (unless (external-process-pid proc)
+        (dolist (fd close-on-error) (fd-close fd)))
+      (when (and wait (external-process-pid proc))
+        (with-interrupts-enabled
+            (wait-on-semaphore (external-process-completed proc)))))
+    (and (external-process-pid proc) proc)))
+
+(let* ((external-processes ())
+       (external-processes-lock (make-lock)))
+  (defun add-external-process (p)
+    (with-lock-grabbed (external-processes-lock)
+      (push p external-processes)))
+  (defun remove-external-process (p)
+    (with-lock-grabbed (external-processes-lock)
+      (setq external-processes (delete p external-processes))))
+  ;; Likewise
+  (defun external-processes ()
+    (with-lock-grabbed (external-processes-lock)
+      (copy-list external-processes)))
+  )
+
+
 (defun pipe ()
   (%stack-block ((filedes 8))
     (syscall syscalls::pipe filedes)
     (values (paref filedes (:array :int)  0) (paref filedes (:array :int)  1))))
+
+(defun run-external-process (proc in-fd out-fd error-fd &optional env)
+  ;; stub, stub
+  (let* ((args (external-process-args proc))
+         (child-pid (exec-with-io-redirection in-fd out-fd error-fd (car args) (cdr args))))
+    (setf (external-process-pid proc) child-pid)
+    (add-external-process proc)
+    (signal-semaphore (external-process-signal proc))
+    (monitor-external-process proc)))
+
+(defun exec-with-io-redirection (new-in new-out new-err command args)
+  (with-filename-cstrs ((command command))
+    (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.hStdInput) (#__get_osfhandle new-in))
+      (setf (pref si #>STARTUPINFO.hStdOutput) (#__get_osfhandle new-out))
+      (setf (pref si #>STARTUPINFO.hStdError) (#__get_osfhandle new-err))
+      (if (zerop (#_CreateProcessW (%null-ptr)
+                                   command
+                                   (%null-ptr)
+                                   (%null-ptr)
+                                   1
+                                   #$CREATE_NEW_CONSOLE
+                                   (%null-ptr)
+                                   (%null-ptr)
+                                   si
+                                   proc-info))
+          (error "Process creation failed"))
+      (pref proc-info #>PROCESS_INFORMATION.hProcess))))
+
+(defun fd-uninheritable (fd &key direction)
+  (let ((new-fd (fd-dup fd :direction direction)))
+    (fd-close fd)
+    new-fd))
+
+(defun monitor-external-process (p)
+  (let* ((in-fd (external-process-watched-fd p))
+         (out-stream (external-process-watched-stream p))
+         (token (external-process-token p))
+         (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))))))))))
+  
+
 ) ; #+windows-target (progn