(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 2-Nov-87 23:37:35" {PHYLUM}<MASINTER>LISP>CHATSERVER.;1 14330
changes to%: (VARS CHATSERVERCOMS) (FNS CHATSERVER CHATSERVERWHENCLOSEDFN CHATSERVEROPENFN DOBE REQUIRED.LOGIN RINGBELLS SERVER-EXEC SWEEP.OFD \PROMPTFORWORDBIN \REMOTE.EXEC.OUTCHARFN CHATSERVER.FONT SIMPLECHATSERVER \CLEARSYSBUF \REMOTE.BIN)
(ADVICE (MENU :IN INSTALL-PROTOTYPE-DEFN)) (COMMANDS "QUIT")
previous date%: "30-Oct-87 16:44:56" {ERINYES}<LISPUSERS>LYRIC>CHATSERVER.;8)
(* "
Copyright (c) 1984, 1985, 1986, 1987 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT CHATSERVERCOMS)
(RPAQQ CHATSERVERCOMS ((FNS CHATSERVER CHATSERVERWHENCLOSEDFN CHATSERVEROPENFN DOBE REQUIRED.LOGIN RINGBELLS SERVER-EXEC SWEEP.OFD \CLEARSYSBUF \PROMPTFORWORDBIN \REMOTE.BIN \REMOTE.EXEC.OUTCHARFN CHATSERVER.FONT) (VARS (DISPLAYTERMFLG (QUOTE DM))) (P (SETQ CHATSERVERTTBL (COPYTERMTABLE (QUOTE ORIG))) (for I from 1 to 8 do (ECHOCHAR I (QUOTE IGNORE) CHATSERVERTTBL) (ECHOCHAR I (QUOTE IGNORE) ASKUSERTTBL)) (ECHOCHAR (CHARCODE CR) (QUOTE SIMULATE) CHATSERVERTTBL) (ECHOCHAR (CHARCODE CR) (QUOTE SIMULATE) ASKUSERTTBL) (ECHOCHAR 0 (QUOTE SIMULATE) ASKUSERTTBL) (ECHOCHAR 0 (QUOTE SIMULATE) CHATSERVERTTBL)) (INITVARS (CHATSERVER.PROFILE) (\SIMPLEIMAGEOPS)) (ADDVARS (\SWEPT.OFDS)) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) LLCHAR ATERM IMAGEIO FILEIO ATBL)) (COMS (FNS SIMPLECHATSERVER) (INITVARS (CHATSERVERWINDOW) (CHATSERVERWINDOWREGION (QUOTE (11 228 392 190))))) (MACROS \SYNCODE) (ADVISE (MENU :IN INSTALL-PROTOTYPE-DEFN)) (COMMANDS "QUIT") (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA \REMOTE.BIN CHATSERVEROPENFN))))
)
(DEFINEQ
(CHATSERVER
(LAMBDA NIL (* ; "Edited 30-Oct-87 16:44 by masinter") (PROMPTPRINT "Remote CHAT connection attempted") (PRINTOUT T "Remote " HERALDSTRING T T) (CL:UNWIND-PROTECT (COND ((AND (LISTGET CHATSERVER.PROFILE (QUOTE IDLE.ONLY)) (NOT \IDLING)) (PRINTOUT T " Machine not in idle mode, login not allowed " T) (DISMISS 10000)) (T (COND ((LET ((PROFILE (APPEND CHATSERVER.PROFILE IDLE.PROFILE))) (OR (REQUIRED.LOGIN PROFILE) (REQUIRED.LOGIN PROFILE) (REQUIRED.LOGIN PROFILE))) (* ; "try three times") (PROMPTPRINT "Remote CHAT exec in use") (LET ((*PACKAGE* (CL:FIND-PACKAGE "XCL-USER")) (*READTABLE* (FIND-READTABLE "XCL"))) (SERVER-EXEC))) (T (PRINTOUT T T "Sorry... bye" T))))) (PROMPTPRINT "Remote CHAT disconnect")))
)
(CHATSERVERWHENCLOSEDFN
(LAMBDA (STREAM) (* ; "Edited 6-Oct-87 11:43 by Masinter") (* ;; "when a connection gets closed, signal the server process to abort") (LET ((PROC (STREAMPROP STREAM (QUOTE SERVER.PROCESS)))) (AND PROC (FIND.PROCESS PROC) (DEL.PROCESS PROC))))
)
(CHATSERVEROPENFN
(CL:LAMBDA (*KEYBOARD-STREAM* OUTSTREAM) (* ; "Edited 30-Oct-87 15:38 by masinter") (* ;; "code common to all chat servers") (CL:UNWIND-PROTECT (PROGN (LINELENGTH 80 OUTSTREAM) (PAGEHEIGHT 24 OUTSTREAM) (STREAMPROP *KEYBOARD-STREAM* (QUOTE SERVER.PROCESS) (THIS.PROCESS)) (COND ((fetch (FDEV BUFFERED) of (fetch (STREAM DEVICE) of OUTSTREAM)) (* ;; "output is a buffered device: spawn/restart process to send it out") (pushnew \SWEPT.OFDS OUTSTREAM) (COND ((FIND.PROCESS (QUOTE SWEEP.OFD)) (RESTART.PROCESS (QUOTE SWEEP.OFD))) (T (ADD.PROCESS (QUOTE (SWEEP.OFD))))))) (OR \SIMPLEIMAGEOPS (SETQ \SIMPLEIMAGEOPS (create IMAGEOPS using \NOIMAGEOPS IMFONT ← (QUOTE CHATSERVER.FONT)))) (AND (EQ (fetch IMAGEOPS of OUTSTREAM) \NOIMAGEOPS) (replace IMAGEOPS of OUTSTREAM with \SIMPLEIMAGEOPS)) (replace (STREAM OUTCHARFN) of OUTSTREAM with (FUNCTION \REMOTE.EXEC.OUTCHARFN)) (replace (STREAM EOLCONVENTION) of OUTSTREAM with CRLF.EOLC) (if (EQ (fetch (STREAM STRMBINFN) of *KEYBOARD-STREAM*) (fetch (FDEV BIN) (fetch (STREAM DEVICE) *KEYBOARD-STREAM*))) then (replace (STREAM STRMBINFN) of *KEYBOARD-STREAM* with (QUOTE \REMOTE.BIN)) elseif (NOT (EQ (fetch (STREAM STRMBINFN) of *KEYBOARD-STREAM*) (QUOTE \REMOTE.BIN))) THEN (PRINTOUT OUTSTREAM "[Interrupts not enabled]" T)) (CL:IF NIL (SIMPLECHATSERVER *KEYBOARD-STREAM* OUTSTREAM) (LET* ((\TERM.OFD OUTSTREAM) (*STANDARD-OUTPUT* \TERM.OFD) (\LINEBUF.OFD (\CREATELINEBUFFER *KEYBOARD-STREAM*)) (*STANDARD-INPUT* \LINEBUF.OFD) (*TRACE-OUTPUT* *STANDARD-OUTPUT*)) (DECLARE (CL:SPECIAL PROMPTWINDOW \TERM.OFD *STANDARD-OUTPUT* \LINEBUF.OFD *STANDARD-INPUT*)) (CHATSERVER)))) (SETQ \SWEPT.OFDS (REMOVE OUTSTREAM \SWEPT.OFDS))))
)
(DOBE
(LAMBDA NIL (FLUSHOUTPUT T T)))
(REQUIRED.LOGIN
(LAMBDA (PROFILE) (* ; "Edited 30-Oct-87 16:13 by masinter") (PROG ((GROUP (LISTGET PROFILE (QUOTE ALLOWED.LOGINS))) (AUTHTYPE (LISTGET PROFILE (QUOTE AUTHENTICATE))) (NAME (USERNAME NIL NIL T)) PWD) (COND ((NLISTP GROUP) (* ; "no login check at all") (COND ((LISTGET PROFILE (QUOTE FORGET)) (SETPASSWORD NIL NAME ""))) (RETURN T))) (COND ((EQ 0 (NCHARS NAME)) (* ; "Not logged in, so don't complain about anything") (RETURN T))) CLEAR (CLEARBUF T T) (SETQ NAME (USERNAME NIL NIL T)) (SETQ PWD NIL) RETRY (COND ((AND (EQUAL GROUP (QUOTE (T))) NAME) (* ; "Only previous user allowed to login") (SETQ PWD (PROMPTFORWORD (CONCAT NAME " password:") NIL NIL NIL (QUOTE *)))) (T (SETQ NAME (PROMPTFORWORD "Login (<return> to terminate): " NAME NIL T NIL T (CHARCODE (CR LF)))) (if (MEMBER NAME (QUOTE ("Logon" "ogon"))) then (GO CLEAR)) (SETQ PWD (PROMPTFORWORD " (password) " NIL NIL T (QUOTE *))) (TERPRI T))) (if (EQUAL PWD "Logon") then (GO CLEAR)) (RETURN (COND ((NULL PWD) NIL) ((AND (OR (MEMB T GROUP) (MEMB (QUOTE *) GROUP)) (\IDLE.IS.PREVIOUS NAME PWD (EQUAL GROUP (QUOTE (T))))) (* ;; "Previous user is allowed to login. Also, if only allowed login is old user, but old password is unknown, allow it") T) ((\IDLE.ISMEMBER GROUP NAME PWD) (PROG1 (COND ((COND (AUTHTYPE (\IDLE.AUTHENTICATE NAME PWD AUTHTYPE (NOT (MEMB T GROUP)))) (T T)) (AND (LISTGET PROFILE (QUOTE FORGET)) (SETPASSWORD NIL NAME PWD)) (SETQ \IDLE.PASSWORD.SET T) T)) (TERPRI T))) (T (PRINTOUT T "login incorrect" T) NIL)))))
)
(RINGBELLS
(LAMBDA (N) (* ; "Edited 11-Oct-87 23:02 by Masinter") (DECLARE (GLOBALVARS RINGBELLS.L1 RINGBELLS.L2)) (OR (FIXP N) (SETQ N 1)) (LET ((W (WFROMDS \TERM.OFD))) (CL:IF W (COND ((OR (EQ \MACHINETYPE \DAYBREAK) (EQ \MACHINETYPE \DANDELION)) (to N do (PLAYTUNE RINGBELLS.L1) (FLASHWINDOW NIL NIL 100) (PLAYTUNE RINGBELLS.L2))) (T (FLASHWINDOW NIL N))) (RPTQ N (BOUT \TERM.OFD 7)))))
)
(SERVER-EXEC
(LAMBDA NIL (* ; "Edited 6-Oct-87 16:37 by Masinter") (\CALLME (QUOTE T)) (do (EXEC :TOP-LEVEL-P T)))
)
(SWEEP.OFD
(LAMBDA NIL (* lmm "15-Mar-86 14:40") (while \SWEPT.OFDS do (for X in \SWEPT.OFDS do (if (if (NLISTP X) then (OR (NOT (OPENP X (QUOTE OUTPUT))) (NOT (NLSETQ (FORCEOUTPUT X)))) else T) then (SETQ \SWEPT.OFDS (REMOVE X \SWEPT.OFDS))) (BLOCK))))
)
(\CLEARSYSBUF
(LAMBDA (ALLFLG) (* ; "Edited 30-Oct-87 11:07 by Masinter") (LET ((KEY (fetch (LINEBUFFER KEYBOARDSTREAM) of \LINEBUF.OFD))) (while (READP KEY) do (BIN KEY))))
)
(\PROMPTFORWORDBIN
(LAMBDA (INSTREAM DISPLAYECHOSTREAM URGENCY.OPTION TIMER) (* ; "Edited 7-Oct-87 11:25 by Masinter") (* ; "Takes in one character from the KEYBD.CHANNEL") (DECLARE (USEDFREE TERMINCHARS.LST TIMELIMITEXPIRED? BELLBEENHEARD?)) (PROG ((WAITINTERVAL.secs 15) (TTYWAITLIMIT (if URGENCY.OPTION then (if BELLBEENHEARD? then 30000 else 0))) (BROADURGENCY? (AND URGENCY.OPTION (NOT (FIXP URGENCY.OPTION)))) CHAR READABLE (KEYSTREAM (fetch (LINEBUFFER KEYBOARDSTREAM) of \LINEBUF.OFD))) NEXTROUND (if BROADURGENCY? then (SETQ TIMER (SETUPTIMER WAITINTERVAL.secs TIMER (QUOTE SECONDS)))) LP (if (SETQ READABLE (OR INSTREAM (NEQ KEYSTREAM \KEYBOARD.STREAM) (WAIT.FOR.TTY TTYWAITLIMIT))) then (* ; "Ready to read") (if (SETQ CHAR (if (NULL INSTREAM) then (if (READP KEYSTREAM T) then (BIN KEYSTREAM)) elseif (READP INSTREAM T) then (BIN INSTREAM) elseif (EOFP INSTREAM) then (CAR TERMINCHARS.LST))) then (RETURN CHAR)) (if DISPLAYECHOSTREAM then (* ; "\TTYBACKGROUND so that a caret will flash") (\TTYBACKGROUND) else (BLOCK))) (if (AND TIMER (TIMEREXPIRED? TIMER (QUOTE SECONDS))) then (if (AND URGENCY.OPTION (NOT BROADURGENCY?)) then (SETQ TIMELIMITEXPIRED? T) (RETURN)) else (SETQ TTYWAITLIMIT 30000) (AND READABLE (GO LP))) (if (NULL BELLBEENHEARD?) then (SETQ BELLBEENHEARD? T) (RINGBELLS)) (if (AND BROADURGENCY? (TTY.PROCESSP)) then (* ;; "Double the wait interval time (the time between 'flashings') up to about 2 minutes, so that it doesn't become obnoxious") (SETQ WAITINTERVAL.secs (IMIN (LLSH WAITINTERVAL.secs 1) (TIMES 2 60)))) (GO NEXTROUND)))
)
(\REMOTE.BIN
(CL:LAMBDA (STREAM) (* ; "Edited 30-Oct-87 10:47 by Masinter") (CL:MACROLET ((REALBIN NIL (QUOTE (CL:FUNCALL (FETCH (FDEV BIN) (fetch (STREAM DEVICE) STREAM)) STREAM))) (CLR NIL (QUOTE (while (READP STREAM) do (REALBIN))))) (PROG (CH) RETRY (SELCHARQ (SETQ CH (REALBIN)) (↑E (CLR) (ERROR!)) (↑D (CLR) (RESET)) (↑B (CLR) (\DOHELPINTERRUPT1) (GO RETRY)) (↑T (PROG ((CNT 0)) (FRESHLINE T) (BACKTRACE -2 T NIL T (FUNCTION (LAMBDA (X) (PRIN1 (if (EQ CNT 0) then "Running in " else " in ") T) (CL:PRIN1 X *TERMINAL-IO*) (if (IGEQ (add CNT 1) 5) then (RETURN NIL))))) (FRESHLINE T)) (GO RETRY)) NIL) (RETURN CH))))
)
(\REMOTE.EXEC.OUTCHARFN
(LAMBDA (STREAM CHARCODE) (* ; "Edited 11-Oct-87 23:17 by Masinter") (* ; "OUTCHARFN for standard files") (SELECTC (ffetch CCECHO of (\SYNCODE \PRIMTERMSA CHARCODE)) (INDICATE.CCE (* ; "Make sure that all the chars in the indicate-string fit on the line or wrap-around together.") (CL:MAP NIL (CL:FUNCTION (LAMBDA (CH) (CL:WRITE-CHAR CH STREAM) (CL:INCF (ffetch CHARPOSITION of STREAM)))) (\INDICATESTRING CHARCODE))) (IGNORE.CCE) (PROGN (if (EQ CHARCODE ERASECHARCODE) then (BOUT STREAM (CHARCODE ↑H)) (BOUT STREAM (CHARCODE SPACE)) (BOUT STREAM (CHARCODE ↑H)) (add (fetch CHARPOSITION of STREAM) -1) else (SELCHARQ CHARCODE ((EOL CR LF) (BLOCK) (COND ((OR (EQ \CURRENTDISPLAYLINE -1) (AND (SMALLP \CURRENTDISPLAYLINE) (EQ \#DISPLAYLINES (SETQ \CURRENTDISPLAYLINE (ADD1 \CURRENTDISPLAYLINE))))) (SETQ \CURRENTDISPLAYLINE 0) (LET ((KEYSTREAM (fetch (LINEBUFFER KEYBOARDSTREAM) of \LINEBUF.OFD))) (COND ((READP KEYSTREAM)) (T (PRIN1 \STOPSCROLLMESSAGE STREAM) (SELCHARQ (BIN KEYSTREAM) (↑B (INTERRUPT)) (↑E (ERROR!)) NIL) (* ; "Now erase the message") (FRPTQ (NCHARS \STOPSCROLLMESSAGE) (\REMOTE.EXEC.OUTCHARFN STREAM ERASECHARCODE)) (BLOCK)))))) (BOUT STREAM (SELECTC (ffetch EOLCONVENTION of STREAM) (CR.EOLC (CHARCODE CR)) (LF.EOLC (CHARCODE LF)) (CRLF.EOLC (* ;; "The CRLF is EOL only if the bytes are immediately adjacent in the stream, with no additional encoding bytes") (BOUT STREAM (CHARCODE CR)) (CHARCODE LF)) (SHOULDNT))) (freplace CHARPOSITION of STREAM with 0)) (ESCAPE (BOUT STREAM (CHARCODE $)) (add (ffetch CHARPOSITION of STREAM) 1)) (TAB (SPACES (DIFFERENCE 8 (IMOD (POSITION) 8)) STREAM)) (PROGN (BOUT STREAM CHARCODE) (add (ffetch CHARPOSITION of STREAM) 1)))))) CHARCODE)
)
(CHATSERVER.FONT
(LAMBDA (STREAM FONT) (* lmm "20-Nov-86 00:01") (SELECTQ DISPLAYTERMFLG (DM (COND ((OR (EQ BOLDFONT FONT) (EQ FONT LAMBDAFONT)) (BOUT STREAM (CHARCODE ↑N))) (T (BOUT STREAM (CHARCODE ↑X)) (BOUT STREAM (CHARCODE "↑]"))))) NIL))
)
)
(RPAQQ DISPLAYTERMFLG DM)
(SETQ CHATSERVERTTBL (COPYTERMTABLE (QUOTE ORIG)))
(for I from 1 to 8 do (ECHOCHAR I (QUOTE IGNORE) CHATSERVERTTBL) (ECHOCHAR I (QUOTE IGNORE) ASKUSERTTBL))
(ECHOCHAR (CHARCODE CR) (QUOTE SIMULATE) CHATSERVERTTBL)
(ECHOCHAR (CHARCODE CR) (QUOTE SIMULATE) ASKUSERTTBL)
(ECHOCHAR 0 (QUOTE SIMULATE) ASKUSERTTBL)
(ECHOCHAR 0 (QUOTE SIMULATE) CHATSERVERTTBL)
(RPAQ? CHATSERVER.PROFILE )
(RPAQ? \SIMPLEIMAGEOPS )
(ADDTOVAR \SWEPT.OFDS )
(DECLARE%: EVAL@COMPILE DONTCOPY
(FILESLOAD (LOADCOMP) LLCHAR ATERM IMAGEIO FILEIO ATBL)
)
(DEFINEQ
(SIMPLECHATSERVER
(LAMBDA (INSTREAM OUTSTREAM) (* ; "Edited 6-Oct-87 14:37 by Masinter") (if NIL then (PRINTOUT OUTSTREAM "Simple chat echo service") (do (\OUTCHAR OUTSTREAM (BIN INSTREAM))) else (PROG ((WINDOW (OR CHATSERVERWINDOW (SETQ CHATSERVERWINDOW (CREATEW CHATSERVERWINDOWREGION "Chat Listener")))) (KEYSTREAM \KEYBOARD.STREAM) MYSTREAM) (printout OUTSTREAM "Xerox Lisp Chat echo service" T) (CLEARW WINDOW) (SETQ MYSTREAM (GETSTREAM WINDOW (QUOTE OUTPUT))) (WINDOWPROP WINDOW (QUOTE CLOSEFN) (FUNCTION (LAMBDA (W) (SETQ SIMPLECHATSERVERDONE T) (AND (OPENWP W) (WINDOWPROP W (QUOTE TITLE) "Connection closed"))))) (WINDOWPROP WINDOW (QUOTE PROCESS) (THIS.PROCESS)) (bind CH do (while (READP INSTREAM) do (\OUTCHAR OUTSTREAM (SETQ CH (BIN INSTREAM))) (\OUTCHAR MYSTREAM CH)) (BLOCK) (while (READP KEYSTREAM) do (\OUTCHAR OUTSTREAM (SETQ CH (BIN KEYSTREAM))) (\OUTCHAR MYSTREAM CH)) (if (EQ (TTY.PROCESS) (THIS.PROCESS)) then (\TTYBACKGROUND) else (BLOCK))) (printout MYSTREAM T T "Connection closed" T) (WINDOWPROP WINDOW (QUOTE TITLE) "Connection closed") (WINDOWPROP WINDOW (QUOTE CLOSEFN) NIL))) (* ;;; "The following isn't executed"))
)
)
(RPAQ? CHATSERVERWINDOW )
(RPAQ? CHATSERVERWINDOWREGION (QUOTE (11 228 392 190)))
(DECLARE%: EVAL@COMPILE
(PROGN (PUTPROPS \SYNCODE DMACRO (OPENLAMBDA (TABLE CHAR) (CHECK (type? CHARTABLE TABLE)) (* ; "0 is either NONE.TC, REAL.CCE, or OTHER.RC") (COND ((IGREATERP CHAR \MAXTHINCHAR) (OR (AND (fetch (CHARTABLE NSCHARHASH) of TABLE) (GETHASH CHAR (fetch (CHARTABLE NSCHARHASH) of TABLE))) 0)) (T (\GETBASEBYTE TABLE CHAR))))) (PUTPROPS \SYNCODE MACRO (OPENLAMBDA (TABLE CHAR) (CHECK (type? CHARTABLE TABLE)) (* ; "0 is either NONE.TC, REAL.CCE, or OTHER.RC") (COND ((IGREATERP CHAR \MAXTHINCHAR) (OR (AND (fetch (CHARTABLE NSCHARHASH) of TABLE) (GETHASH CHAR (fetch (CHARTABLE NSCHARHASH) of TABLE))) 0)) (T (\GETBASEBYTE TABLE CHAR))))))
)
(XCL:REINSTALL-ADVICE (QUOTE (MENU :IN INSTALL-PROTOTYPE-DEFN)) :BEFORE (QUOTE ((:LAST (OR (DISPLAYSTREAMP \TERM.OFD) (RETURN (ASKUSER NIL NIL (FETCH (MENU TITLE) MENU) (MAPCAR (FETCH (MENU ITEMS) MENU) (FUNCTION (LAMBDA (X) (COND ((LISTP X) (LIST (CAR X) "" (QUOTE RETURN) (CADR X))) (T X))))))))))))
(READVISE (MENU :IN INSTALL-PROTOTYPE-DEFN))
(DEFCOMMAND "QUIT" NIL (RETFROM (QUOTE CHATSERVEROPENFN)))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA \REMOTE.BIN CHATSERVEROPENFN)
)
(PUTPROPS CHATSERVER COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1769 11179 (CHATSERVER 1779 . 2507) (CHATSERVERWHENCLOSEDFN 2509 . 2782) (
CHATSERVEROPENFN 2784 . 4476) (DOBE 4478 . 4519) (REQUIRED.LOGIN 4521 . 6039) (RINGBELLS 6041 . 6436)
(SERVER-EXEC 6438 . 6559) (SWEEP.OFD 6561 . 6820) (\CLEARSYSBUF 6822 . 7001) (\PROMPTFORWORDBIN 7003
. 8574) (\REMOTE.BIN 8576 . 9202) (\REMOTE.EXEC.OUTCHARFN 9204 . 10926) (CHATSERVER.FONT 10928 .
11177)) (11750 12914 (SIMPLECHATSERVER 11760 . 12912)))))
STOP