(FILECREATED "17-NOV-83 14:54:12" {PHYLUM}<LISPCORE>SOURCES>COURIER.;14 55336  

      changes to:  (VARS COURIERCOMS)
		   (FNS CH.ADD.USER CH.LOOKUP CH.ENUMERATE CH.SERVERS CH.ORGANIZATIONS CH.DOMAINS 
			CH.DOMAINS.SERVED CH.FINDSERVER NSPRINTREQUEST.STATUS NSPRINTER.PROPERTIES 
			NSPRINTER.STATUS OPEN.NS.PRINTING.STREAM NSPRINT.WATCHDOG)

      previous date: " 3-NOV-83 22:51:58" {PHYLUM}<LISPCORE>SOURCES>COURIER.;10)


(* Copyright (c) 1983 by Xerox Corporation)

(PRETTYCOMPRINT COURIERCOMS)

(RPAQQ COURIERCOMS ((COMS (DECLARE: DONTCOPY EVAL@COMPILE (FILES (LOADCOMP)
								 SPP)))
	(COMS (* Authentication Protocol.)
	      (COURIERPROGRAMS AUTHENTICATION)
	      (DECLARE: DONTCOPY (CONSTANTS (\AUTHENTICATION.SIMPLE.CREDENTIALS 0)))
	      (FNS HASH.PASSWORD NSLOGIN))
	(COMS (* Printing Protocol.)
	      (COURIERPROGRAMS PRINTING)
	      (DECLARE: DONTCOPY (GLOBALVARS NS.DEFAULT.PRINTER)
			(RECORDS NSPRINTINGSTREAM))
	      (INITVARS (NS.DEFAULT.PRINTER NIL))
	      (FNS GETNSPRINTER NSPRINT IP.SENDTOPRINTER NSPRINT.WATCHDOG \NSPRINT.WATCHDOG.INTERNAL 
		   OPEN.NS.PRINTING.STREAM NSPRINTER.STATUS NSPRINTER.PROPERTIES 
		   NSPRINTREQUEST.STATUS))
	(COMS (* Clearinghouse Protocol.)
	      (COURIERPROGRAMS CLEARINGHOUSE)
	      (DECLARE: DONTCOPY (CONSTANTS [\CH.NULL.AUTHENTICATOR (QUOTE ((CREDENTIALS
									      ((TYPE 0)
									       (VALUE NIL)))
									    (VERIFIER (0]
					    [CH.PROPERTYIDS (QUOTE ((ALL 0)
								    (CLEARINGHOUSE.NAMES 3)
								    (CLEARINGHOUSE.ADDRESSES 4)
								    (FILESERVER 10)
								    (PRINTSERVER 11)
								    (IRS 12)
								    (USER 14)
								    (MAILSERVER 15)
								    (WORKSTATION 17)
								    (ECS 20)
								    (ITS 23]
					    (\CH.BROADCAST.TYPE 2)
					    (\CH.BROADCAST.SOCKET 20)
					    (\BROADCAST.FOR.SERVERS.LENGTH 22))
			(RECORDS \BROADCAST.FOR.SERVERS.PACKET)
			(GLOBALVARS LOCAL.CLEARINGHOUSE \CH.CACHE CH.DEFAULT.DOMAIN 
				    CH.DEFAULT.ORGANIZATION))
	      (INITVARS (CH.DEFAULT.DOMAIN NIL)
			(CH.DEFAULT.ORGANIZATION NIL)
			(LOCAL.CLEARINGHOUSE NIL)
			(\CH.CACHE NIL)
			(CLEARINGHOUSE.STRUCTURE.WINDOW NIL)
			(NS.SERVER.NAMES.TO.ADDRESSES NIL))
	      (ADDVARS (\SYSTEMCACHEVARS LOCAL.CLEARINGHOUSE \CH.CACHE NS.SERVER.NAMES.TO.ADDRESSES))
	      (FNS GETCLEARINGHOUSE START.CLEARINGHOUSE SHOW.CLEARINGHOUSE CH.FINDSERVER 
		   \CH.UPDATE.CACHE EQUAL.CH.NAMES MATCHING.CH.NAMES STREQUAL.EXCEPT.FOR.CASE 
		   CH.DOMAINS.SERVED CH.DOMAINS CH.ORGANIZATIONS CH.SERVERS CH.BROADCAST.FOR.SERVERS 
		   \CH.BROADCAST.FOR.SERVERS.ON.NET \CH.READ.BROADCAST.RESPONSE PARSE.CH.NAME 
		   CH.NAME.TO.STRING CANONICAL.CH.NAME \CH.CHECK.WILDCARD CH.PROPERTY 
		   \CH.GUESS.NEW.PROPERTIES CH.NSADDRESS CH.GETAUTHENTICATOR CH.ENUMERATE CH.LOOKUP 
		   LOOKUP.NS.SERVER CH.LOOKUP.USER CH.ADD.USER))))
(DECLARE: DONTCOPY EVAL@COMPILE 
(FILESLOAD (LOADCOMP)
	   SPP)
)



(* Authentication Protocol.)


(COURIERPROGRAM AUTHENTICATION (14 1)
    TYPES
      [(CREDENTIALS.TYPE CARDINAL)
       [CREDENTIALS (RECORD (TYPE CREDENTIALS.TYPE)
			    (VALUE (SEQUENCE UNSPECIFIED]
       (SIMPLE.CREDENTIALS (CLEARINGHOUSE . NAME))
       (VERIFIER (SEQUENCE UNSPECIFIED))
       (SIMPLE.VERIFIER HASHED.PASSWORD)
       (HASHED.PASSWORD CARDINAL)
       (PROBLEM (ENUMERATION (CREDENTIALS.INVALID 0)
			     (VERIFIER.INVALID 1])
(DECLARE: DONTCOPY 
(DECLARE: EVAL@COMPILE 

(RPAQQ \AUTHENTICATION.SIMPLE.CREDENTIALS 0)

(CONSTANTS (\AUTHENTICATION.SIMPLE.CREDENTIALS 0))
)
)
(DEFINEQ

(HASH.PASSWORD
  [LAMBDA (PASSWORD)                                         (* bvm: " 3-NOV-83 22:35")

          (* Compute remainder mod 65357 of PASSWORD considered as an arbitrary length integer whose 16 bit words, from most
	  to least significant, are the characters in PASSWORD. Uses Horner's rule and properties of modular arithmetic to 
	  do it efficiently.)


    (bind (HASH ← 0) for CHAR instring (MKSTRING PASSWORD)
       do (SETQ HASH (IMOD (IPLUS (ITIMES HASH (CONSTANT (IMOD (EXPT 2 16)
							       65357)))
				  (L-CASECODE (\DECRYPT.PWD.CHAR CHAR)))
			   65357))
       finally (RETURN HASH])

(NSLOGIN
  [LAMBDA (HOST MSG)                                         (* ecc "16-AUG-83 15:51")
    (PROG (INFO NAME/PASSWORD)
          (SETQ HOST (MKATOM (CH.NAME.TO.STRING HOST T)))
          (SETQ INFO (GETHASH HOST LOGINPASSWORDS))
          (if (OR MSG (NULL INFO))
	      then (SETQ NAME/PASSWORD (\INTERNAL/GETPASSWORD HOST T NIL MSG))
	    else (SETQ NAME/PASSWORD (CAR INFO)))
          (RETURN NAME/PASSWORD])
)



(* Printing Protocol.)


(COURIERPROGRAM PRINTING (4 3)
    TYPES
      [(REQUEST.ID (ARRAY 5 UNSPECIFIED))
       [PRINT.ATTRIBUTES (SEQUENCE (CHOICE (PRINT.OBJECT.NAME 0 STRING)
					   (PRINT.OBJECT.CREATE.DATE 1 TIME)
					   (SENDER.NAME 2 STRING]
       [PRINT.OPTIONS (SEQUENCE (CHOICE (PRINT.OBJECT.SIZE 0 LONGCARDINAL)
					(RECIPIENT.NAME 1 STRING)
					(MESSAGE 2 STRING)
					(COPY.COUNT 3 CARDINAL)
					(PAGES.TO.PRINT 4 (RECORD (BEGINNING.PAGE.NUMBER CARDINAL)
								  (ENDING.PAGE.NUMBER CARDINAL)))
					(MEDIUM.HINT 5 MEDIUM)
					(PRIORITY.HINT 6 (ENUMERATION (HOLD 0)
								      (LOW 1)
								      (NORMAL 2)
								      (HIGH 3)))
					(RELEASE.KEY 7 HASHED.PASSWORD)
					(STAPLE 8 BOOLEAN)
					(TWO.SIDED 9 BOOLEAN]
       [PRINTER.PROPERTIES (SEQUENCE (CHOICE (MEDIA 0 MEDIA)
					     (STAPLE 1 BOOLEAN)
					     (TWO.SIDED 2 BOOLEAN]
       [PRINTER.STATUS (SEQUENCE (CHOICE (SPOOLER 0 (ENUMERATION (AVAILABLE 0)
								 (BUSY 1)
								 (DISABLED 2)
								 (FULL 3)))
					 (FORMATTER 1 (ENUMERATION (AVAILABLE 0)
								   (BUSY 1)
								   (DISABLED 2)))
					 (PRINTER 2 (ENUMERATION (AVAILABLE 0)
								 (BUSY 1)
								 (DISABLED 2)
								 (NEEDS.ATTENTION 3)
								 (NEED.KEY.OPERATOR 4)))
					 (MEDIA 3 MEDIA]
       (MEDIA (SEQUENCE MEDIUM))
       (MEDIUM (CHOICE (PAPER 0 PAPER)))
       [PAPER (CHOICE (UNKNOWN 0 NIL)
		      (KNOWN.SIZE 1 (ENUMERATION (US.LETTER 1)
						 (US.LEGAL 2)
						 (A0 3)
						 (A1 4)
						 (A2 5)
						 (A3 6)
						 (A4 7)
						 (A5 8)
						 (A6 9)
						 (A7 10)
						 (A8 11)
						 (A9 12)
						 (A10 35)
						 (ISO.B0 13)
						 (ISO.B1 14)
						 (ISO.B2 15)
						 (ISO.B3 16)
						 (ISO.B4 17)
						 (ISO.B5 18)
						 (ISO.B6 19)
						 (ISO.B7 20)
						 (ISO.B8 21)
						 (ISO.B9 22)
						 (ISO.B10 23)
						 (JIS.B0 24)
						 (JIS.B1 25)
						 (JIS.B2 26)
						 (JIS.B3 27)
						 (JIS.B4 28)
						 (JIS.B5 29)
						 (JIS.B6 30)
						 (JIS.B7 31)
						 (JIS.B8 32)
						 (JIS.B9 33)
						 (JIS.B10 34)))
		      (OTHER.SIZE 2 (RECORD (WIDTH CARDINAL)
					    (LENGTH CARDINAL]
       [REQUEST.STATUS (SEQUENCE (CHOICE (STATUS 0 (ENUMERATION (PENDING 0)
								(IN.PROGRESS 1)
								(COMPLETED 2)
								(UNKNOWN 3)
								(REJECTED 4)
								(ABORTED 5)
								(CANCELLED 6)
								(HELD 7)))
					 (STATUS.MESSAGE 1 STRING]
       (CONNECTION.PROBLEM (ENUMERATION (NO.ROUTE 0)
					(NO.RESPONSE 1)
					(TRANSMISSION.HARDWARE 2)
					(TRANSPORT.TIMEOUT 3)
					(TOO.MANY.LOCAL.CONNECTIONS 4)
					(TOO.MANY.REMOTE.CONNECTIONS 5)
					(MISSING.COURIER 6)
					(MISSING.PROGRAM 6)
					(MISSING.PROCEDURE 7)
					(PROTOCOL.MISMATCH 9)
					(PARAMETER.INCONSISTENCY 10)
					(INVALID.MESSAGE 11)
					(RETURN.TIMED.OUT 12)
					(OTHER.CALL.PROBLEM -1)))
       (TRANSFER.PROBLEM (ENUMERATION (ABORTED 0)
				      (FORMAT.INCORRECT 2)
				      (NO.RENDEZVOUS 3)
				      (WRONG.DIRECTION 4]
    PROCEDURES
      ((PRINT ARGS (BULK.DATA.SOURCE PRINT.ATTRIBUTES PRINT.OPTIONS)
	      RESULTS
	      (REQUEST.ID)
	      ERRORS
	      (BUSY CONNECTION.ERROR INSUFFICIENT.SPOOL.SPACE INVALID.PRINT.PARAMETERS 
		    MASTER.TOO.LARGE MEDIUM.UNAVAILABLE SERVICE.UNAVAILABLE SPOOLING.DISABLED 
		    SPOOLING.QUEUE.FULL SYSTEM.ERROR TOO.MANY.CLIENTS TRANSFER.ERROR UNDEFINED.ERROR)
	      0)
       (GET.PRINTER.PROPERTIES RESULTS (PRINTER.PROPERTIES)
			       ERRORS
			       (SERVICE.UNAVAILABLE SYSTEM.ERROR UNDEFINED.ERROR)
			       1)
       (GET.PRINT.REQUEST.STATUS ARGS (REQUEST.ID)
				 RESULTS
				 (REQUEST.STATUS)
				 ERRORS
				 (SERVICE.UNAVAILABLE SYSTEM.ERROR UNDEFINED.ERROR)
				 2)
       (GET.PRINTER.STATUS RESULTS (PRINTER.STATUS)
			   ERRORS
			   (SERVICE.UNAVAILABLE SYSTEM.ERROR UNDEFINED.ERROR)
			   3))
    ERRORS
      ((BUSY 0)
       (CONNECTION.ERROR ERROR ARGS (CONNECTION.PROBLEM)
			 11)
       (INSUFFICIENT.SPOOL.SPACE 1)
       (INVALID.PRINT.PARAMETERS 2)
       (MASTER.TOO.LARGE 3)
       (MEDIUM.UNAVAILABLE 4)
       (SERVICE.UNAVAILABLE 5)
       (SPOOLING.DISABLED 6)
       (SPOOLING.QUEUE.FULL 7)
       (SYSTEM.ERROR 8)
       (TOO.MANY.CLIENTS 9)
       (TRANSFER.ERROR ARGS (TRANSFER.PROBLEM)
		       12)
       (UNDEFINED.ERROR ARGS (CARDINAL)
			10)))
(DECLARE: DONTCOPY 
(DECLARE: DOEVAL@COMPILE DONTCOPY

(ADDTOVAR GLOBALVARS NS.DEFAULT.PRINTER)
)

[DECLARE: EVAL@COMPILE 

(ACCESSFNS NSPRINTINGSTREAM ((NSPRINTING.ATTRIBUTES (fetch F3 of DATUM)
						    (replace F3 of DATUM with NEWVALUE))))
]
)

(RPAQ? NS.DEFAULT.PRINTER NIL)
(DEFINEQ

(GETNSPRINTER
  [LAMBDA (HOSTNAME)                                         (* ecc "28-JUN-83 10:29")
    (COND
      (HOSTNAME)
      (NS.DEFAULT.PRINTER)
      ([SETQ NS.DEFAULT.PRINTER (CAR (CH.ENUMERATE "*" (QUOTE PRINTSERVER]
	(printout PROMPTWINDOW .TAB0 0 "[Default NS printer set to " NS.DEFAULT.PRINTER "]")
	NS.DEFAULT.PRINTER)
      (T (ERROR "Can't find an NS printserver" NIL T])

(NSPRINT
  [LAMBDA (PRINTERNAME FILE OPTIONS)                         (* lmm " 3-OCT-83 18:11")
    (PROG (FULLFILENAME COURIERSTREAM PRINTINGSTREAM)
          (if (NULL (SETQ FULLFILENAME (INFILEP FILE)))
	      then (LISPERROR "FILE NOT FOUND" FILE))
          (RETURN (COND
		    ([SETQ PRINTINGSTREAM (OPEN.NS.PRINTING.STREAM PRINTERNAME
								   (OR (LISTGET OPTIONS (QUOTE 
										    DOCUMENT.NAME))
								       FULLFILENAME)
								   (OR (LISTGET OPTIONS (QUOTE 
									   DOCUMENT.CREATION.DATE))
								       (GETFILEINFO FULLFILENAME
										    (QUOTE 
										    ICREATIONDATE)))
								   (LISTGET OPTIONS (QUOTE 
										      SENDER.NAME))
								   (LISTGET OPTIONS (QUOTE 
										    RECIPENT.NAME))
								   (LISTGET OPTIONS (QUOTE #COPIES))
								   (LISTGET OPTIONS (QUOTE MEDIUM))
								   (LISTGET OPTIONS (QUOTE PRIORITY))
								   (LISTGET OPTIONS (QUOTE STAPLE?))
								   (EQ 2 (OR (LISTGET OPTIONS
										      (QUOTE #SIDES))
									     EMPRESS#SIDES]
		      (RESETLST (RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
						     PRINTINGSTREAM))
				(RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
						     FULLFILENAME))
				(COPYBYTES (OPENSTREAM FULLFILENAME (QUOTE INPUT))
					   PRINTINGSTREAM))
		      FULLFILENAME])

(IP.SENDTOPRINTER
  [LAMBDA (HOST FILE #COPIES #SIDES DOCUMENT.NAME DOCUMENT.CREATION.DATE SENDER.NAME RECIPIENT.NAME 
		MEDIUM PRIORITY STAPLE?)                     (* lmm "12-JUN-83 01:55")
    (NSPRINT HOST FILE DOCUMENT.NAME DOCUMENT.CREATION.DATE SENDER.NAME RECIPIENT.NAME #COPIES MEDIUM 
	     PRIORITY STAPLE?])

(NSPRINT.WATCHDOG
  [LAMBDA (SUBSTREAM ID)                                     (* bvm: "16-NOV-83 15:28")
    (PROG [[PRINTER (CADR (ASSOC (QUOTE PRINTSERVER)
				 (fetch NSPRINTING.ATTRIBUTES of SUBSTREAM]
	   (JOBNAME (CADR (ASSOC (QUOTE DOCUMENT)
				 (fetch NSPRINTING.ATTRIBUTES of SUBSTREAM]
          (ADD.PROCESS (LIST (FUNCTION \NSPRINT.WATCHDOG.INTERNAL)
			     (KWOTE ID)
			     (KWOTE PRINTER)
			     (KWOTE JOBNAME))
		       (QUOTE NAME)
		       (PACK* (OR (ROOTFILENAME JOBNAME)
				  JOBNAME)
			      " Watchdog"])

(\NSPRINT.WATCHDOG.INTERNAL
  [LAMBDA (ID PRINTER JOBNAME)                               (* ecc "23-AUG-83 16:09")
    (bind (RESULT STATUS MSG)
       do (SETQ RESULT (NSPRINTREQUEST.STATUS ID PRINTER))
	  (SETQ STATUS (CADR (ASSOC (QUOTE STATUS)
				    RESULT)))
	  (SETQ MSG (CADR (ASSOC (QUOTE STATUS.MESSAGE)
				 RESULT)))
	  (printout PROMPTWINDOW .TAB0 0)
	  (if JOBNAME
	      then (printout PROMPTWINDOW JOBNAME " on "))
	  (printout PROMPTWINDOW PRINTER ": " STATUS)
	  (if (AND MSG (NOT (STREQUAL MSG "")))
	      then (printout PROMPTWINDOW " (" MSG ")"))
	  (if (MEMBER STATUS (QUOTE (PENDING IN.PROGRESS)))
	      then (BLOCK 30000)
	    else (RETURN])

(OPEN.NS.PRINTING.STREAM
  [LAMBDA (PRINTER DOCUMENT.NAME DOCUMENT.CREATION.DATE SENDER.NAME RECIPIENT.NAME #COPIES MEDIUM 
		   PRIORITY STAPLE? TWO.SIDED? NOWATCHDOG?)
                                                             (* bvm: "16-NOV-83 15:10")
                                                             (* Return a stream for Interpress printing.)
    (PROG (COURIERSTREAM PROPERTIES STATUS ATTRIBUTES OPTIONS)
          [COND
	    ((NULL DOCUMENT.CREATION.DATE)
	      (SETQ DOCUMENT.CREATION.DATE (IDATE]
          [COND
	    ((NULL SENDER.NAME)
	      (SETQ SENDER.NAME (USERNAME NIL NIL T]
          (COND
	    ((NULL RECIPIENT.NAME)
	      (SETQ RECIPIENT.NAME SENDER.NAME)))
          (COND
	    ((NULL #COPIES)
	      (SETQ #COPIES 1)))
          [COND
	    ((NULL PRIORITY)
	      (SETQ PRIORITY (QUOTE NORMAL]
          (SETQ PRINTER (GETNSPRINTER PRINTER))
          (SETQ COURIERSTREAM (COURIER.OPEN PRINTER (QUOTE PRINTSERVER)
					    NIL
					    (PACK* (CH.NAME.TO.STRING PRINTER)
						   " Printing")))
          (RETURN (COND
		    (COURIERSTREAM (RESETLST (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE)
								  COURIERSTREAM))
					     [COND
					       ((OR MEDIUM STAPLE? TWO.SIDED?)
                                                             (* Check that the printer supports these options.)
						 (SETQ PROPERTIES (COURIER.CALL COURIERSTREAM
										(QUOTE PRINTING)
										(QUOTE 
									   GET.PRINTER.PROPERTIES)))
						 (COND
						   ([AND MEDIUM
							 (NOT (MEMBER MEDIUM
								      (CADR (ASSOC (QUOTE MEDIA)
										   PROPERTIES]
						     (ERROR "Printer does not support medium" 
							    PROPERTIES T)))
						 (COND
						   ([AND STAPLE? (NOT (CADR (ASSOC (QUOTE STAPLE)
										   PROPERTIES]
						     (ERROR "Printer does not support stapled copies" 
							    PROPERTIES T)))
						 (COND
						   ([AND TWO.SIDED?
							 (NOT (CADR (ASSOC (QUOTE TWO.SIDED)
									   PROPERTIES]
						     (ERROR 
						      "Printer does not support two-sided copies"
							    PROPERTIES T]
                                                             (* Check the status of the printer.)
					     (do [SETQ STATUS (CADR (ASSOC (QUOTE SPOOLER)
									   (COURIER.CALL
									     COURIERSTREAM
									     (QUOTE PRINTING)
									     (QUOTE 
									       GET.PRINTER.STATUS]
						 (COND
						   ((EQ STATUS (QUOTE AVAILABLE))
						     (RETURN)))
						 (COND
						   ((NEQ STATUS (QUOTE BUSY))
						     (ERROR "Printer spooler" STATUS T)))
						 (printout PROMPTWINDOW .TAB0 0 
							   "[Spooler busy; will retry]")
						 (BLOCK 5000))
					     [SETQ ATTRIBUTES (BQUOTE ((PRINT.OBJECT.NAME , 
										    DOCUMENT.NAME)
								       (PRINT.OBJECT.CREATE.DATE
									 , DOCUMENT.CREATION.DATE)
								       (SENDER.NAME , SENDER.NAME]
					     [SETQ OPTIONS (BQUOTE ((RECIPIENT.NAME , RECIPIENT.NAME)
								    (COPY.COUNT , #COPIES)
								    (PRIORITY.HINT , PRIORITY)
								    (STAPLE , STAPLE?)
								    (TWO.SIDED , TWO.SIDED?]
					     [COND
					       (MEDIUM       (* We've already checked that the printer supports this 
							     medium.)
						       (SETQ OPTIONS (CONS (BQUOTE (MEDIUM.HINT
										     , MEDIUM))
									   OPTIONS]
					     (SETQ PRINTINGSTREAM
					       (COURIER.CALL COURIERSTREAM (QUOTE PRINTING)
							     (QUOTE PRINT)
							     (COND
							       (NOWATCHDOG? NIL)
							       (T (FUNCTION NSPRINT.WATCHDOG)))
							     ATTRIBUTES OPTIONS))
					     [replace NSPRINTING.ATTRIBUTES of PRINTINGSTREAM
						with (BQUOTE ((PRINTSERVER , PRINTER)
							      (DOCUMENT , DOCUMENT.NAME]
					     PRINTINGSTREAM])

(NSPRINTER.STATUS
  [LAMBDA (PRINTER)                                          (* bvm: "16-NOV-83 15:09")
    (PROG (STREAM)
          (SETQ PRINTER (GETNSPRINTER PRINTER))
          (SETQ STREAM (COURIER.OPEN PRINTER (QUOTE PRINTSERVER)
				     NIL
				     (PACK* (CH.NAME.TO.STRING PRINTER)
					    " Printing")))
          (RETURN (COND
		    (STREAM (RESETLST (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE)
							   STREAM))
				      (COURIER.CALL STREAM (QUOTE PRINTING)
						    (QUOTE GET.PRINTER.STATUS])

(NSPRINTER.PROPERTIES
  [LAMBDA (PRINTER)                                          (* bvm: "16-NOV-83 15:09")
    (PROG (STREAM)
          (SETQ PRINTER (GETNSPRINTER PRINTER))
          (SETQ STREAM (COURIER.OPEN PRINTER (QUOTE PRINTSERVER)
				     NIL
				     (PACK* (CH.NAME.TO.STRING PRINTER)
					    " Printing")))
          (RETURN (COND
		    (STREAM (RESETLST (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE)
							   STREAM))
				      (COURIER.CALL STREAM (QUOTE PRINTING)
						    (QUOTE GET.PRINTER.PROPERTIES])

(NSPRINTREQUEST.STATUS
  [LAMBDA (REQUESTID PRINTERHOST)                            (* bvm: "16-NOV-83 15:09")
    (PROG (STREAM)
          (SETQ PRINTER (GETNSPRINTER PRINTER))
          (SETQ STREAM (COURIER.OPEN PRINTER (QUOTE PRINTSERVER)
				     NIL
				     (PACK* (CH.NAME.TO.STRING PRINTER)
					    " Printing")))
          (RETURN (COND
		    (STREAM (RESETLST (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE)
							   STREAM))
				      (COURIER.CALL STREAM (QUOTE PRINTING)
						    (QUOTE GET.PRINT.REQUEST.STATUS)
						    REQUESTID])
)



(* Clearinghouse Protocol.)


(COURIERPROGRAM CLEARINGHOUSE (2 2)
    TYPES
      [(ORGANIZATION STRING)
       (DOMAIN STRING)
       (OBJECT STRING)
       (ORGANIZATION.NAME ORGANIZATION)
       (TWO.PART.NAME (RECORD (ORGANIZATION ORGANIZATION)
			      (DOMAIN DOMAIN)))
       (DOMAIN.NAME TWO.PART.NAME)
       (THREE.PART.NAME (RECORD (ORGANIZATION ORGANIZATION)
				(DOMAIN DOMAIN)
				(OBJECT OBJECT)))
       (OBJECT.NAME THREE.PART.NAME)
       (NAME THREE.PART.NAME)
       (ORGANIZATION.NAME.PATTERN ORGANIZATION)
       (DOMAIN.NAME.PATTERN TWO.PART.NAME)
       (OBJECT.NAME.PATTERN THREE.PART.NAME)
       (PROPERTY LONGCARDINAL)
       (PROPERTIES (SEQUENCE PROPERTY))
       (ITEM (SEQUENCE UNSPECIFIED))
       (NETWORK.ADDRESS (RECORD (NETWORK (ARRAY 2 UNSPECIFIED))
				(HOST (ARRAY 3 UNSPECIFIED))
				(SOCKET UNSPECIFIED)))
       (NETWORK.ADDRESS.LIST (SEQUENCE NETWORK.ADDRESS))
       [AUTHENTICATOR (RECORD (CREDENTIALS (AUTHENTICATION . CREDENTIALS))
			      (VERIFIER (AUTHENTICATION . VERIFIER]
       (USER.ENTRY (RECORD (LAST.NAME.INDEX CARDINAL)
			   (PASSWORD STRING)
			   (SYSTEM.ADMINISTRATOR BOOLEAN)
			   (FILESERVER OBJECT.NAME)
			   (MAILSERVER OBJECT.NAME)
			   (DESCRIPTION STRING)
			   (PRODUCT STRING)
			   (TRAINING STRING)
			   (HELP UNSPECIFIED)))
       (WHICH.ARGUMENT (ENUMERATION (FIRST 1)
				    (SECOND 2)))
       (ARGUMENT.PROBLEM (ENUMERATION (ILLEGAL.PROPERTY 10)
				      (ILLEGAL.ORGANIZATION.NAME 11)
				      (ILLEGAL.DOMAIN.NAME 12)
				      (ILLEGAL.OBJECT.NAME 13)
				      (NO.SUCH.ORGANIZATION 14)
				      (NO.SUCH.DOMAIN 15)
				      (NO.SUCH.OBJECT 16)))
       (CALL.PROBLEM (ENUMERATION (ACCESS.RIGHTS.INSUFFICIENT 1)
				  (TOO.BUSY 2)
				  (SERVER.DOWN 3)
				  (USE.COURIER 4)
				  (OTHER 5)))
       (PROPERTY.PROBLEM (ENUMERATION (MISSING 20)
				      (WRONG.TYPE 21)))
       (UPDATE.PROBLEM (ENUMERATION (NO.CHANGE 30)
				    (OUT.OF.DATE 31)
				    (OBJECT.OVERFLOW 32)
				    (DATABASE.OVERFLOW 33]
    PROCEDURES
      ((CREATE.OBJECT ARGS (OBJECT.NAME AUTHENTICATOR)
		      ERRORS
		      (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR UPDATE.ERROR WRONG.SERVER)
		      2)
       (DELETE.OBJECT ARGS (OBJECT.NAME AUTHENTICATOR)
		      ERRORS
		      (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR UPDATE.ERROR WRONG.SERVER)
		      3)
       (LOOKUP.OBJECT ARGS (OBJECT.NAME.PATTERN AUTHENTICATOR)
		      RESULTS
		      (OBJECT.NAME)
		      ERRORS
		      (ARGUMENT.ERROR CALL.ERROR WRONG.SERVER)
		      4)
       (LIST.ORGANIZATIONS ARGS (ORGANIZATION.NAME.PATTERN BULK.DATA.SINK AUTHENTICATOR)
			   ERRORS
			   (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR WRONG.SERVER)
			   5)
       (LIST.DOMAINS ARGS (DOMAIN.NAME.PATTERN BULK.DATA.SINK AUTHENTICATOR)
		     ERRORS
		     (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR WRONG.SERVER)
		     6)
       (LIST.OBJECTS ARGS (OBJECT.NAME.PATTERN PROPERTY BULK.DATA.SINK AUTHENTICATOR)
		     ERRORS
		     (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR WRONG.SERVER)
		     7)
       (LIST.ALIASES.OF ARGS (OBJECT.NAME.PATTERN BULK.DATA.SINK AUTHENTICATOR)
			RESULTS
			(OBJECT.NAME)
			ERRORS
			(ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR WRONG.SERVER)
			9)
       (CREATE.ALIAS ARGS (OBJECT.NAME OBJECT.NAME AUTHENTICATOR)
		     RESULTS
		     (OBJECT.NAME)
		     ERRORS
		     (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR UPDATE.ERROR WRONG.SERVER)
		     10)
       (DELETE.ALIAS ARGS (OBJECT.NAME AUTHENTICATOR)
		     RESULTS
		     (OBJECT.NAME)
		     ERRORS
		     (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR UPDATE.ERROR WRONG.SERVER)
		     11)
       (LIST.ALIASES ARGS (OBJECT.NAME.PATTERN BULK.DATA.SINK AUTHENTICATOR)
		     ERRORS
		     (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR WRONG.SERVER)
		     8)
       (DELETE.PROPERTY ARGS (OBJECT.NAME PROPERTY AUTHENTICATOR)
			RESULTS
			(OBJECT.NAME)
			ERRORS
			(ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR PROPERTY.ERROR UPDATE.ERROR 
					WRONG.SERVER)
			14)
       (LIST.PROPERTIES ARGS (OBJECT.NAME.PATTERN AUTHENTICATOR)
			RESULTS
			(OBJECT.NAME PROPERTIES)
			ERRORS
			(ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR WRONG.SERVER)
			15)
       (ADD.ITEM.PROPERTY ARGS (OBJECT.NAME PROPERTY ITEM AUTHENTICATOR)
			  RESULTS
			  (OBJECT.NAME)
			  ERRORS
			  (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR PROPERTY.ERROR UPDATE.ERROR 
					  WRONG.SERVER)
			  13)
       (RETRIEVE.ITEM ARGS (OBJECT.NAME.PATTERN PROPERTY AUTHENTICATOR)
		      RESULTS
		      (OBJECT.NAME ITEM)
		      ERRORS
		      (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR PROPERTY.ERROR WRONG.SERVER)
		      16)
       (CHANGE.ITEM ARGS (OBJECT.NAME PROPERTY ITEM AUTHENTICATOR)
		    RESULTS
		    (OBJECT.NAME)
		    ERRORS
		    (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR PROPERTY.ERROR UPDATE.ERROR 
				    WRONG.SERVER)
		    17)
       (ADD.GROUP.PROPERTY ARGS (OBJECT.NAME PROPERTY BULK.DATA.SOURCE AUTHENTICATOR)
			   RESULTS
			   (OBJECT.NAME)
			   ERRORS
			   (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR PROPERTY.ERROR 
					   UPDATE.ERROR WRONG.SERVER)
			   12)
       (RETRIEVE.MEMBERS ARGS (OBJECT.NAME.PATTERN PROPERTY BULK.DATA.SINK AUTHENTICATOR)
			 RESULTS
			 (OBJECT.NAME)
			 ERRORS
			 (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR PROPERTY.ERROR WRONG.SERVER)
			 18)
       (ADD.MEMBER ARGS (OBJECT.NAME PROPERTY THREE.PART.NAME AUTHENTICATOR)
		   RESULTS
		   (OBJECT.NAME)
		   ERRORS
		   (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR PROPERTY.ERROR UPDATE.ERROR 
				   WRONG.SERVER)
		   19)
       (ADD.SELF ARGS (OBJECT.NAME PROPERTY AUTHENTICATOR)
		 RESULTS
		 (OBJECT.NAME)
		 ERRORS
		 (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR PROPERTY.ERROR UPDATE.ERROR 
				 WRONG.SERVER)
		 20)
       (DELETE.MEMBER ARGS (OBJECT.NAME PROPERTY THREE.PART.NAME AUTHENTICATOR)
		      RESULTS
		      (OBJECT.NAME)
		      ERRORS
		      (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR PROPERTY.ERROR UPDATE.ERROR 
				      WRONG.SERVER)
		      21)
       (DELETE.SELF ARGS (OBJECT.NAME PROPERTY AUTHENTICATOR)
		    RESULTS
		    (OBJECT.NAME)
		    ERRORS
		    (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR PROPERTY.ERROR UPDATE.ERROR 
				    WRONG.SERVER)
		    22)
       (IS.MEMBER ARGS (OBJECT.NAME.PATTERN PROPERTY PROPERTY THREE.PART.NAME AUTHENTICATOR)
		  RESULTS
		  (BOOLEAN OBJECT.NAME)
		  ERRORS
		  (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR PROPERTY.ERROR WRONG.SERVER)
		  23)
       (RETRIEVE.ADDRESSES RESULTS (NETWORK.ADDRESS.LIST)
			   ERRORS
			   (CALL.ERROR)
			   0)
       (LIST.DOMAINS.SERVED ARGS (BULK.DATA.SINK AUTHENTICATOR)
			    ERRORS
			    (CALL.ERROR)
			    1))
    ERRORS
      ((ARGUMENT.ERROR ARGS (ARGUMENT.PROBLEM WHICH.ARGUMENT)
		       2)
       (AUTHENTICATION.ERROR ARGS (AUTHENTICATION.PROBLEM)
			     6)
       (CALL.ERROR ARGS (CALL.PROBLEM)
		   1)
       (PROPERTY.ERROR ARGS (PROPERTY.PROBLEM OBJECT.NAME)
		       3)
       (UPDATE.ERROR ARGS (UPDATE.PROBLEM BOOLEAN WHICH.ARGUMENT OBJECT.NAME)
		     4)
       (WRONG.SERVER ARGS (OBJECT.NAME)
		     5)))
(DECLARE: DONTCOPY 
(DECLARE: EVAL@COMPILE 

(RPAQQ \CH.NULL.AUTHENTICATOR ((CREDENTIALS ((TYPE 0)
					     (VALUE NIL)))
			       (VERIFIER (0))))

(RPAQQ CH.PROPERTYIDS ((ALL 0)
		       (CLEARINGHOUSE.NAMES 3)
		       (CLEARINGHOUSE.ADDRESSES 4)
		       (FILESERVER 10)
		       (PRINTSERVER 11)
		       (IRS 12)
		       (USER 14)
		       (MAILSERVER 15)
		       (WORKSTATION 17)
		       (ECS 20)
		       (ITS 23)))

(RPAQQ \CH.BROADCAST.TYPE 2)

(RPAQQ \CH.BROADCAST.SOCKET 20)

(RPAQQ \BROADCAST.FOR.SERVERS.LENGTH 22)

(CONSTANTS [\CH.NULL.AUTHENTICATOR (QUOTE ((CREDENTIALS ((TYPE 0)
							 (VALUE NIL)))
					   (VERIFIER (0]
	   [CH.PROPERTYIDS (QUOTE ((ALL 0)
				   (CLEARINGHOUSE.NAMES 3)
				   (CLEARINGHOUSE.ADDRESSES 4)
				   (FILESERVER 10)
				   (PRINTSERVER 11)
				   (IRS 12)
				   (USER 14)
				   (MAILSERVER 15)
				   (WORKSTATION 17)
				   (ECS 20)
				   (ITS 23]
	   (\CH.BROADCAST.TYPE 2)
	   (\CH.BROADCAST.SOCKET 20)
	   (\BROADCAST.FOR.SERVERS.LENGTH 22))
)

[DECLARE: EVAL@COMPILE 

(BLOCKRECORD \BROADCAST.FOR.SERVERS.PACKET ((NIL 3 WORD)     (* Packet exchange header)
					    (LOW.VERSION WORD)
					    (HIGH.VERSION WORD)
					    (ZERO1 WORD)
					    (ZERO2 WORD)
					    (PROGRAM# FIXP)
					    (VERSION# WORD)
					    (ZERO3 WORD)))
]

(DECLARE: DOEVAL@COMPILE DONTCOPY

(ADDTOVAR GLOBALVARS LOCAL.CLEARINGHOUSE \CH.CACHE CH.DEFAULT.DOMAIN CH.DEFAULT.ORGANIZATION)
)
)

(RPAQ? CH.DEFAULT.DOMAIN NIL)

(RPAQ? CH.DEFAULT.ORGANIZATION NIL)

(RPAQ? LOCAL.CLEARINGHOUSE NIL)

(RPAQ? \CH.CACHE NIL)

(RPAQ? CLEARINGHOUSE.STRUCTURE.WINDOW NIL)

(RPAQ? NS.SERVER.NAMES.TO.ADDRESSES NIL)

(ADDTOVAR \SYSTEMCACHEVARS LOCAL.CLEARINGHOUSE \CH.CACHE NS.SERVER.NAMES.TO.ADDRESSES)
(DEFINEQ

(GETCLEARINGHOUSE
  [LAMBDA NIL                                                (* ecc "18-JUL-83 15:38")
    (if (AND CH.DEFAULT.DOMAIN CH.DEFAULT.ORGANIZATION LOCAL.CLEARINGHOUSE)
      elseif [AND (NULL LOCAL.CLEARINGHOUSE)
		  (NULL (SETQ LOCAL.CLEARINGHOUSE (CH.BROADCAST.FOR.SERVERS]
	then (ERROR "Can't find a Clearinghouse" NIL T)
      else (PROG ((DOMAINS (CH.DOMAINS.SERVED LOCAL.CLEARINGHOUSE))
		  DOM)
	         (SETQ DOM (CAR DOMAINS))
	         (if (OR (NULL CH.DEFAULT.DOMAIN)
			 (NULL CH.DEFAULT.ORGANIZATION))
		     then                                    (* Use the first domain that this server serves to set 
							     the default domain and organization.)
			  (SETQ CH.DEFAULT.DOMAIN (CADR (ASSOC (QUOTE DOMAIN)
							       DOM)))
			  (SETQ CH.DEFAULT.ORGANIZATION (CADR (ASSOC (QUOTE ORGANIZATION)
								     DOM)))
			  (printout PROMPTWINDOW .TAB0 0 "[Default Clearinghouse domain set to " 
				    CH.DEFAULT.DOMAIN ":" CH.DEFAULT.ORGANIZATION "]"))
	         (\CH.UPDATE.CACHE (PARSE.CH.NAME "local Clearinghouse:CHServers:CHServers")
				   LOCAL.CLEARINGHOUSE DOMAINS)
	         (RETURN LOCAL.CLEARINGHOUSE])

(START.CLEARINGHOUSE
  [LAMBDA (RESTARTFLG)                                       (* ecc "20-JUL-83 12:17")
    (if RESTARTFLG
	then (SETQ LOCAL.CLEARINGHOUSE NIL))
    (if (NULL LOCAL.CLEARINGHOUSE)
	then (SETQ \NS.ROUTING.TABLE.RADIUS 5)
	     (SETQ \CH.CACHE NIL)
	     (printout PROMPTWINDOW .TAB0 0 "[Starting Clearinghouse: this will take a few seconds]")
	     (if (NOT \NSFLG)
		 then (\NSINIT)
		      (BLOCK 5000)                           (* Allow time for routing info to be received.)
		 )
	     (GETCLEARINGHOUSE))
    LOCAL.CLEARINGHOUSE])

(SHOW.CLEARINGHOUSE
  [LAMBDA (ENTIRE.CLEARINGHOUSE? DONT.GRAPH)                 (* ecc "18-AUG-83 14:50")
    (PROG (SEXPR)
          [SETQ SEXPR (CONS "" (if ENTIRE.CLEARINGHOUSE?
				   then                      (* Find all domains in all organizations.)
					[for ORG in (CH.ORGANIZATIONS "*")
					   collect (CONS ORG (CH.DOMAINS (CONCAT "*:" ORG]
				 else                        (* Use cached structure.)
				      (for ORG in \CH.CACHE
					 collect (CONS (CAR ORG)
						       (for DOM in (CDR ORG)
							  collect (CADR (ASSOC (QUOTE DOMAIN)
									       (CAR DOM]
          (if DONT.GRAPH
	      then (RETURN SEXPR))
          (LOAD? (QUOTE GRAPHER.DCOM)
		 (QUOTE SYSLOAD))
          (SETQ CLEARINGHOUSE.STRUCTURE.WINDOW (SHOWGRAPH (LAYOUTSEXPR SEXPR (QUOTE HORIZONTAL)
								       NIL
								       (QUOTE (HELVETICA 10 BOLD)))
							  (OR CLEARINGHOUSE.STRUCTURE.WINDOW 
							      "Clearinghouse structure")))
          [WINDOWPROP CLEARINGHOUSE.STRUCTURE.WINDOW (QUOTE CLOSEFN)
		      (FUNCTION (LAMBDA NIL
			  (SETQ CLEARINGHOUSE.STRUCTURE.WINDOW NIL]
          (RETURN CLEARINGHOUSE.STRUCTURE.WINDOW])

(CH.FINDSERVER
  [LAMBDA (DOMAINPATTERN NOERRORFLG DONTPROBEFLG)            (* bvm: "16-NOV-83 15:08")
                                                             (* Find a Clearinghouse which serves the specified 
							     domain and return its NS address.
							     If DONTPROBEFLG is T, just search the cache.)
    (PROG (ORGANIZATION DOMAIN ORGANIZATION.INFO ADDRESS STREAM TRANSFER.STREAM RESULTS NAMELIST)
          (SETQ DOMAINPATTERN (PARSE.CH.NAME DOMAINPATTERN 2))
          (SETQ ORGANIZATION (CADR (ASSOC (QUOTE ORGANIZATION)
					  DOMAINPATTERN)))
          (SETQ DOMAIN (CADR (ASSOC (QUOTE DOMAIN)
				    DOMAINPATTERN)))
          [for X in \CH.CACHE do (COND
				   ((STREQUAL.EXCEPT.FOR.CASE (CAR X)
							      ORGANIZATION)
				     (SETQ ORGANIZATION.INFO X)
				     (RETURN]
          [COND
	    (ORGANIZATION.INFO (for DOMAIN.INFO in (CDR ORGANIZATION.INFO)
				  do (COND
				       ((MATCHING.CH.NAMES (CAR DOMAIN.INFO)
							   DOMAINPATTERN)
					 (SETQ ADDRESS (CADADR DOMAIN.INFO))
					 (RETURN]
          (COND
	    (ADDRESS (RETURN ADDRESS))
	    [DONTPROBEFLG (COND
			    (NOERRORFLG (RETURN NIL))
			    (T (ERROR "Couldn't find Clearinghouse server for domain" (
					CH.NAME.TO.STRING DOMAINPATTERN)
				      T]
	    (T (printout PROMPTWINDOW .TAB0 0 "[Finding Clearinghouse server for " (CH.NAME.TO.STRING
			   DOMAINPATTERN)
			 "]")
	       [COND
		 ((SETQ STREAM (COURIER.OPEN (COND
					       (ORGANIZATION.INFO (CH.FINDSERVER
								    (BQUOTE ((ORGANIZATION , 
										     ORGANIZATION)
									     (DOMAIN , "*")))
								    NOERRORFLG T))
					       (T (GETCLEARINGHOUSE)))
					     NIL NOERRORFLG (QUOTE CLEARINGHOUSE)))
		   (RESETLST (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE)
						  STREAM))
			     (SETQ TRANSFER.STREAM (COURIER.CALL
				 STREAM
				 (QUOTE CLEARINGHOUSE)
				 (QUOTE RETRIEVE.MEMBERS)
				 [PARSE.CH.NAME (COND
						  [ORGANIZATION.INFO (BQUOTE ((ORGANIZATION , 
										      "CHServers")
									      (DOMAIN , ORGANIZATION)
									      (OBJECT , DOMAIN]
						  (T (BQUOTE ((ORGANIZATION , "CHServers")
							      (DOMAIN , "CHServers")
							      (OBJECT , ORGANIZATION]
				 (CH.PROPERTY (QUOTE CLEARINGHOUSE.NAMES))
				 NIL
				 (CH.GETAUTHENTICATOR)))
			     (SETQ NAMELIST (COURIER.READ.BULKDATA TRANSFER.STREAM (QUOTE 
										    CLEARINGHOUSE)
								   (QUOTE OBJECT.NAME)))
			     (CLOSEF TRANSFER.STREAM)
			     (bind CHDOMAINS CHADDR for CH in NAMELIST
				do (SETQ RESULTS (COURIER.CALL STREAM (QUOTE CLEARINGHOUSE)
							       (QUOTE RETRIEVE.ITEM)
							       CH
							       (CH.PROPERTY (QUOTE 
									  CLEARINGHOUSE.ADDRESSES))
							       (CH.GETAUTHENTICATOR)))
				   [SETQ CHADDR (CH.NSADDRESS (CAR (COURIER.READ.REP (CADR RESULTS)
										     (QUOTE 
										    CLEARINGHOUSE)
										     (QUOTE 
									     NETWORK.ADDRESS.LIST]
				   (SETQ CHDOMAINS (CH.DOMAINS.SERVED CHADDR))
				   (COND
				     (CHDOMAINS (\CH.UPDATE.CACHE CH CHADDR CHDOMAINS]
	       (RETURN (CH.FINDSERVER DOMAINPATTERN NOERRORFLG T])

(\CH.UPDATE.CACHE
  [LAMBDA (OBJECT ADDRESS DOMAINS.SERVED)                    (* ecc "28-JUN-83 10:31")
    (PROG (NAME.AND.ADDRESS ORGANIZATION ORGANIZATION.INFO)
          (printout PROMPTWINDOW .TAB0 0 "[Adding " (CADR (ASSOC (QUOTE OBJECT)
								 OBJECT))
		    " to cache of known Clearinghouses]")
          (SETQ NAME.AND.ADDRESS (LIST OBJECT ADDRESS))
          [for DOMAIN in DOMAINS.SERVED
	     do (SETQ ORGANIZATION (CADR (ASSOC (QUOTE ORGANIZATION)
						DOMAIN)))
		(SETQ ORGANIZATION.INFO NIL)
		(for X in \CH.CACHE do (if (STREQUAL.EXCEPT.FOR.CASE (CAR X)
								     ORGANIZATION)
					   then (SETQ ORGANIZATION.INFO X)
						(RETURN)))
		(if (NULL ORGANIZATION.INFO)
		    then [SETQ \CH.CACHE (NCONC \CH.CACHE (LIST (LIST ORGANIZATION (LIST DOMAIN 
										 NAME.AND.ADDRESS]
		  else (for DOMAIN.INFO in (CDR ORGANIZATION.INFO) do (if (EQUAL.CH.NAMES
									    (CAR DOMAIN.INFO)
									    DOMAIN)
									  then (NCONC DOMAIN.INFO
										      (LIST 
										 NAME.AND.ADDRESS))
									       (RETURN))
			  finally (NCONC ORGANIZATION.INFO (LIST (LIST DOMAIN NAME.AND.ADDRESS]
          (if CLEARINGHOUSE.STRUCTURE.WINDOW
	      then (SHOW.CLEARINGHOUSE])

(EQUAL.CH.NAMES
  [LAMBDA (NAME1 NAME2)                                      (* ecc "25-MAY-83 14:05")
                                                             (* Check if two Clearinghouse names are the same.)
    (for X in NAME1 as Y in NAME2 always (STREQUAL.EXCEPT.FOR.CASE (CADR X)
								   (CADR Y])

(MATCHING.CH.NAMES
  [LAMBDA (NAME1 NAME2)                                      (* ecc " 2-MAY-83 14:02")
                                                             (* Check if two Clearinghouse names match.)
    (AND NAME1 NAME2 (for X in NAME1 as Y in NAME2 always (OR (STREQUAL (CADR X)
									"*")
							      (STREQUAL (CADR Y)
									"*")
							      (STREQUAL.EXCEPT.FOR.CASE (CADR X)
											(CADR Y])

(STREQUAL.EXCEPT.FOR.CASE
  [LAMBDA (S1 S2)                                            (* ecc " 7-JUN-83 11:35")

          (* Use this version if instring doesn't work: (AND (EQP (fetch (STRINGP LENGTH) of S1) (fetch 
	  (STRINGP LENGTH) of S2)) (STREQUAL (U-CASE S1) (U-CASE S2))))


    (AND (EQP (fetch (STRINGP LENGTH) of S1)
	      (fetch (STRINGP LENGTH) of S2))
	 (for C1 instring S1 as C2 instring S2 always (EQP (U-CASECODE C1)
							   (U-CASECODE C2])

(CH.DOMAINS.SERVED
  [LAMBDA (CH)                                               (* bvm: "16-NOV-83 15:03")
    (PROG ((STREAM (COURIER.OPEN CH NIL T (QUOTE CLEARINGHOUSE)))
	   TRANSFER.STREAM DOMAINS)
          [COND
	    (STREAM 

          (* We wrap this in an NLSETQ because we might get an error underneath the Bulk Data transfer if we're not really 
	  talking to a Clearinghouse.)


		    (NLSETQ (RESETLST (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE)
							   STREAM))
				      (SETQ TRANSFER.STREAM (COURIER.CALL STREAM (QUOTE CLEARINGHOUSE)
									  (QUOTE LIST.DOMAINS.SERVED)
									  NIL
									  (CH.GETAUTHENTICATOR)))
				      (SETQ DOMAINS (COURIER.READ.BULKDATA TRANSFER.STREAM
									   (QUOTE CLEARINGHOUSE)
									   (QUOTE DOMAIN.NAME)))
				      (CLOSEF TRANSFER.STREAM]
          (RETURN DOMAINS])

(CH.DOMAINS
  [LAMBDA (DOMAINPATTERN)                                    (* bvm: "16-NOV-83 15:03")
    (PROG (STREAM TRANSFER.STREAM DOMAINS)
          (SETQ DOMAINPATTERN (PARSE.CH.NAME DOMAINPATTERN 2))
          (SETQ STREAM (COURIER.OPEN (CH.FINDSERVER DOMAINPATTERN T)
				     NIL T (QUOTE CLEARINGHOUSE)))
          [COND
	    (STREAM (RESETLST (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE)
						   STREAM))
			      (SETQ TRANSFER.STREAM (COURIER.CALL STREAM (QUOTE CLEARINGHOUSE)
								  (QUOTE LIST.DOMAINS)
								  DOMAINPATTERN NIL (
								    CH.GETAUTHENTICATOR)))
			      (SETQ DOMAINS (COURIER.READ.BULKDATA TRANSFER.STREAM (QUOTE 
										    CLEARINGHOUSE)
								   (QUOTE DOMAIN)))
			      (CLOSEF TRANSFER.STREAM]
          (RETURN DOMAINS])

(CH.ORGANIZATIONS
  [LAMBDA (ORGANIZATIONPATTERN)                              (* bvm: "16-NOV-83 15:03")
    (PROG ((STREAM (COURIER.OPEN (GETCLEARINGHOUSE)
				 NIL NIL (QUOTE CLEARINGHOUSE)))
	   TRANSFER.STREAM ORGANIZATIONS)
          (RESETLST (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE)
					 STREAM))
		    (SETQ TRANSFER.STREAM (COURIER.CALL STREAM (QUOTE CLEARINGHOUSE)
							(QUOTE LIST.ORGANIZATIONS)
							(PARSE.CH.NAME ORGANIZATIONPATTERN 1)
							NIL
							(CH.GETAUTHENTICATOR)))
		    (SETQ ORGANIZATIONS (COURIER.READ.BULKDATA TRANSFER.STREAM (QUOTE CLEARINGHOUSE)
							       (QUOTE ORGANIZATION)))
		    (CLOSEF TRANSFER.STREAM))
          (RETURN ORGANIZATIONS])

(CH.SERVERS
  [LAMBDA NIL                                                (* bvm: "16-NOV-83 15:02")
                                                             (* Return a list of the names of all Clearinghouse 
							     servers.)
    (PROG (STREAM TRANSFER.STREAM ENUMERATION.LIST)
          (SETQ STREAM (COURIER.OPEN (GETCLEARINGHOUSE)
				     NIL NIL (QUOTE CLEARINGHOUSE)))
          (RESETLST (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE)
					 STREAM))
		    (SETQ TRANSFER.STREAM (COURIER.CALL STREAM (QUOTE CLEARINGHOUSE)
							(QUOTE RETRIEVE.MEMBERS)
							(PARSE.CH.NAME 
								  "CHServers:CHServers:CHServers")
							(CH.PROPERTY (QUOTE CLEARINGHOUSE.NAMES))
							NIL
							(CH.GETAUTHENTICATOR)))
		    (SETQ ENUMERATION.LIST (COURIER.READ.BULKDATA TRANSFER.STREAM (QUOTE 
										    CLEARINGHOUSE)
								  (QUOTE OBJECT.NAME)))
		    (CLOSEF TRANSFER.STREAM))
          (RETURN (for OBJ in ENUMERATION.LIST collect (CADR (ASSOC (QUOTE OBJECT)
								    OBJ])

(CH.BROADCAST.FOR.SERVERS
  [LAMBDA NIL                                                (* ecc "29-AUG-83 13:08")
                                                             (* Expanding ring broadcast, as defined in Clearinghouse
							     Protocol spec.)
    (PROG ((SKT (OPENNSOCKET \CH.BROADCAST.SOCKET T))
	   EPKT BASE ROUTINGTABLE RESULT)
          (SETQ EPKT (\FILLINXIP \XIPT.EXCHANGE SKT BROADCASTNSHOSTNUMBER \CH.BROADCAST.SOCKET 0
				 (IPLUS \XIPOVLEN \BROADCAST.FOR.SERVERS.LENGTH)))
          (SETQ BASE (fetch XIPCONTENTS of EPKT))
          (replace (PACKETEXCHANGEXIP PACKETEXCHANGEID) of BASE with (RAND))
          (replace (PACKETEXCHANGEXIP PACKETEXCHANGETYPE) of BASE with \CH.BROADCAST.TYPE)
          (replace (\BROADCAST.FOR.SERVERS.PACKET LOW.VERSION) of BASE with COURIER.VERSION#)
          (replace (\BROADCAST.FOR.SERVERS.PACKET HIGH.VERSION) of BASE with COURIER.VERSION#)
          [replace (\BROADCAST.FOR.SERVERS.PACKET PROGRAM#) of BASE
	     with (CAR (\GET.COURIER.PROG#VERS#.PAIR (QUOTE CLEARINGHOUSE]
          [replace (\BROADCAST.FOR.SERVERS.PACKET VERSION#) of BASE
	     with (CADR (\GET.COURIER.PROG#VERS#.PAIR (QUOTE CLEARINGHOUSE]
          (replace (\BROADCAST.FOR.SERVERS.PACKET ZERO1) of BASE with (replace (
\BROADCAST.FOR.SERVERS.PACKET ZERO2) of BASE with (replace (\BROADCAST.FOR.SERVERS.PACKET ZERO3)
						     of BASE with 0)))
          (if (SETQ RESULT (\CH.BROADCAST.FOR.SERVERS.ON.NET 0 SKT EPKT))
	      then                                           (* First try directly connected network.)
		   (GO DONE))
          [if (AND (BOUNDP (QUOTE CH.NET.HINT))
		   CH.NET.HINT)
	      then                                           (* Now use a hint for which network to try first.)
		   (if (FIXP CH.NET.HINT)
		       then (if (SETQ RESULT (\CH.BROADCAST.FOR.SERVERS.ON.NET CH.NET.HINT SKT EPKT))
				then (GO DONE))
		     elseif (LISTP CH.NET.HINT)
		       then (for NET in CH.NET.HINT do (if (SETQ RESULT (
							       \CH.BROADCAST.FOR.SERVERS.ON.NET
							       NET SKT EPKT))
							   then (GO DONE]
          (SETQ ROUTINGTABLE (COPY (CDR \NS.ROUTING.TABLE)))
                                                             (* Need to make a copy so that the network code doesn't 
							     change it out from under us.)
          [for #HOPS from 0 to 5 do (for RT in ROUTINGTABLE
				       do (if (AND (EQP (fetch (ROUTING RTHOPCOUNT) of RT)
							#HOPS)
						   (SETQ RESULT (\CH.BROADCAST.FOR.SERVERS.ON.NET
						       (fetch (ROUTING RTNET#) of RT)
						       SKT EPKT)))
					      then (GO DONE]
      DONE(CLOSENSOCKET SKT)
          (RETURN RESULT])

(\CH.BROADCAST.FOR.SERVERS.ON.NET
  [LAMBDA (NET SOCKET EPKT)                                  (* ecc "28-JUN-83 10:32")
    (PROG (RESPONSE RESULT)
          (replace XIPDESTNET of EPKT with NET)
          (printout PROMPTWINDOW .TAB0 0 "[Broadcasting for Clearinghouse servers on net " .I0.8 NET 
		    "]")
          (to \MAXETHERTRIES do (if (AND (SETQ RESPONSE (EXCHANGEXIPS SOCKET EPKT T))
					 (SETQ RESULT (\CH.READ.BROADCAST.RESPONSE RESPONSE)))
				    then (SETQ RESULT (CH.NSADDRESS (CAR RESULT)))
					 (RETURN)))
          (RETURN RESULT])

(\CH.READ.BROADCAST.RESPONSE
  [LAMBDA (EPKT)                                             (* ecc " 7-JUL-83 14:31")
    (PROG ((STREAM (\STREAM.FROM.PACKET EPKT))
	   LOW.VERSION HIGH.VERSION)
          (SETQ LOW.VERSION (GETWORD STREAM))
          (SETQ HIGH.VERSION (GETWORD STREAM))
          (RETURN (if (AND (AND (ILEQ LOW.VERSION COURIER.VERSION#)
				(ILEQ COURIER.VERSION# HIGH.VERSION))
			   (EQ (GETWORD STREAM)
			       2))
		      then (GETWORD STREAM)                  (* This word isn't documented in the spec, but the 
							     Clearinghouse sends it.)
			   (COURIER.READ STREAM (QUOTE CLEARINGHOUSE)
					 (QUOTE NETWORK.ADDRESS.LIST))
		    else NIL])

(PARSE.CH.NAME
  [LAMBDA (NAME #PARTS.REQUESTED NOWILDCARDS)                (* ecc "15-AUG-83 14:43")
                                                             (* Return a Clearinghouse name with 1, 2, or 3 parts 
							     (default 3))
    (PROG (FIRSTPART SECONDPART THIRDPART I J)
          (GETCLEARINGHOUSE)
          (if (NULL #PARTS.REQUESTED)
	      then (SETQ #PARTS.REQUESTED 3))
          (if (NULL NAME)
	      then (SETQ NAME "*"))
          (if [OR (NULL NAME)
		  (NOT (OR (LISTP NAME)
			   (STRINGP NAME)
			   (LITATOM NAME]
	      then (LISPERROR "ILLEGAL ARG" NAME))
          (if (LISTP NAME)
	      then                                           (* Since NAME is a list, it must already be a two or 
							     three part name.)
		   (RETURN (SELECTQ #PARTS.REQUESTED
				    (1 (\CH.CHECK.WILDCARD (CADR (ASSOC (QUOTE ORGANIZATION)
									NAME))
							   NOWILDCARDS))
				    [2 (BQUOTE ((ORGANIZATION , (\CH.CHECK.WILDCARD
								(CADR (ASSOC (QUOTE ORGANIZATION)
									     NAME))
								T))
						(DOMAIN , (\CH.CHECK.WILDCARD
							  (CADR (ASSOC (QUOTE DOMAIN)
								       NAME))
							  NOWILDCARDS]
				    [3 (BQUOTE ((ORGANIZATION , (\CH.CHECK.WILDCARD
								(CADR (ASSOC (QUOTE ORGANIZATION)
									     NAME))
								T))
						(DOMAIN , (\CH.CHECK.WILDCARD
							  (CADR (ASSOC (QUOTE DOMAIN)
								       NAME))
							  T))
						(OBJECT , (\CH.CHECK.WILDCARD
							  (CADR (ASSOC (QUOTE OBJECT)
								       NAME))
							  NOWILDCARDS]
				    (ERROR "Clearinghouse names must have 1, 2, or 3 parts" 
					   #PARTS.REQUESTED)))
	    else (SETQ NAME (MKSTRING NAME))
		 (if (SETQ I (STRPOS ":" NAME))
		     then (SETQ FIRSTPART (SUBSTRING NAME 1 (SUB1 I)))
			  (if (SETQ J (STRPOS ":" NAME (ADD1 I)))
			      then (SETQ SECONDPART (SUBSTRING NAME (ADD1 I)
							       (SUB1 J)))
				   (SETQ THIRDPART (SUBSTRING NAME (ADD1 J)
							      NIL))
			    else (SETQ SECONDPART (SUBSTRING NAME (ADD1 I)
							     NIL)))
		   else (SETQ FIRSTPART NAME))
		 (RETURN (SELECTQ #PARTS.REQUESTED
				  (1 (\CH.CHECK.WILDCARD (OR THIRDPART SECONDPART FIRSTPART)
							 NOWILDCARDS))
				  [2 (BQUOTE ((ORGANIZATION , (\CH.CHECK.WILDCARD (OR THIRDPART 
										      SECONDPART 
									  CH.DEFAULT.ORGANIZATION)
										  T))
					      (DOMAIN , (\CH.CHECK.WILDCARD (OR (AND THIRDPART 
										     SECONDPART)
										FIRSTPART)
									    NOWILDCARDS]
				  [3 (BQUOTE ((ORGANIZATION , (\CH.CHECK.WILDCARD (OR THIRDPART 
									  CH.DEFAULT.ORGANIZATION)
										  T))
					      (DOMAIN , (\CH.CHECK.WILDCARD (OR SECONDPART 
										CH.DEFAULT.DOMAIN)
									    T))
					      (OBJECT , (\CH.CHECK.WILDCARD FIRSTPART NOWILDCARDS]
				  (ERROR "Clearinghouse names must have 1, 2, or 3 parts" 
					 #PARTS.REQUESTED])

(CH.NAME.TO.STRING
  [LAMBDA (CHNAME FULLNAMEFLG)                               (* ecc "20-JUN-83 11:56")
                                                             (* Return a string for a Clearinghouse name.
							     Leaves off default components unless FULLNAMEFLG is 
							     set.)
    (if (OR (LITATOM CHNAME)
	    (STRINGP CHNAME))
	then (SETQ CHNAME (PARSE.CH.NAME CHNAME)))
    (SELECTQ (LENGTH CHNAME)
	     [2 (PROG [(ORG (CADR (ASSOC (QUOTE ORGANIZATION)
					 CHNAME)))
		       (DOM (CADR (ASSOC (QUOTE DOMAIN)
					 CHNAME]
		      (RETURN (if (OR FULLNAMEFLG (NOT (STREQUAL.EXCEPT.FOR.CASE ORG 
									  CH.DEFAULT.ORGANIZATION)))
				  then (CONCAT DOM ":" ORG)
				else DOM]
	     [3 (PROG [(ORG (CADR (ASSOC (QUOTE ORGANIZATION)
					 CHNAME)))
		       (DOM (CADR (ASSOC (QUOTE DOMAIN)
					 CHNAME)))
		       (OBJ (CADR (ASSOC (QUOTE OBJECT)
					 CHNAME]
		      (RETURN (if (OR FULLNAMEFLG (NOT (STREQUAL.EXCEPT.FOR.CASE ORG 
									  CH.DEFAULT.ORGANIZATION)))
				  then (CONCAT OBJ ":" DOM ":" ORG)
				elseif (NOT (STREQUAL.EXCEPT.FOR.CASE DOM CH.DEFAULT.DOMAIN))
				  then (CONCAT OBJ ":" DOM)
				else                         (* Leave a trailing colon on the name as a hack to 
							     distinguish it from PUP names.)
				     (CONCAT OBJ ":"]
	     (LISPERROR "ILLEGAL ARG" CHNAME])

(CANONICAL.CH.NAME
  [LAMBDA (NAME)                                             (* ecc "22-JUN-83 13:17")
    (MKATOM (CH.NAME.TO.STRING (PARSE.CH.NAME NAME])

(\CH.CHECK.WILDCARD
  [LAMBDA (STRING WILDCARDSILLEGALP)                         (* ecc "27-APR-83 17:41")
    (if (NULL STRING)
	then (SETQ STRING "*"))
    (if (OR (NOT WILDCARDSILLEGALP)
	    (NOT (STRPOS "*" STRING)))
	then STRING
      else (ERROR "Wildcard characters not allowed" STRING])

(CH.PROPERTY
  [LAMBDA (PROP)                                             (* ecc "27-APR-83 12:28")
                                                             (* Return the official Clearinghouse property ID for the
							     specified property.)
    (if (LITATOM PROP)
	then (COND
	       ((CADR (ASSOC PROP CH.PROPERTYIDS)))
	       (T (ERROR "Unknown Clearinghouse property" PROP)))
      else PROP])

(\CH.GUESS.NEW.PROPERTIES
  [LAMBDA (DOMAIN MINPROPERTYID MAXPROPERTYID)               (* ecc "12-AUG-83 14:58")

          (* This is a hack that finds all the objects in the given domain with any properties in the given range.
	  Useful for finding out what the Services people are up to.)


    (PROG ([PATTERN (PARSE.CH.NAME (APPEND (PARSE.CH.NAME DOMAIN 2)
					   (QUOTE (OBJECT "*"]
	   OBJECTS)
          (SETQ MINPROPERTYID (OR MINPROPERTYID 1))
          (SETQ MAXPROPERTYID (OR MAXPROPERTYID 25))
          (RETURN (for ID from MINPROPERTYID to MAXPROPERTYID when (SETQ OBJECTS (CH.ENUMERATE 
											  PATTERN ID))
		     collect (CONS ID OBJECTS])

(CH.NSADDRESS
  [LAMBDA (X)                                                (* ecc " 7-JUL-83 14:42")
                                                             (* Convert a network address returned by Clearinghouse 
							     into an NSADDRESS record.)
    (PROG (NET HOST)
          (SETQ NET (COURIER.READ.REP (CADR (ASSOC (QUOTE NETWORK)
						   X))
				      (QUOTE CLEARINGHOUSE)
				      (QUOTE LONGCARDINAL)))
          (SETQ HOST (CADR (ASSOC (QUOTE HOST)
				  X)))
          (RETURN (create NSADDRESS
			  NSNET ← NET
			  NSHNM0 ←(CAR HOST)
			  NSHNM1 ←(CADR HOST)
			  NSHNM2 ←(CADDR HOST])

(CH.GETAUTHENTICATOR
  [LAMBDA NIL                                                (* ecc "31-MAY-83 15:41")
    \CH.NULL.AUTHENTICATOR])

(CH.ENUMERATE
  [LAMBDA (OBJECTPATTERN PROPERTY)                           (* bvm: "16-NOV-83 15:02")
    (PROG (STREAM TRANSFER.STREAM ENUMERATION.LIST)
          (SETQ OBJECTPATTERN (PARSE.CH.NAME OBJECTPATTERN))
          [COND
	    ((NULL PROPERTY)                                 (* Use the null property.)
	      (SETQ PROPERTY (QUOTE ALL]
          (SETQ STREAM (COURIER.OPEN (CH.FINDSERVER (PARSE.CH.NAME OBJECTPATTERN 2)
						    T)
				     NIL T (QUOTE CLEARINGHOUSE)))
          [COND
	    (STREAM (RESETLST (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE)
						   STREAM))
			      (SETQ TRANSFER.STREAM (COURIER.CALL STREAM (QUOTE CLEARINGHOUSE)
								  (QUOTE LIST.OBJECTS)
								  OBJECTPATTERN
								  (CH.PROPERTY PROPERTY)
								  NIL
								  (CH.GETAUTHENTICATOR)
								  T))
			      (COND
				(TRANSFER.STREAM (SETQ ENUMERATION.LIST (COURIER.READ.BULKDATA
						     TRANSFER.STREAM
						     (QUOTE CLEARINGHOUSE)
						     (QUOTE OBJECT)))
						 (CLOSEF TRANSFER.STREAM]
          (RETURN ENUMERATION.LIST])

(CH.LOOKUP
  [LAMBDA (OBJECTPATTERN PROPERTY)                           (* bvm: "16-NOV-83 15:01")
    (SETQ OBJECTPATTERN (PARSE.CH.NAME OBJECTPATTERN))
    (PROG [(STREAM (COURIER.OPEN (CH.FINDSERVER (PARSE.CH.NAME OBJECTPATTERN 2)
						T)
				 NIL T (QUOTE CLEARINGHOUSE]
          (RETURN (COND
		    (STREAM (RESETLST (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE)
							   STREAM))
				      (COURIER.CALL STREAM (QUOTE CLEARINGHOUSE)
						    (QUOTE RETRIEVE.ITEM)
						    OBJECTPATTERN
						    (CH.PROPERTY PROPERTY)
						    (CH.GETAUTHENTICATOR)
						    T])

(LOOKUP.NS.SERVER
  [LAMBDA (NAME TYPE)                                        (* ecc " 7-JUL-83 14:42")
                                                             (* Return the NS address of the specified server.
							     If a type is given, use the Clearinghouse if the address
							     isn't in the cache.)
    (PROG (ADDRESS X)
          (SETQ NAME (PARSE.CH.NAME NAME))
          (for PAIR in NS.SERVER.NAMES.TO.ADDRESSES do (if (EQUAL.CH.NAMES (CAR PAIR)
									   NAME)
							   then (SETQ ADDRESS (CADR PAIR))
								(RETURN)))
          (if (AND (NULL ADDRESS)
		   TYPE
		   (SETQ X (CH.LOOKUP NAME TYPE)))
	      then [SETQ ADDRESS (CH.NSADDRESS (COURIER.READ.REP (CADR X)
								 (QUOTE CLEARINGHOUSE)
								 (QUOTE NETWORK.ADDRESS]
		   (push NS.SERVER.NAMES.TO.ADDRESSES (LIST NAME ADDRESS)))
          (RETURN ADDRESS])

(CH.LOOKUP.USER
  [LAMBDA (NAME)                                             (* ecc "24-AUG-83 10:35")
    (PROG ((X (CH.LOOKUP NAME (QUOTE USER)))
	   USER)
          (RETURN (if X
		      then (LIST (CAR X)
				 (COURIER.READ.REP (CADR X)
						   (QUOTE CLEARINGHOUSE)
						   (QUOTE USER.ENTRY])

(CH.ADD.USER
  [LAMBDA NIL                                                (* bvm: "16-NOV-83 14:59")
    (PROG ((INFO (\INTERNAL/GETPASSWORD "New Clearinghouse user:" T))
	   FULL.NAME
	   (LAST.NAME.INDEX 0)
	   LAST.NAME PASSWORD SYSTEM.ADMINISTRATOR STREAM)
          (SETQ FULL.NAME (MKSTRING (CAR INFO)))
          (bind I while (SETQ I (STRPOS " " FULL.NAME (ADD1 LAST.NAME.INDEX))) do (SETQ 
										  LAST.NAME.INDEX I))
          [SETQ LAST.NAME (PARSE.CH.NAME (SUBSTRING FULL.NAME (ADD1 LAST.NAME.INDEX]
          (SETQ FULL.NAME (PARSE.CH.NAME FULL.NAME))
          (SETQ PASSWORD (CDR INFO))
          (SETQ SYSTEM.ADMINISTRATOR (EQ (ASKUSER NIL NIL "System administrator? ")
					 (QUOTE Y)))
          (COND
	    ((NEQ (ASKUSER NIL NIL (CONCAT "Confirm new user '" (CH.NAME.TO.STRING FULL.NAME T)
					   "' with alias '"
					   (CH.NAME.TO.STRING LAST.NAME T)
					   "' (Y or N) "))
		  (QUOTE Y))
	      (RETURN)))
          [SETQ INFO (BQUOTE ((LAST.NAME.INDEX , LAST.NAME.INDEX)
			      (PASSWORD , (\DECRYPT.PWD PASSWORD))
			      (SYSTEM.ADMINISTRATOR , SYSTEM.ADMINISTRATOR)
			      (FILESERVER , (PARSE.CH.NAME "FS"))
			      (MAILSERVER , (PARSE.CH.NAME "MS"))
			      (DESCRIPTION "")
			      (PRODUCT "")
			      (TRAINING "")
			      (HELP 0]
          (SETQ STREAM (COURIER.OPEN (CH.FINDSERVER (PARSE.CH.NAME CH.DEFAULT.DOMAIN 2)
						    T)
				     NIL T (QUOTE CLEARINGHOUSE)))
          (COND
	    (STREAM (RESETLST (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE)
						   STREAM))
			      (COURIER.CALL STREAM (QUOTE CLEARINGHOUSE)
					    (QUOTE CREATE.OBJECT)
					    FULL.NAME
					    (CH.GETAUTHENTICATOR))
			      (COURIER.CALL STREAM (QUOTE CLEARINGHOUSE)
					    (QUOTE CREATE.ALIAS)
					    LAST.NAME FULL.NAME (CH.GETAUTHENTICATOR))
			      (COURIER.CALL STREAM (QUOTE CLEARINGHOUSE)
					    (QUOTE ADD.ITEM.PROPERTY)
					    FULL.NAME
					    (CH.PROPERTY (QUOTE USER))
					    (COURIER.WRITE.REP INFO (QUOTE CLEARINGHOUSE)
							       (QUOTE USER.ENTRY))
					    (CH.GETAUTHENTICATOR])
)
(PUTPROPS COURIER COPYRIGHT ("Xerox Corporation" 1983))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (3515 4629 (HASH.PASSWORD 3525 . 4181) (NSLOGIN 4183 . 4627)) (9203 17951 (GETNSPRINTER 
9213 . 9620) (NSPRINT 9622 . 10923) (IP.SENDTOPRINTER 10925 . 11256) (NSPRINT.WATCHDOG 11258 . 11817) 
(\NSPRINT.WATCHDOG.INTERNAL 11819 . 12551) (OPEN.NS.PRINTING.STREAM 12553 . 16298) (NSPRINTER.STATUS 
16300 . 16835) (NSPRINTER.PROPERTIES 16837 . 17380) (NSPRINTREQUEST.STATUS 17382 . 17949)) (26888 
55258 (GETCLEARINGHOUSE 26898 . 28105) (START.CLEARINGHOUSE 28107 . 28705) (SHOW.CLEARINGHOUSE 28707
 . 29921) (CH.FINDSERVER 29923 . 33134) (\CH.UPDATE.CACHE 33136 . 34433) (EQUAL.CH.NAMES 34435 . 34782
) (MATCHING.CH.NAMES 34784 . 35240) (STREQUAL.EXCEPT.FOR.CASE 35242 . 35758) (CH.DOMAINS.SERVED 35760
 . 36619) (CH.DOMAINS 36621 . 37422) (CH.ORGANIZATIONS 37424 . 38138) (CH.SERVERS 38140 . 39180) (
CH.BROADCAST.FOR.SERVERS 39182 . 42101) (\CH.BROADCAST.FOR.SERVERS.ON.NET 42103 . 42705) (
\CH.READ.BROADCAST.RESPONSE 42707 . 43409) (PARSE.CH.NAME 43411 . 46356) (CH.NAME.TO.STRING 46358 . 
47772) (CANONICAL.CH.NAME 47774 . 47948) (\CH.CHECK.WILDCARD 47950 . 48273) (CH.PROPERTY 48275 . 48710
) (\CH.GUESS.NEW.PROPERTIES 48712 . 49423) (CH.NSADDRESS 49425 . 50054) (CH.GETAUTHENTICATOR 50056 . 
50200) (CH.ENUMERATE 50202 . 51281) (CH.LOOKUP 51283 . 51889) (LOOKUP.NS.SERVER 51891 . 52808) (
CH.LOOKUP.USER 52810 . 53130) (CH.ADD.USER 53132 . 55256)))))
STOP