/[meta-cvs]/meta-cvs/F-6BD7679FED76D6E5A7D36DC36C205FC1.lisp
ViewVC logotype

Diff of /meta-cvs/F-6BD7679FED76D6E5A7D36DC36C205FC1.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.24 by kaz, Fri Nov 24 05:04:27 2006 UTC revision 1.25 by kaz, Mon Nov 27 02:40:02 2006 UTC
# Line 320  Line 320 
320      (values)      (values)
321      (error (make-condition 'rm-error :path file))))      (error (make-condition 'rm-error :path file))))
322    
323    ;;; pipes
324    
325    ;;; A process pipe consists of a CLISP stream (input or output), and a child
326    ;;; process ID.  Additionally, the direction records the stream's direction,
327    ;;; the fd records its file descriptor.
328    
329    (defstruct process-pipe
330      (stream)
331      (child-pid)
332      (direction)
333      (fd))
334    
335    (defun create-process-pipe (func direction)
336      (multiple-value-bind (result fd) (unix-funcs:pipe)
337        (when (< 0 result)
338          (error "failed to create pipe: ~A"
339                 (unix-funcs:strerror unix-funcs:errno)))
340        (let ((child (unix-funcs:fork)))
341          (cond
342            ((< child 0)
343             (map nil #'unix-funcs:close fd)
344             (error "fork failed: ~A."
345                    (unix-funcs:strerror unix-funcs:errno)))
346            ((zerop child)
347              (case direction
348                (:output
349                  (ext:duplicate-handle (aref fd 0) 0)
350                  (setf *standard-input* (ext:make-stream
351                                           (aref fd 0)
352                                           :direction :input
353                                           :element-type 'character)))
354                (:input
355                  (ext:duplicate-handle (aref fd 1) 1)
356                  (setf *standard-output* (ext:make-stream
357                                            (aref fd 1)
358                                            :direction :output
359                                            :element-type 'character))))
360              (map nil #'unix-funcs:close fd)
361              (funcall func)
362              (force-output *standard-output*)
363              (unix-funcs:_exit 1))
364            (t
365              (unwind-protect
366                (case direction
367                  (:output
368                    (make-process-pipe
369                      :stream (ext:make-stream (aref fd 1)
370                                               :direction direction
371                                               :element-type 'character)
372                      :direction direction
373                      :fd (ext:duplicate-handle (aref fd 1))
374                      :child-pid child))
375                  (:input
376                    (make-process-pipe
377                      :stream (ext:make-stream (aref fd 0)
378                                               :direction direction
379                                               :element-type 'character)
380                      :direction direction
381                      :fd (ext:duplicate-handle (aref fd 0))
382                      :child-pid child)))
383                (map nil #'unix-funcs:close fd)))))))
384    
385    (defun close-process-pipe (pipe)
386      (unix-funcs:default-sigchld)
387      (close (slot-value pipe 'stream))
388      (unix-funcs:close (slot-value pipe 'fd))
389      (setf (slot-value pipe 'stream) nil)
390      (setf (slot-value pipe 'fd) nil)
391      (loop for result = (unix-funcs:waitpid (slot-value pipe 'child-pid) 0)
392            do (when (and (< result 0) (/= unix-funcs:errno unix-funcs:eintr))
393                 (error "waitpid failed: ~A"
394                        (unix-funcs:strerror unix-funcs:errno)))
395            until (>= result 0))
396      (setf (slot-value pipe 'child-pid) nil)
397      (values))
398    
399  ;;; Coprocesses  ;;; Coprocesses
400    
401  (defun shell-interpreter (command)  (defun shell-interpreter (command)
# Line 327  Line 403 
403      ((0) T)      ((0) T)
404      (otherwise nil)))      (otherwise nil)))
405    
406    (defvar *default-execute-filter* nil)
407    
408  (defun execute-program (arglist)  (defun execute-program (arglist)
409    (chatter-debug "invoking ~s in directory ~s~%" arglist (getcwd))    (chatter-debug "invoking ~s in directory ~s~%" arglist (getcwd))
410    (case (unix-funcs:run-program (first arglist) :arguments (rest arglist))    (let ((result nil))
411      ((0) (chatter-debug "successful termination~%") T)      (let ((pipe nil)
412      (otherwise (chatter-debug "unsuccessful or abnormal termination~%") nil)))            (saved-handle)
413              (saved-handle-which)
414              (*standard-output* *standard-output*)
415              (*standard-input* *standard-input*))
416          (unwind-protect
417            (progn
418              (when *default-execute-filter*
419                (setf pipe (funcall *default-execute-filter*))
420                (case (slot-value pipe 'direction)
421                  (:output
422                    (setf *standard-output* (slot-value pipe 'stream))
423                    (setf saved-handle (ext:duplicate-handle 1))
424                    (setf saved-handle-which 1)
425                    (ext:duplicate-handle (slot-value pipe 'fd) 1))
426                  (:input
427                    (setf *standard-input* (slot-value pipe 'stream))
428                    (setf saved-handle (ext:duplicate-handle 0))
429                    (setf saved-handle-which 0)
430                    (ext:duplicate-handle (slot-value pipe 'fd) 0))))
431              (setf result (unix-funcs:run-program (first arglist)
432                                                   :arguments (rest arglist))))
433            (when saved-handle
434              (ext:duplicate-handle saved-handle saved-handle-which))
435            (when pipe
436              (close-process-pipe pipe))))
437        (case result
438          ((0)
439            (chatter-debug "successful termination~%") T)
440          (otherwise
441            (chatter-debug "unsuccessful or abnormal termination~%") nil))))
442    
443    (defmacro with-filtered-execute-program ((enabled-expr func-expr direction)
444                                             &body body)
445      `(let* ((*default-execute-filter*
446                (if ,enabled-expr
447                  (lambda () (create-process-pipe ,func-expr ,direction))
448                  *default-execute-filter*)))
449         ,@body))
450    
451  (defmacro with-input-from-program ((stream-var arg-list) &body forms)  (defmacro with-input-from-program ((stream-var arg-list) &body forms)
452    (let ((arg-list-sym (gensym "ARG-LIST-")))    (let ((arg-list-sym (gensym "ARG-LIST-")))

Legend:
Removed from v.1.24  
changed lines
  Added in v.1.25

  ViewVC Help
Powered by ViewVC 1.1.5