;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 123.238
;;; Reason:
;;;  (chaos:finger-lispms) had a few problems:
;;;    - Its process wait function was exactly backwards, causing it to loop for
;;;      5 seconds instead of sleeping, when waiting for slow Lispms to respond.
;;;    - When printing the names of Lisp Machines that did not respond, it chose
;;;      the third host-name to print (comment: "winning name").  I've never
;;;      heard that the 3rd name was special -- print the official name instead.
;;; Written 21-Apr-88 16:21:34 by pld at site Gigamos Cambridge
;;; while running on Azathoth from band 1
;;; with Experimental System 123.237, Experimental Local-File 73.4, Experimental FILE-Server 22.2, Experimental Unix-Interface 11.0, Experimental KERMIT 34.3, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, Experimental Tape 22.1, Experimental Site Data Editor 9.0, microcode 1755, SDU Boot Tape 3.14, SDU ROM 8, the old ones.



; From modified file DJ: L.NETWORK.CHAOS; CHSAUX.LISP#395 at 21-Apr-88 16:21:35
#8R CHAOS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "CHAOS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; CHAOS; CHSAUX  "

(DEFUN FINGER-LISPMS (&OPTIONAL
		      (STREAM *STANDARD-OUTPUT*) HOSTS (PRINT-FREE T) RETURN-FREE
		      (PRINT-INUSE T) (PRINT-DOWN T)
		      &AUX FREE DOWN ELEMS HOST)
  "Print brief information about who is logged in to each Lisp machine.
STREAM is where to print it.
PRINT-FREE not NIL says print also lists of free and nonresponding Lisp machines.
RETURN-FREE not NIL says return information about free and nonresponding machines;
 in this case, the first value is a list of host objects of free machines
 and the second a list of host objects of nonresponding ones.
HOSTS is the list of hosts to check, defaulting to all known Lisp machines.
HOSTS should be a list of already parsed hosts, or NIL."
  (IF (NULL HOSTS)
      (SETQ HOSTS (ALL-LOCAL-LISPMS)))
  (SETQ ELEMS (MAKE-FAST-CONNECTION-LIST HOSTS "FINGER" 1))
  (UNWIND-PROTECT
      ;; If number of machines gets large enough,
      ;; put in a hack like HOSTAT's, to go around later and try again
      ;; to connect to machines which we couldn't get the first time
      ;; due to connection table full.
      (DO ((OLD-TIME (TIME)))
	  (NIL)
	(DOLIST (ELEM ELEMS)
	  (LET* ((CONN (FCL-CONN1 ELEM))
		 (STATE (AND CONN (STATE CONN))))
	    (UNLESS (EQ STATE 'RFC-SENT-STATE)
	      ;; Got some reply for this one.
	      (WHEN (EQ STATE 'ANSWERED-STATE)	;Got something meaningful
		(LET* ((PKT (GET-NEXT-PKT CONN))
		       (STR (PKT-STRING PKT))
		       (HOST-NAME (send (FCL-HOST ELEM) :short-name))
		       (IDX))
		  (UNWIND-PROTECT
		      (COND ((NOT (MEMQ (CHAR STR 0) '(#/CR #/SP #/TAB)))	;Logged in
			     (WHEN PRINT-INUSE
			       (LET (USER (GROUP "") (NAME "") (IDLE "") (LOCATION ""))
				 (SETQ USER
				       (NSUBSTRING STR 0
						   (SETQ IDX (STRING-SEARCH-CHAR #/CR STR))))
				 (WHEN IDX
				   (SETQ LOCATION
					 (NSUBSTRING STR (1+ IDX)
						     (SETQ IDX (STRING-SEARCH-CHAR #/CR STR (1+ IDX))))))
				 
				 (WHEN IDX
				   (SETQ IDLE
					 (NSUBSTRING STR (1+ IDX)
						     (SETQ IDX (STRING-SEARCH-CHAR #/CR STR (1+ IDX))))))
				 (WHEN IDX
				   (SETQ NAME
					 (NSUBSTRING STR (1+ IDX)
						     (SETQ IDX (STRING-SEARCH-CHAR #/CR STR (1+ IDX))))))
				 (SETQ GROUP
				       (IF IDX (AREF STR (1+ IDX)) #/SP))
				 (FORMAT STREAM
					 "~&~10A ~C ~22A ~7A ~4@A    ~A~%"
					 USER GROUP NAME HOST-NAME IDLE LOCATION))))
			    ((OR PRINT-FREE RETURN-FREE)	;person CANNOT be logged in.
			     (PUSH (LIST HOST-NAME
					 (SUBSTRING STR 1	;Please don't search for the space!
						    (STRING-SEARCH-SET '(#/CR) STR 1)))
				   FREE)))
		    (RETURN-PKT PKT)))
		(SETQ ELEMS (DELQ ELEM ELEMS))
		(CLOSE-CONN CONN))
	      (AND CONN (REMOVE-CONN CONN)))))
	(OR ELEMS (RETURN NIL))
	(AND (> (TIME-DIFFERENCE (TIME) OLD-TIME) 240.)	;Allow 5 secs for this all
	     (RETURN NIL))			; someone can't tell time
	(PROCESS-WAIT "Finger Lispms"
		      #'(LAMBDA (OLD-TIME ELEMS)
			  (OR (> (TIME-DIFFERENCE (TIME) OLD-TIME) 240.)
			      (dolist (elem elems)
				(LET ((CONN (FCL-CONN1 ELEM)))
				  (AND CONN (neq (STATE CONN) 'RFC-SENT-STATE)
				       (RETURN T))))))
		      OLD-TIME ELEMS))
    ;; Flush all outstanding connections
    (SETQ DOWN (MAPCAR #'FCL-HOST ELEMS))
    (DOLIST (ELEM ELEMS)
      (LET ((CONN (FCL-CONN1 ELEM)))
	(AND CONN (REMOVE-CONN (FCL-CONN1 ELEM))))))
  ;; Print which machines responded that they are free.
  (AND PRINT-FREE
       (COND ((NULL FREE)
	      (FORMAT STREAM "~18@T ~2&No Free Lisp machines.~%"))
	     (T
	      (FORMAT STREAM "~18@T ~2&Free Lisp machines: ~2%")
	      (DOLIST (ENTRY FREE)
		(FORMAT:OSTRING (CAR ENTRY) 18.)
		(FORMAT STREAM "~A~&" (CADR ENTRY))))))
  ;; Print which machines did not respond.
  (AND PRINT-DOWN
       (COND ((NOT (NULL DOWN))
	      (FORMAT STREAM "~18@T ~2&Lisp machines not responding: ~2%")
	      (DOLIST (ENTRY DOWN)
		(SETQ HOST (send entry :name))
		(FORMAT:OSTRING HOST 18.)
		(FORMAT STREAM "~A~&" (LISPM-FINGER-INFO HOST))))))
  (AND RETURN-FREE
       (VALUES (MAPCAR 'CAR FREE) DOWN)))

))