;;; -*- Mode: Common-Lisp; Package: chaos; Base: 10.; Patch-File: T -*- ;;; Reason: Fixed remote-eval and remote-eval-server to handle errors arising when the client reference a package defined on the server machine but not defined on the client. [10734] ;;; RESTRICTED RIGHTS LEGEND ;;; ;;; Use, duplication, or disclosure by the Government is subject to ;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;; Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909, M/S 2151 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1989 Texas Instruments Incorporated. ;;; All rights reserved. ;;; Written 10/31/89 14:17:10 by BERGER, ;;; while running on ARIES from band LODX ;;; With SYSTEM 6.23, VIRTUAL-MEMORY 6.2, EH 6.5, MAKE-SYSTEM 6.2, MICRONET 6.0, LOCAL-FILE 6.1, ;;; BASIC-PATHNAME 6.2, NETWORK-SUPPORT-COLD 6.2, BASIC-NAMESPACE 6.6, NETWORK-NAMESPACE 6.0, ;;; DISK-IO 6.1, DISK-LABEL 6.0, BASIC-FILE 6.5, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0, ;;; COMPILER 6.14, TV 6.18, DATALINK 6.0, CHAOSNET 6.1, GC 6.3, MEMORY-AUX 6.0, NVRAM 6.2, ;;; SYSLOG 6.2, STREAMER-TAPE 6.4, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ZWEI 6.8, ;;; DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.2, DATALINK-DISPLAYS 6.0, ;;; FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.3, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.2, ;;; IMAGEN 6.1, SUGGESTIONS 6.1, MAIL-DAEMON 6.3, MAIL-READER 6.5, TELNET 6.0, VT100 6.0, ;;; NAMESPACE-EDITOR 6.4, PROFILE 6.2, VISIDOC 6.5, TI-CLOS 6.26, CLEH 6.5, IP 3.55, ;;; Experimental CLX 6.6, CLUE 6.27, X11M 6.15, Experimental BUG 11.15, microcode 429, ;;; Band Name: rel6.0 10/23 #!C ; From file EVAL.LISP#> CHAOSNET; sys: #10R CHAOS#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "CHAOS")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: CHAOSNET; EVAL.#" (defun eval-server-function () (let ((conn (listen "EVAL")) (*package* (find-package 'user))) (cond ((and (null eval-server-on) (not (member user-id '(nil "") :test #'equal))) (reject conn (format nil "This machine is in use by ~A, try again later." user-id)) (return-from eval-server-function nil)) ((eq eval-server-on :notify) (process-run-function "Notify" 'tv:notify () "EVAL server being used by ~A" (host-short-name (foreign-address conn))) (process-allow-schedule) (accept conn)) (t (accept conn))) (push conn eval-server-connections) (return-from eval-server-function (catch-error (with-open-stream (stream (make-stream conn :ascii-translation t)) (let ((generic-server (make-instance 'generic-eval-server :conn conn :server-stream stream))) (send tv:who-line-file-state-sheet :add-server generic-server "EVAL" si:current-process)) (do* ((*terminal-io* stream) ; Don't blow away machine on lossage (input (condition-case (condition) (read stream nil 'quit) (error condition)) ; DAB 10-31-89 (condition-case (condition) (read stream nil 'quit) (error condition)))) ; DAB 10-31-89 ((and (symbolp input) (string-equal (symbol-name input) "Quit")) nil) (catch-error (if (typep input 'condition) ; DAB 10-31-89 If condition , return report string. (progn (send stream :clear-input) (format stream "~s" (send input :report-string))) (dolist (value (multiple-value-list (eval input))) (format stream "~s~%" value))) t) (write-char #\End stream) (send stream :force-output))) ())) ())) (defun remote-eval (host ) (let (form remote-packages x-cursor y-cursor) (declare (special remote-packages x-cursor y-cursor)) (with-open-stream (chaos-stream (open-stream host "EVAL" :ascii-translation t)) (format t "~%Eval Service ~A.~ ~%Type in forms to be evaluated on remote host. To quit press ABORT.~%" host) (unwind-protect (loop (multiple-value-setq (x-cursor y-cursor) (send *standard-input* :read-cursorpos)) ; DAB 10-31-89 ;;DAB 10-31-89 The following condition-bind was added to handle certain error that ;;may be generated by the reader that may not really be an error at the server. ;;For example: packages may exist on the server , but not on the local machine. ;;The local READER will generate a "package not found" error before the ;;request is sent to the server. In this case we will create the package locally, ;;redisplay the buffer and continue on. The packages will be removed when the ;;remote-eval is terminated. The user may see some delay while the package is being ;;created, but input character will not be losted. [10734] (SETQ form (condition-bind ((sys:package-not-found ; DAB 10-31-89 #'(lambda (condition) (let (x-cur y-cur) (declare (special remote-packages x-cursor y-cursor)) ;;get cursor boundary to clear later. (multiple-value-setq (x-cur y-cur) (send *standard-input* :read-cursorpos)) (multiple-value-bind (buffer index) ;;need this to restore later (send *standard-input* :save-rubout-handler-buffer) ;;Now make the package, save so we can delete later. (push (make-package (send condition :name)) remote-packages ) ;;noew we need to restore the rubout buffers. (without-interrupts (send *standard-input* :clear-between-cursorposes x-cursor y-cursor x-cur y-cur) (send *standard-input* :set-cursorpos x-cursor y-cursor) (send *standard-input* :restore-rubout-handler-buffer buffer index)))) (throw 'rubout-handler t))) (error #'(lambda (condition) ; DAB 10-31-89 ;;just print the error and let the normal rubout-handler ;;handle it. (format *standard-input* "~%~a~%" (send condition :report-string)) (throw 'rubout-handler t)) )) (with-input-editing (*standard-input* '((:dont-handle-errors T))) (read *standard-input* t)))) (format *standard-output* "~&") (format chaos-stream "~s~%" form) (send chaos-stream :force-output) (when (and (symbolp form) (string-equal (symbol-name form) "Quit")) (return ())) (do ((char (read-char chaos-stream) (read-char chaos-stream))) ((eql char #\End)) (write-char char *standard-output*))) ;loop (dolist (pkg remote-packages ) (delete-package pkg))) ) ) ;let ; DAB 10-31-89 ) ))