Changeset 824
- Timestamp:
- Jun 5, 2004, 10:57:31 PM (20 years ago)
- File:
-
- 1 edited
-
trunk/ccl/level-1/linux-files.lisp (modified) (10 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/ccl/level-1/linux-files.lisp
r820 r824 476 476 477 477 478 (defmacro with-forked-pid (pidvar child-form parent-form)479 `(let* ((,pidvar (#_fork)))480 (declare (fixnum ,pidvar))481 (cond ((zerop ,pidvar) ,child-form)482 ((> ,pidvar 0) ,parent-form)483 (t (%errno-disp ,pidvar)))))484 485 478 486 479 … … 516 509 args 517 510 (signal (make-semaphore)) 511 (completed (make-semaphore)) 512 watched-fd 513 watched-stream 518 514 ) 519 515 … … 528 524 (format stream ")")))) 529 525 530 (defun get-descriptor-for (object tokenclose-in-parent close-on-error526 (defun get-descriptor-for (object proc close-in-parent close-on-error 531 527 &rest keys &key direction 532 528 &allow-other-keys) … … 599 595 (:output 600 596 (multiple-value-bind (read-pipe write-pipe) (pipe) 601 (watch-fd-output read-pipe object token) 597 (setf (external-process-watched-fd proc) read-pipe 598 (external-process-watched-stream proc) object) 599 (incf (car (external-process-token proc))) 602 600 (values write-pipe 603 601 nil … … 606 604 607 605 (let* ((external-processes ()) 608 (watched-fd-handlers ()) 609 (external-processes-lock (make-lock)) 610 (watched-fd-handlers-lock (make-lock))) 606 (external-processes-lock (make-lock))) 611 607 (defun add-external-process (p) 612 608 (with-lock-grabbed (external-processes-lock) … … 615 611 (with-lock-grabbed (external-processes-lock) 616 612 (setq external-processes (delete p external-processes)))) 617 (defun add-watched-fd-handler (h)618 (with-lock-grabbed (watched-fd-handlers-lock)619 (push h watched-fd-handlers)))620 (defun remove-watched-fd-handler (h)621 (with-lock-grabbed (watched-fd-handlers-lock)622 (setq watched-fd-handlers (delete h watched-fd-handlers))))623 (defun watch-file-descriptors ()624 (with-lock-grabbed (watched-fd-handlers-lock)625 (dolist (h watched-fd-handlers) (funcall h))626 (null watched-fd-handlers)))627 (defun check-all-pids ()628 (with-lock-grabbed (external-processes-lock)629 (dolist (p external-processes)630 (let* ((statusflags (check-pid (external-process-pid p)))631 (oldstatus (external-process-%status p)))632 (cond ((null statusflags)633 (remove-external-process p))634 ((eq statusflags t)) ; Running.635 (t636 (multiple-value-bind (status code core)637 (cond ((wifstopped statusflags)638 (values :stopped (wstopsig statusflags)))639 ((wifexited statusflags)640 (values :exited (wexitstatus statusflags)))641 (t642 (let* ((signal (wtermsig statusflags)))643 (declare (fixnum signal))644 (values645 (if (or (= signal #$SIGSTOP)646 (= signal #$SIGTSTP)647 (= signal #$SIGTTIN)648 (= signal #$SIGTTOU))649 :stopped650 :signaled)651 signal652 (logtest #$WCOREFLAG statusflags)))))653 (setf (external-process-%status p) status654 (external-process-%exit-code p) code655 (external-process-core p) core)656 (let* ((status-hook (external-process-status-hook p)))657 (when (and status-hook (not (eq oldstatus status)))658 (funcall status-hook p)))659 (when (or (eq status :exited)660 (eq status :signaled))661 (remove-external-process p)))))))662 (null external-processes)))663 ;; Returns a copy, for debugging.664 (defun watched-fd-handlers ()665 (with-lock-grabbed (watched-fd-handlers-lock)666 (copy-list watched-fd-handlers)))667 613 ;; Likewise 668 614 (defun external-processes () … … 694 640 (add-watched-fd-handler handler)) 695 641 nil) 696 642 643 (defun monitor-external-process (p) 644 (let* ((in-fd (external-process-watched-fd p)) 645 (out-stream (external-process-watched-stream p)) 646 (token (external-process-token p)) 647 (terminated)) 648 (loop 649 (when (and terminated (null in-fd)) 650 (signal-semaphore (external-process-completed p)) 651 (return)) 652 (if in-fd 653 (progn 654 (format t "~& waiting for input") 655 (when (fd-input-available-p in-fd *ticks-per-second*) 656 (%stack-block ((buf 1024)) 657 (let* ((n (fd-read in-fd buf 1024))) 658 (declare (fixnum n)) 659 (format t "~& n bytes available") 660 (if (<= n 0) 661 (progn 662 (without-interrupts 663 (decf (car token)) 664 (fd-close in-fd) 665 (setq in-fd nil))) 666 (let* ((string (make-string 1024))) 667 (declare (dynamic-extent string)) 668 (%copy-ptr-to-ivector buf 0 string 0 n) 669 (write-sequence string out-stream :end n))))))) 670 (sleep 1)) 671 (let* ((statusflags (check-pid (external-process-pid p))) 672 (oldstatus (external-process-%status p))) 673 (cond ((null statusflags) 674 (remove-external-process p) 675 (setq terminated t)) 676 ((eq statusflags t)) ; Running. 677 (t 678 (multiple-value-bind (status code core) 679 (cond ((wifstopped statusflags) 680 (values :stopped (wstopsig statusflags))) 681 ((wifexited statusflags) 682 (values :exited (wexitstatus statusflags))) 683 (t 684 (let* ((signal (wtermsig statusflags))) 685 (declare (fixnum signal)) 686 (values 687 (if (or (= signal #$SIGSTOP) 688 (= signal #$SIGTSTP) 689 (= signal #$SIGTTIN) 690 (= signal #$SIGTTOU)) 691 :stopped 692 :signaled) 693 signal 694 (logtest #$WCOREFLAG statusflags))))) 695 (setf (external-process-%status p) status 696 (external-process-%exit-code p) code 697 (external-process-core p) core) 698 (let* ((status-hook (external-process-status-hook p))) 699 (when (and status-hook (not (eq oldstatus status))) 700 (funcall status-hook p))) 701 (when (or (eq status :exited) 702 (eq status :signaled)) 703 (remove-external-process p) 704 (setq terminated t))))))))) 705 697 706 (defun run-external-process (proc in-fd out-fd error-fd) 698 707 (call-with-string-vector … … 708 717 ;; Running in the parent: success 709 718 (setf (external-process-pid proc) child-pid) 719 (add-external-process proc) 710 720 (signal-semaphore (external-process-signal proc)) 711 (add-external-process proc)))))721 (monitor-external-process proc))))) 712 722 (external-process-args proc))) 713 723 … … 732 742 (close-in-parent nil) 733 743 (close-on-error nil) 734 (proc nil)) 744 (proc 745 (make-external-process 746 :pid nil 747 :args args 748 :%status :running 749 :input nil 750 :output nil 751 :error nil 752 :token token 753 :status-hook status-hook))) 735 754 (unwind-protect 736 755 (progn 737 756 (multiple-value-setq (in-fd in-stream close-in-parent close-on-error) 738 (get-descriptor-for input tokennil nil :direction :input757 (get-descriptor-for input proc nil nil :direction :input 739 758 :if-does-not-exist if-input-does-not-exist)) 740 759 (multiple-value-setq (out-fd out-stream close-in-parent close-on-error) 741 (get-descriptor-for output tokenclose-in-parent close-on-error760 (get-descriptor-for output proc close-in-parent close-on-error 742 761 :direction :output 743 762 :if-exists if-output-exists)) … … 745 764 (if (eq error :output) 746 765 (values out-fd out-stream close-in-parent close-on-error) 747 (get-descriptor-for error tokenclose-in-parent close-on-error766 (get-descriptor-for error proc close-in-parent close-on-error 748 767 :direction :output 749 768 :if-exists if-error-exists))) 750 (setq proc 751 (make-external-process 752 :pid nil 753 :args args 754 :%status :running 755 :input in-stream 756 :output out-stream 757 :error error-stream 758 :token token 759 :status-hook status-hook)) 760 (process-interrupt *initial-process* #'run-external-process proc in-fd out-fd error-fd) 761 (wait-on-semaphore (external-process-signal proc)) 762 ) 763 764 (dolist (fd close-in-parent) (fd-close fd)) 765 (unless (external-process-pid proc) 766 (dolist (fd close-on-error) (fd-close fd))) 767 (when (and wait (external-process-pid proc)) 768 (external-process-wait proc))) 769 (and proc (external-process-pid proc) proc))) 769 (setf (external-process-input proc) in-stream 770 (external-process-output proc) out-stream 771 (external-process-error proc) error-stream) 772 (process-run-function 773 (format nil "Monitor thread for external process ~a" args) 774 775 #'run-external-process proc in-fd out-fd error-fd) 776 (wait-on-semaphore (external-process-signal proc)) 777 ) 778 779 (dolist (fd close-in-parent) (fd-close fd)) 780 (unless (external-process-pid proc) 781 (dolist (fd close-on-error) (fd-close fd))) 782 (when (and wait (external-process-pid proc)) 783 (wait-on-semaphore (external-process-completed proc)))) 784 (and (external-process-pid proc) proc))) 770 785 771 786 #|
Note:
See TracChangeset
for help on using the changeset viewer.
