;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.54
;;; Reason:
;;;  Add :eval type for forced keyboard input for peek-top-level.
;;;  "Addr-stat" operation on a network interface now uses this.
;;;  Allow "History" operation for FTP host unit.
;;; Written 16-Oct-87 14:04:33 by pld at site LMI Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.52, Experimental Local-File 73.0, Experimental FILE-Server 22.0, Experimental Unix-Interface 11.0, Experimental Tape 18.0, Experimental KERMIT 34.0, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, microcode 1754, SDU Boot Tape 3.12, SDU ROM 8.



; From modified file DJ: L.WINDOW; PEEK.LISP#199 at 16-Oct-87 13:59:46
#8R TV#: #!:ZL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TV")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: WINDOW; PEEK  "

(DEFUN PEEK-TOP-LEVEL (WINDOW MODE)
  (COND-EVERY
    ((AND MODE (SYMBOLP MODE)) (SETQ MODE (SYMBOL-NAME MODE)))
    ((STRINGP MODE) (SETQ MODE (CHAR MODE 0)))
    ((CHARACTERP MODE) (SETQ MODE (CHAR-INT MODE)))
;character lossage
    ((NUMBERP MODE) (SEND WINDOW :FORCE-KBD-INPUT MODE)))
  (BLOCK PEEK
    (DO-FOREVER
      (CATCH-ERROR-RESTART ((SYS:ABORT ERROR) "Return to PEEK command level.")
	(DO ((SLEEP-TIME PEEK-SLEEP-TIME)
	     (WAKEUP-TIME (TIME-DIFFERENCE (TIME) (- PEEK-SLEEP-TIME)))
	     (wakeup-time-passed nil)
	     (*TERMINAL-IO* (SEND WINDOW :TYPEOUT-WINDOW))
	     (ARG)
	     (CHAR))
	    (())
	  (when (or (TIME-LESSP WAKEUP-TIME (TIME)) wakeup-time-passed)
	    (SETQ WAKEUP-TIME (TIME-DIFFERENCE (TIME) (- SLEEP-TIME)))
	    (setq wakeup-time-passed nil))
	  (OR (= SLEEP-TIME 0)
	      (PROCESS-WAIT "Peek Timeout or TYI"
			    (LAMBDA (TIME FLAG-LOC STREAM PEEK-WINDOW)
				(if (SHEET-EXPOSED-P PEEK-WINDOW)
				    (OR wakeup-time-passed
					(TIME-LESSP TIME (TIME))
					(CONTENTS FLAG-LOC)
					(SEND STREAM :LISTEN))
				  ;;If sheet not exposed, notice when wakeup-time is passed
				  ;;If we don't do this and sheet is deexposed for a long time, peek
				  ;;stops redisplaying
				  (when (time-lessp time (time))
				    (setq wakeup-time-passed t)
				    nil)))
			    WAKEUP-TIME
			    (LOCATE-IN-INSTANCE WINDOW 'NEEDS-REDISPLAY)
			    *TERMINAL-IO*
			    (SEND WINDOW :ALIAS-FOR-SELECTED-WINDOWS)))
	  (DO ()
	      ((PROGN (PEEK-ASSURE-NO-TYPEOUT WINDOW)
		      (NULL (SETQ CHAR (SEND *TERMINAL-IO* :ANY-TYI-NO-HANG)))))
	    (COND-EVERY
	      ((CONSP CHAR)
	       ;; A special command (forced input, no doubt)
	       (CASE (CAR CHAR)
		 (SUPDUP (SUPDUP (CADR CHAR)))
		 (SUPDUP:TELNET (TELNET (CADR CHAR)))
		 (QSEND (QSEND (CADR CHAR))
			(SEND WINDOW :SET-NEEDS-REDISPLAY T)
			(SEND *TERMINAL-IO* :MAKE-COMPLETE))
		 (EH (EH (CADR CHAR)))
		 (INSPECT (INSPECT (CADR CHAR)))
		 (DESCRIBE (DESCRIBE (CADR CHAR)))
		 (:eval (eval (cadr char)))
		 (:MENU (SETQ CHAR (FIRST (THIRD (SECOND CHAR)))))
		 (:mouse-button
		  (mouse-call-system-menu))
		 (OTHERWISE (BEEP)))
	       (SETQ ARG NIL))
	      ((NUMBERP CHAR)
	       (SETQ CHAR (INT-CHAR CHAR)))
	      ((CHARACTERP CHAR)
	       ;; Standard character, either accumulate arg or select new mode
	       (SETQ CHAR (CHAR-UPCASE CHAR))
	       (IF (DIGIT-CHAR-P CHAR)
		   (SETQ ARG (+ (* 10. (OR ARG 0)) (DIGIT-CHAR-P CHAR)))
		 (IF (PEEK-SET-MODE WINDOW CHAR ARG)
		     (SETQ ARG NIL)
		   ;; Check for standard character assignments
		   (CASE CHAR
		     (#/HELP
		      (SEND *STANDARD-OUTPUT* :CLEAR-WINDOW)
		      (LET (INPUT)
			(SETQ INPUT (SEND *STANDARD-INPUT* :LISTEN))
			(UNLESS INPUT
			  (FORMAT T "The Peek program shows a continuously updating status display.
  There are several modes that display different status.
  Here is a list of modes.  Select a mode by typing the character
  or by clicking on the corresponding menu item.~2%"))
			(DOLIST (E *PEEK-DEFAULT-MODE-ALIST*)
			  (WHEN (OR INPUT (SETQ INPUT (SEND *STANDARD-INPUT* :LISTEN)))
			    (RETURN))
			  (FORMAT T "~:@C~5T~A~%~@[~6T~A~%~]"
				  (FIRST E) (THIRD E) (FIFTH E)))
			(UNLESS INPUT
			  (FORMAT T "~%Q~5TQuit.~%")
			  (FORMAT T "nZ~5TSets sleep time between updates to n seconds.~2%")
			  (FORMAT T "[Help]  Prints this message.~2%")))
		      (SETQ ARG NIL))
		     (#/Q
		      (RETURN-FROM PEEK NIL))
		     (#/Z
		      (AND ARG (SETQ SLEEP-TIME (* 60. ARG)))
		      (SEND WINDOW :SET-NEEDS-REDISPLAY T)
		      (SETQ ARG NIL))
		     (#/SPACE (SEND WINDOW :SET-NEEDS-REDISPLAY T))
		     (OTHERWISE (BEEP))))))))
	  (WHEN (OR (SEND WINDOW :NEEDS-REDISPLAY) (TIME-LESSP WAKEUP-TIME (TIME)))
	    ;; We want to redisplay.  If have typeout, hang until user confirms.
	    (SEND WINDOW :SET-NEEDS-REDISPLAY NIL)
	    (SEND WINDOW :REDISPLAY)))))))

))

; From modified file DJ: L.NETWORK.KERNEL; NETSTAT.LISP#100 at 16-Oct-87 13:59:52
#10R NETWORK#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "NETWORK")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; KERNEL; NETSTAT  "

(defun peek-network-interface (ni)
  "Format is:

Network interface <tag> is a <interface> interface to a <keyword> network on address <address>.
<enabled state>, protocols <protocol list>
Packets: <n> sent <n> rcvd <n> sdisc <n> rdisc <n> looped
Bytes: <n> sent <n> rcvd <n> sdisc <n> rdisc <n> looped
"
  (list `( :PRE-PROCESS-FUNCTION peek-network-insert-ni-special-fields
	   :interface ,ni)
	(tv:scroll-parse-item
	  `(:MOUSE-ITEM
	     (NIL :MENU-CHOOSE
		  ("Network Interface Operations"
		   ("Close" :EVAL  (when (tv:mouse-y-or-n-p "Close this network interface")
				     (funcall ni :close))
		    :DOCUMENTATION
		    "Click left to close this network interface.")
		   ("Reset" :EVAL  (when (tv:mouse-y-or-n-p "Reset this network interface")
				     (funcall ni :reset))
		    :DOCUMENTATION
		    "Click left to reset this network interface.")
		   ("Inspect" :EVAL (send tv:selected-window :force-kbd-input `(inspect ,ni))
		    :DOCUMENTATION
		    "Click left to INSPECT this network interface.")
		  ("Describe" :EVAL (send tv:selected-window :force-kbd-input `(describe ,ni))
		    :DOCUMENTATION
		    "Click left to DESCRIBE this network interface.")
		  ("Addr-Stat" :EVAL (send tv:selected-window :force-kbd-input `(:eval (arp:addr-stat ,ni)))
		    :DOCUMENTATION
		    "Click left to list address translation table for this interface"))
		  :DOCUMENTATION
		  "Menu of things to do to this network interface."
		  :BINDINGS
		  ((ni ',ni)))
	     :FUNCTION ni-tag (,ni) NIL ("Network Interface ~S:"))
	  `(:function ni-interface (,ni) NIL (" ~A interface"))
	  `(:function ni-keyword (,ni) NIL (" to ~A network"))
	  `(:function ni-address (,ni) NIL (" on address ~X")))
	(tv:scroll-parse-item
	  `(:function ni-sent-header-length (,ni) NIL ("Header (S/R): ~D"))
	  `(:function ni-rcvd-header-length (,ni) NIL ("/~D"))
	  `(:function ni-sent-trailer-length (,ni) NIL (" trailer (S/R): ~D"))
	  `(:function ni-rcvd-trailer-length (,ni) NIL ("/~D"))
	  `(:function ni-minimum-data-length (,ni) NIL (" data length: ~D"))
	  `(:function ni-maximum-data-length (,ni) NIL ("-~D, "))
	  `(:mouse-item
	     (nil :buttons
		  ,(make-list 3 :initial-element
			      `(nil :eval (setf (ni-loopback ni) (not (ni-loopback ni)))
				    :bindings ((ni ',ni))))
		  :DOCUMENTATION
		  "Click to toggle software loopback"
		  :BINDINGS
		  ((ni ',ni)))
	     :function ni-loopback (,ni) NIL ("loopback: ~A"))
	  `(:function ni-allocation-failures (,ni) NIL (", alloc failed ~D")))
	(tv:scroll-parse-item
	  `(:mouse-item
	     (nil :buttons
		  ,(make-list 3 :initial-element
			      `(nil :eval (funcall ni (if (ni-enabled ni) :disable :enable))
				    :bindings ((ni ',ni))))
		  :DOCUMENTATION
		  "Click to toggle state of interface"
		  :BINDINGS
		  ((ni ',ni)))
	     :function ni-enabled (,ni) NIL ("~:[Dis~;En~]abled"))
	  `(:function ,#'(lambda (ni)
			  (loop for elt in (ni-network-alist ni)
				collect (car elt)))
		      (,ni) NIL (" on protocols: ~A"))
	  `(:function ni-protocols-not-understood (,ni) NIL (", not understood: ~A,  "))
	  `(:mouse-item
	     (nil :buttons
		  ((nil :eval (funcall ni (if (ni-active-gauges ni) :kill-gauges :make-gauges))
			:bindings ((ni ',ni)))
		   (nil :eval (ignore))
		   (nil :eval (gauge-menu ni (ni-active-gauges ni))
			:bindings ((ni ',ni))))
		  :documentation
		  "Click left for default, right for menu"
		  ((ni ',ni)))
	     :function ,#'(lambda (n) (mapcar 'car (ni-active-gauges n))) (,ni) NIL ("Gauges: ~A")))
	(sent-statistics (ni-statistics-block ni) "")
	(rcvd-statistics (ni-statistics-block ni) "")
	(TV:SCROLL-PARSE-ITEM
	  `(:function ni-packets-sent-discarded (,ni) NIL ("Packets sent/disc ~D"))
	  `(:function ni-packets-received-discarded (,ni) NIL (" rcvd/disc ~D"))
	  `(:function ni-bytes-sent-discarded (,ni) NIL (" Bytes sent/disc ~D"))
	  `(:function ni-bytes-received-discarded (,ni) NIL (" rcvd/disc ~D")))
	(TV:SCROLL-PARSE-ITEM
	  :leader 1				;to indicate whether special fields inserted
	  "")
	))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#20 at 16-Oct-87 14:02:54
#10R FILE-SYSTEM#: #!:ZL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  "

(defun peek-ftp-host-unit (unit &optional (indent 2))
  "Generate a scroll item describing a host unit"
  (list ()
    (tv:scroll-parse-item ':mouse
			  `(nil :menu-choose
				("Host-unit operations"
				 ("Reset" :eval (funcall thisunit ':reset)
				  :documentation
				  "Click left to close this connection")
				 ("History" :eval (send tv:selected-window :force-kbd-input `(:eval (ftp-history ,thisunit)))
				  :documentation
				  "Show command history for this unit")
				 ("Inspect" :eval (send tv:selected-window :force-kbd-input `(inspect ,thisunit))
				  :documentation
				  "Click left to INSPECT this host-unit.")
				 ("Describe" :eval (send tv:selected-window :force-kbd-input `(describe ,thisunit))
				  :documentation
				  "Click left to DESCRIBE this host-unit."))
				:documentation
				"Menu of things to do to this host-unit."
				:bindings
				((thisunit ',unit)
				 (typwin ',(funcall self ':typeout-window))))
			  (format nil "~V@THost unit for ~A"
				  indent (send unit :host))
			  `(:FUNCTION ,#'(LAMBDA (UNIT)
					   (format nil
						   " with ~:[closed~;open~] control connection"
						   (symeval-in-instance unit 'ftp:*cin*)))
				      (,UNIT)))))

))