(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)

(FILECREATED " 7-Sep-88 17:08:57" {ERINYES}<LISPUSERS>MEDLEY>CHATSERVER.;11
 47957  

      changes to%:  (FNS CHATSERVEROPENFN)

      previous date%: "19-May-88 00:37:49" {ERINYES}<LISPUSERS>MEDLEY>CHATSERVER.;10)


(* "
Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT CHATSERVERCOMS)

(RPAQQ CHATSERVERCOMS

       [(FNS CHATSERVER CHATSERVERWHENCLOSEDFN CHATSERVEROPENFN DOBE REQUIRED.LOGIN SERVER-EXEC 
             SWEEP.OFD \CLEARSYSBUF PROMPTFORWORD \CREATELINEBUFFER \PROMPTFORWORDBIN \REMOTE.BIN 
             \REMOTE.EXEC.OUTCHARFN CHATSERVER.FONT)
        (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (DISPLAYTERMFLG 'DM))
               (INITVARS (CHATSERVER.PROFILE)
                      (\SIMPLEIMAGEOPS))
               (P (SETQ CHATSERVERTTBL (COPYTERMTABLE 'ORIG))
                  (for I from 1 to 8 do (ECHOCHAR I 'IGNORE CHATSERVERTTBL)
                       (ECHOCHAR I 'IGNORE ASKUSERTTBL))
                  (ECHOCHAR (CHARCODE CR)
                         'SIMULATE CHATSERVERTTBL)
                  (ECHOCHAR (CHARCODE CR)
                         'SIMULATE ASKUSERTTBL)
                  (ECHOCHAR 0 'SIMULATE ASKUSERTTBL)
                  (ECHOCHAR 0 'SIMULATE CHATSERVERTTBL)))
        (ADDVARS (\SWEPT.OFDS))
        (DECLARE%: EVAL@COMPILE DONTCOPY (P (CHECKIMPORTS '(LLCHAR ATERM IMAGEIO FILEIO ATBL AOFD)
                                                   T)))
        [COMS (FNS SIMPLECHATSERVER)
              (INITVARS (CHATSERVERWINDOW)
                     (CHATSERVERWINDOWREGION '(11 228 392 190]
        (MACROS \SYNCODE)
        (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES CL-TTYEDIT SIMPLECHAT)
               (ADVISE MENU CHAT RINGBELLS))
        (COMMANDS "QUIT" "SAY")
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA \REMOTE.BIN 
                                                                                   CHATSERVEROPENFN])
(DEFINEQ

(CHATSERVER

  [LAMBDA NIL
                                            (* ; "Edited 18-May-88 23:56 by amd")

    (PROMPTPRINT "Remote CHAT connection attempted")
    (PRINTOUT T "Remote " HERALDSTRING T T)
    (CL:UNWIND-PROTECT [COND
                          ((AND (LISTGET CHATSERVER.PROFILE '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")
                                 (PRINTOUT T (IF
 \IDLING
                                                 THEN
 "[Idling, "
                                               ELSE
 "[Not in Idle, ")
                                        "last user action "
                                        (GDATE (ALTO.TO.LISP.DATE \LASTUSERACTION))
                                        "]" T)
                                 (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 'SERVER.PROCESS]
         (AND PROC (FIND.PROCESS PROC)
              (DEL.PROCESS PROC])

(CHATSERVEROPENFN

  [CL:LAMBDA (*KEYBOARD-STREAM* OUTSTREAM)
            (* ; "Edited  2-Sep-88 23:36 by masinter")


         (* ;; "code common to all chat servers")


         (CL:UNWIND-PROTECT
             [PROGN (LINELENGTH 80 OUTSTREAM)
                    (PAGEHEIGHT 24 OUTSTREAM)
                    (STREAMPROP *KEYBOARD-STREAM* 'SERVER.PROCESS (THIS.PROCESS))
                    (STREAMPROP *KEYBOARD-STREAM* 'AFTERCLOSE 'CHATSERVERWHENCLOSEDFN)
                    (STREAMPROP OUTSTREAM 'SERVER.PROCESS (THIS.PROCESS))
                    (STREAMPROP OUTSTREAM 'AFTERCLOSE 'CHATSERVERWHENCLOSEDFN)
                    [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)
                        (DEL.PROCESS 'SWEEP.OFD)
                        (ADD.PROCESS '(SWEEP.OFD
]
                    [OR \SIMPLEIMAGEOPS (SETQ \SIMPLEIMAGEOPS (create
 IMAGEOPS
                                                                 using
 \NOIMAGEOPS IMFONT _
                                                                       '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
 '\REMOTE.BIN)
                      elseif
 (NOT (EQ (fetch
 (STREAM STRMBINFN) of
 *KEYBOARD-STREAM*)
                                          '\REMOTE.BIN))
                        then
 (PRINTOUT OUTSTREAM "[Interrupts not enabled]" T))
                    (LET* ((BUFFERED (\CREATELINEBUFFER
 *KEYBOARD-STREAM*))
                           (\TERM.OFD OUTSTREAM)
                           (*STANDARD-OUTPUT* \TERM.OFD)
                           (\LINEBUF.OFD BUFFERED)
                           (*STANDARD-INPUT* \LINEBUF.OFD)
                           (*TRACE-OUTPUT* *STANDARD-OUTPUT*))
                          (DECLARE
 (CL:SPECIAL PROMPTWINDOW \TERM.OFD *STANDARD-OUTPUT* 
                                              \LINEBUF.OFD *STANDARD-INPUT*))
                          (HANDLER-BIND [(XCL:STREAM-NOT-OPEN
                                          (FUNCTION (LAMBDA (COND)
                                                      (IF
 (FMEMB (XCL:STREAM-NOT-OPEN-STREAM
                                                                      COND)
                                                                     (LIST OUTSTREAM INSTREAM
                                                                           (FULLNAME OUTSTREAM)
                                                                           (FULLNAME INSTREAM)))
                                                          THEN
 (RESET) 
                                                             (* ; " abort")

                                                        ELSE
 NIL 
                                                             (* ; "ignore")
]
                                 (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 'ALLOWED.LOGINS))
           (AUTHTYPE (LISTGET PROFILE 'AUTHENTICATE))
           (NAME (USERNAME NIL NIL T))
           PWD)
          (COND
             ((NLISTP GROUP)                                 (* ; "no login check at all")

              (COND
                 ((LISTGET PROFILE '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 '(T))
                   NAME)                                     (* ; 

                                                           "Only previous user allowed to login")

              (SETQ PWD (PROMPTFORWORD
 (CONCAT NAME " password:")
                               NIL NIL NIL '*]
             (T [SETQ NAME (PROMPTFORWORD
 "Login (<return> to terminate): " NAME NIL T NIL T
                                  (CHARCODE (CR LF]
                (if
 (MEMBER NAME '("Logon" "ogon"))
                    then
 (GO CLEAR))
                (SETQ PWD (PROMPTFORWORD
 " (password) " NIL NIL T '*))
                (TERPRI T)))
          (if
 (EQUAL PWD "Logon")
              then
 (GO CLEAR))
          (RETURN (COND
                     ((NULL PWD)
                      NIL)
                     ([AND (OR (MEMB T GROUP)
                               (MEMB '* GROUP))
                           (\IDLE.IS.PREVIOUS NAME PWD (EQUAL GROUP '(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 'FORGET)
                                      (SETPASSWORD NIL NAME PWD))
                                 (SETQ \IDLE.PASSWORD.SET T)
                                 T))
                             (TERPRI T)))
                     (T (PRINTOUT T "login incorrect" T)
                        NIL])

(SERVER-EXEC

  [LAMBDA NIL
                                         (* ; "Edited  6-Oct-87 16:37 by Masinter")

    (\CALLME '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 '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])

(PROMPTFORWORD

  [LAMBDA (PROMPT.STR CANDIDATE.STR GENERATE?LIST.FN ECHO.CHANNEL DONTECHOTYPEIN.FLG URGENCY.OPTION 
                 TERMINCHARS.LST KEYBD.CHANNEL)
          (* lmm "16-Jan-86 18:07")

    (DECLARE
 (SPECVARS TERMINCHARS.LST ECHO.CHANNEL DONTECHOTYPEIN.FLG))
    [COND
       ((NOT (TERMTABLEP \PROMPTFORWORDTTBL))                (* ; 

                                     "Initializes the special readtable on the first time through.")

        (SETQ \PROMPTFORWORDTTBL (bind
 (TTBL _ (COPYTERMTABLE 'ORIG)) for
 CHAR from

                                                                                       0 to

                                                                                         31
                                    do
 (SELCHARQ CHAR
                                                ((EOL ESCAPE SPACE LF TAB))
                                                (ECHOCHAR CHAR 'INDICATE TTBL))
                                    finally
 (PROGN (ECHOMODE NIL TTBL)
                                                       (CONTROL T TTBL)
                                                       (RETURN TTBL]
    (RESETLST
     (RESETSAVE (SETTERMTABLE \PROMPTFORWORDTTBL))
     (PROG ([CHARBUFFER (COND
                           (CANDIDATE.STR (DREVERSE (CHCON CANDIDATE.STR]
            TTYD X0Y0 TIMELIMITEXPIRED? BELLBEENHEARD? CANDIDATATE.LENGTH CHAR BEGUNTYPING? RUBBING? 
            ?HELPMSGTRIEDP ?HELPMSGLIST TIMER)
           (DECLARE
 (SPECVARS TTYD X0Y0 TIMELIMITEXPIRED? BELLBEENHEARD? CHARBUFFER RUBBING?))
           [COND
              [(EQMEMB 'TTY URGENCY.OPTION)                  (* ; 

  "If we're going to switch the TTY process, better do it before looking for TTYDISPLAYSTREAM etc.")

               [OR (TTY.PROCESSP)
                   (RESETSAVE (TTY.PROCESS (THIS.PROCESS]
               (AND \PROMPTFORWORD.CURSOR (RESETSAVE (CURSOR \PROMPTFORWORD.CURSOR]
              (T (OR (FIXP URGENCY.OPTION)
                     (SELECTQ URGENCY.OPTION
                         ((NIL T) 
                              T)
                         NIL)
                     (\ILLEGAL.ARG URGENCY.OPTION]
           (SETQ ECHO.CHANNEL (GETSTREAM (OR ECHO.CHANNEL T)
                                     'OUTPUT))               (* ; "Normalize the echo channel.")

           (CL:WHEN (SETQ TTYD (DISPLAYSTREAMP ECHO.CHANNEL))
                  (RESETSAVE (TTYDISPLAYSTREAM ECHO.CHANNEL)))
           [COND
              ((AND DONTECHOTYPEIN.FLG (NEQ DONTECHOTYPEIN.FLG T))
               (SETQ DONTECHOTYPEIN.FLG (COND
                                           ((EQ (NCHARS DONTECHOTYPEIN.FLG)
                                                1)
                                            (NTHCHARCODE DONTECHOTYPEIN.FLG 1))
                                           (T T]
           (COND
              [(NULL TERMINCHARS.LST)
               (SETQ TERMINCHARS.LST (CHARCODE (EOL ESCAPE SPACE LF TAB]
              ((CHARCODEP TERMINCHARS.LST)
               (SETQ TERMINCHARS.LST (LIST TERMINCHARS.LST)))
              ([OR (NLISTP TERMINCHARS.LST)
                   (for
 C in
 TERMINCHARS.LST bind
 CONVERTIBLEP unless
 (CHARCODEP
                                                                                       C)
                      do
 (COND
                                ((AND (OR (LITATOM C)
                                          (STRINGP C))
                                      (EQ 1 (NCHARS C)))
                                 (SETQ CONVERTIBLEP T))
                                (T (RETURN T)))
                      finally
 (COND
                                     (CONVERTIBLEP           (* ; 

                                       "List not all charcodes, but all are at least charcode like")

                                            (SETQ TERMINCHARS.LST (MAPCAR TERMINCHARS.LST
                                                                         (FUNCTION (LAMBDA (C)
                                                                                     (OR (FIXP C)
                                                                                         (CHCON1
                                                                                          C]
               (\ILLEGAL.ARG TERMINCHARS.LST)))
           [COND
              (KEYBD.CHANNEL (SETQ KEYBD.CHANNEL (\INSTREAMARG KEYBD.CHANNEL]
           [COND
              (URGENCY.OPTION (SETQ TIMER (SETUPTIMER (OR (FIXP URGENCY.OPTION)
                                                          0)
                                                 NIL
                                                 'SECONDS]
(* ;;; "Now ready to begin.  Print the prompt, gather input")


       PROMPTAGAIN
           (COND
              (PROMPT.STR (PRIN3 PROMPT.STR ECHO.CHANNEL)
                     (PRIN3 " " ECHO.CHANNEL)))
           [COND
              (TTYD (SETQ X0Y0 (create
 POSITION
                                      XCOORD _ (DSPXPOSITION NIL TTYD)
                                      YCOORD _ (DSPYPOSITION NIL TTYD]
           (COND
              (CHARBUFFER 
          (* ;; "If there is input, e.g.  the candidate string, echo it.  This is the one place calling \PROMPTFORWORDRETYPE that doesn't want the line erased first.")


                     (\PROMPTFORWORDRETYPE)))
           [until
 (OR (NULL (SETQ CHAR (\PROMPTFORWORDBIN
 KEYBD.CHANNEL TTYD URGENCY.OPTION 
                                                  TIMER)))
                          (FMEMB CHAR TERMINCHARS.LST))
              do
 (COND
                        ((SELECTQ (GETSYNTAX CHAR \PROMPTFORWORDTTBL)
                             (CHARDELETE (COND
                                            (CHARBUFFER (SETQ BEGUNTYPING? T)
                                                   (\PROMPTFORWORDBS))
                                            (T (SETQ RUBBING?)))
                                         NIL)
                             (LINEDELETE (COND
                                            (CHARBUFFER (COND
                                                           ((NEQ DONTECHOTYPEIN.FLG T)
                                                            (\PROMPTFORWORDERASE)))
                                                   (SETQ BEGUNTYPING? T)
                                                   (SETQ CHARBUFFER))
                                            (T (SETQ RUBBING?)))
                                         NIL)
                             (RETYPE (COND
                                        (CHARBUFFER (COND
                                                       ((NEQ DONTECHOTYPEIN.FLG T)
                                                        (\PROMPTFORWORDERASE)))
                                               (\PROMPTFORWORDRETYPE))
                                        (T (SETQ RUBBING?)))
                                     NIL)
                             (WORDDELETE (COND
                                            [CHARBUFFER (SETQ BEGUNTYPING? T)
                                                   (bind
 (SPACEP _ (SYNTAXP (CAR CHARBUFFER)
                                                                              'WORDSEPR 
                                                                              \PROMPTFORWORDTTBL))
                                                      do
 (\PROMPTFORWORDBS)
                                                            (COND
                                                               ((NULL CHARBUFFER)
                                                                (RETURN)))
                                                            (SETQ CHAR (CAR CHARBUFFER))
                                                            (COND
                                                               [(NOT SPACEP)
                                                                (COND
                                                                   ((SYNTAXP CHAR 'WORDSEPR 
                                                                           \PROMPTFORWORDTTBL)
                                                                    (RETURN]
                                                               ((NOT (SYNTAXP CHAR 'WORDSEPR 
                                                                            \PROMPTFORWORDTTBL))
                                                                (SETQ SPACEP NIL]
                                            (T (SETQ RUBBING?)))
                                         NIL)
                             (CNTRLV (COND
                                        ((NOT DONTECHOTYPEIN.FLG)
          (* ;; "Well, so echo the ^V SO THAT THE LOSER CAN SEE THAT HE'S IN THE STATE OF WAITING FOR THE NEXT CHARACTER AFTER A ^V")


                                         (COND
                                            ((AND RUBBING? (NOT TTYD))
                                             (BOUT ECHO.CHANNEL (CHARCODE \))
                                             (SETQ RUBBING?)))
                                         (PRIN3 (CHARACTER CHAR)
                                                ECHO.CHANNEL)))
                                     (COND
                                        ((NULL (SETQ CHAR (\PROMPTFORWORDBIN
 KEYBD.CHANNEL TTYD 
                                                                 URGENCY.OPTION TIMER T)))
                                         (RETURN T)))
                                     (COND
                                        ((AND TTYD (NOT DONTECHOTYPEIN.FLG)
                                              (NULL (DSPRUBOUTCHAR TTYD CHAR)))
          (* ;; "Well, we tried to erase the ^V so that the typed-in charcter could be echoed, but apparently the ^V was split between lines.")


                                         (\PROMPTFORWORDERASE)
                                         (\PROMPTFORWORDRETYPE)))
                                     T)
                             (COND
                                ((EQ CHAR (CHARCODE ?))
                                 (FRESHLINE ECHO.CHANNEL)
                                 [COND
                                    ((AND GENERATE?LIST.FN (NOT ?HELPMSGTRIEDP))
                                     (SETQ ?HELPMSGLIST (OR (STRINGP GENERATE?LIST.FN)
                                                            (APPLY* GENERATE?LIST.FN PROMPT.STR 
                                                                   CANDIDATE.STR)))
                                     (SETQ ?HELPMSGTRIEDP T))
                                    ((NOT ?HELPMSGTRIEDP)
                                     (SETQ ?HELPMSGLIST '??]
                                 (COND
                                    ((LISTP ?HELPMSGLIST)
                                     (PRIN3 '{ ECHO.CHANNEL)
                                     (PRIN3 (CONSTANT (CHARACTER (CHARCODE SPACE)))
                                            ECHO.CHANNEL)
                                     [MAPC ?HELPMSGLIST (FUNCTION (LAMBDA (X)
                                                                    (PRIN1 X ECHO.CHANNEL)
                                                                    (PRIN3 (CONSTANT
                                                                            (CHARACTER (CHARCODE
                                                                                        SPACE)))
                                                                           ECHO.CHANNEL]
                                     (PRIN3 '} ECHO.CHANNEL))
                                    (T (PRIN1 ?HELPMSGLIST ECHO.CHANNEL)
                                                             (* ; 

                   "FOO we'd really like this FRESHLINE to be just a MOVETO some initial position.")

                                       ))
                                 (FRESHLINE ECHO.CHANNEL)
                                 (GO PROMPTAGAIN))
                                (T T)))                      (* ; 

   "If the SELCHARQ does't select out any of its 'special' characters, then just fall through here")

                         (COND
                            ((AND (NOT BEGUNTYPING?)
                                  CHARBUFFER)
          (* ;; "This is the case of the CANDIDATE.STR having been proffered, but the user starts typing something else.")


                             (COND
                                ((EQ CHAR (CHARCODE SPACE))
          (* ;; "Special kludge for benefit of those with old space-terminating habits: If there is a candidate string, and the first thing you do is type a space, then the space terminates even if it isn't a member of TERMINCHARS.LST")


                                 (RETURN)))
                             (COND
                                ((NOT DONTECHOTYPEIN.FLG)    (* ; 

                                          "Don't need to do anything if type-in isn't being echoed")

                                 (\PROMPTFORWORDERASE)))
                             (SETQ CHARBUFFER)))
                         (push
 CHARBUFFER CHAR)
                         (SETQ BEGUNTYPING? T)
                         (COND
                            ((NEQ DONTECHOTYPEIN.FLG T)      (* ; 

                                                    "Well, so echo the typed-in character already!")

                             (COND
                                ((AND RUBBING? (NOT TTYD))
                                 (PRIN3 '\ ECHO.CHANNEL)
                                 (SETQ RUBBING?)))
                             (BOUT ECHO.CHANNEL (OR DONTECHOTYPEIN.FLG CHAR]
           [SETQ CHARBUFFER (COND
                               [TIMELIMITEXPIRED?            (* ; 

                                                           "Ha, we overflowed the time limit.")

                                      (COND
                                         (CANDIDATE.STR (CONCAT CANDIDATE.STR]
                               (CHARBUFFER (CONCATCODES (DREVERSE CHARBUFFER]
           (\CARET.DOWN ECHO.CHANNEL)
           (RETURN CHARBUFFER])

(\CREATELINEBUFFER

  [LAMBDA (TERMINAL.STREAM)
                              (* ; "Edited 13-Apr-87 22:57 by bvm:")

          (* ;; 

   "Create a new stream that buffers the raw input from TERMINAL.STREAM (default is the keyboard).")


    (LET* ([STREAM (\OPENFILE '{LINEBUFFER} 'BOTH 'NEW '((CHARSET T]
           (DEV (fetch
 (STREAM DEVICE) of
 STREAM))
           EOFMETHOD)
          (replace
 LINEBUFSTATE of
 STREAM with
 READING.LBS)
          (replace
 (LINEBUFFER KEYBOARDSTREAM) of
 STREAM with
 (OR TERMINAL.STREAM 
                                                                              \KEYBOARD.STREAM))
          (replace
 USERCLOSEABLE of
 STREAM with
 NIL)
          (replace
 USERVISIBLE of
 STREAM with
 NIL)
                                                             (* ; 

                                                         "Other linebuffer fields default properly")

          [replace
 ENDOFSTREAMOP of
 STREAM with
 (FUNCTION (LAMBDA (STREAM)
                                                                        (CL:FUNCALL \RefillBufferFn]
          (if
 (AND TERMINAL.STREAM (NEQ (SETQ EOFMETHOD (fetch
 (FDEV EOFP)
                                                               of
 (fetch
 (STREAM DEVICE)
                                                                             TERMINAL.STREAM)))
                                            'NILL))
              then
 
          (* ;; "Need to install an eof method for the buffered stream that looks at TERMINAL.STREAM when the buffer runs out.  This is optimized away for the normal keyboard case, which never runs out.")


                    (replace
 (STREAM DEVICE) of
 STREAM with
 (SETQ DEV (NCREATE
                                                                                   'FDEV DEV))) 
                                                             (* ; 

                                                           "Copy the basic linebuffer device")

                    (replace
 (FDEV EOFP) of
 DEV with
 EOFMETHOD))
          STREAM])

(\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 '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 '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 '(CL:FUNCALL (FETCH
 (FDEV BIN)
                                                        (fetch
 (STREAM DEVICE)
                                                               STREAM))
                                            STREAM))
                       (CLR NIL '(while
 (READP STREAM) do
 (REALBIN]
                (PROG (CH)
                  RETRY
                      (SELCHARQ (SETQ CH (REALBIN))
                           (^E (CLR)
                               (ERROR!))
                           (^D (CLR)
                               (RESET))
                           (^B (CLR)
                               (\DOHELPINTERRUPT1)
                               (GO RETRY))
                           (^T (CL:CATCH 'DONE (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

                                                                            (CL:THROW 'DONE 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 #'[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])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(RPAQQ DISPLAYTERMFLG
 DM)


(RPAQ? CHATSERVER.PROFILE
 )

(RPAQ? \SIMPLEIMAGEOPS
 )


(SETQ CHATSERVERTTBL (COPYTERMTABLE 'ORIG))

(for
 I from
 1 to
 8 do
 (ECHOCHAR I 'IGNORE CHATSERVERTTBL)
                                     (ECHOCHAR I 'IGNORE ASKUSERTTBL))

(ECHOCHAR (CHARCODE CR)
       'SIMULATE CHATSERVERTTBL)

(ECHOCHAR (CHARCODE CR)
       'SIMULATE ASKUSERTTBL)

(ECHOCHAR 0 'SIMULATE ASKUSERTTBL)

(ECHOCHAR 0 'SIMULATE CHATSERVERTTBL)
)

(ADDTOVAR \SWEPT.OFDS
 )
(DECLARE%: EVAL@COMPILE DONTCOPY 

(CHECKIMPORTS '(LLCHAR ATERM IMAGEIO FILEIO ATBL AOFD)
       T)
)
(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 'OUTPUT))
                     [WINDOWPROP WINDOW 'CLOSEFN (FUNCTION (LAMBDA (W)
                                                             (SETQ SIMPLECHATSERVERDONE T)
                                                             (AND (OPENWP W)
                                                                  (WINDOWPROP W 'TITLE 
                                                                         "Connection closed"]
                     (WINDOWPROP WINDOW '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 'TITLE "Connection closed")
                     (WINDOWPROP WINDOW 'CLOSEFN NIL)))
(* ;;; "The following isn't executed")


    ])
)

(RPAQ? CHATSERVERWINDOW
 )

(RPAQ? CHATSERVERWINDOWREGION
 '(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))
                                               (COND
                                                  ((IGREATERP CHAR \MAXTHINCHAR)
                                                   (OR (AND (fetch
 (CHARTABLE NSCHARHASH)
                                                               of
 TABLE)
                                                            (GETHASH CHAR (fetch
 (CHARTABLE
                                                                                      NSCHARHASH)
                                                                             of
 TABLE)))
                                                       0))
                                                  (T (\GETBASEBYTE TABLE CHAR])]
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(FILESLOAD CL-TTYEDIT SIMPLECHAT)


[XCL:REINSTALL-ADVICE 'MENU :BEFORE
       '((:LAST (OR (DISPLAYSTREAMP \TERM.OFD)
                    (RETURN (ASKUSER NIL NIL (OR (FETCH
 (MENU TITLE)
                                                        MENU)
                                                 "Menu choice:")
                                   (MAPCAR (FETCH
 (MENU ITEMS)
                                                  MENU)
                                          (FUNCTION (LAMBDA (X)
                                                      (COND
                                                         ((LISTP X)
                                                          (LIST (CAR X)
                                                                ""
                                                                'RETURN
                                                                (CADR X)))
                                                         (T X]

[XCL:REINSTALL-ADVICE 'CHAT :BEFORE '((:LAST (AND (NOT WINDOW)
                                                  (NOT FROMMENU)
                                                  (NOT (DISPLAYSTREAMP (TTYDISPLAYSTREAM)))
                                                  (RETURN (TTYCHAT HOST LOGOPTION]

[XCL:REINSTALL-ADVICE 'RINGBELLS :BEFORE '((:LAST (OR (WFROMDS \TERM.OFD)
                                                      (RETURN (RPTQ (OR (FIXP N)
                                                                        1)
                                                                    (BOUT \TERM.OFD 7]

(READVISE MENU CHAT RINGBELLS)
)

(DEFCOMMAND "QUIT"
 ()
   (RETFROM 'CHATSERVEROPENFN))

(DEFCOMMAND "SAY"
 (&REST LINE)
   [MAPC \PROCESSES (FUNCTION (LAMBDA (PROC)
                                (CL:WHEN (STRPOS "CHAT.SERVER" (PROCESS.NAME PROC))
                                    (MAPRINT LINE (IF
 (EQ PROC (THIS.PROCESS))
                                                      THEN
 *STANDARD-OUTPUT*
                                                    ELSE
 (EVALV '*STANDARD-OUTPUT* PROC))
                                           "
" "
"))]
   (MAPRINT LINE PROMPTWINDOW "
" "
")
   (CL:VALUES))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 \REMOTE.BIN CHATSERVEROPENFN)
)
(PRETTYCOMPRINT CHATSERVERCOMS)

(RPAQQ CHATSERVERCOMS

       [(FNS CHATSERVER CHATSERVERWHENCLOSEDFN CHATSERVEROPENFN DOBE REQUIRED.LOGIN SERVER-EXEC 
             SWEEP.OFD \CLEARSYSBUF PROMPTFORWORD \CREATELINEBUFFER \PROMPTFORWORDBIN \REMOTE.BIN 
             \REMOTE.EXEC.OUTCHARFN CHATSERVER.FONT)
        (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (DISPLAYTERMFLG 'DM))
               (INITVARS (CHATSERVER.PROFILE)
                      (\SIMPLEIMAGEOPS))
               (P (SETQ CHATSERVERTTBL (COPYTERMTABLE 'ORIG))
                  (for I from 1 to 8 do (ECHOCHAR I 'IGNORE CHATSERVERTTBL)
                       (ECHOCHAR I 'IGNORE ASKUSERTTBL))
                  (ECHOCHAR (CHARCODE CR)
                         'SIMULATE CHATSERVERTTBL)
                  (ECHOCHAR (CHARCODE CR)
                         'SIMULATE ASKUSERTTBL)
                  (ECHOCHAR 0 'SIMULATE ASKUSERTTBL)
                  (ECHOCHAR 0 'SIMULATE CHATSERVERTTBL)))
        (ADDVARS (\SWEPT.OFDS))
        (DECLARE%: EVAL@COMPILE DONTCOPY (P (CHECKIMPORTS '(LLCHAR ATERM IMAGEIO FILEIO ATBL AOFD)
                                                   T)))
        [COMS (FNS SIMPLECHATSERVER)
              (INITVARS (CHATSERVERWINDOW)
                     (CHATSERVERWINDOWREGION '(11 228 392 190]
        (MACROS \SYNCODE)
        (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES CL-TTYEDIT SIMPLECHAT)
               (ADVISE MENU CHAT RINGBELLS))
        (COMMANDS "QUIT" "SAY")
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA CHATSERVEROPENFN])
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 CHATSERVEROPENFN)
)
(PUTPROPS CHATSERVER COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987 1988))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2216 38509 (CHATSERVER 2226 . 3955) (CHATSERVERWHENCLOSEDFN 3957 . 4304) (
CHATSERVEROPENFN 4306 . 8433) (DOBE 8435 . 8481) (REQUIRED.LOGIN 8483 . 11220) (SERVER-EXEC 11222 . 
11395) (SWEEP.OFD 11397 . 11933) (\CLEARSYSBUF 11935 . 12184) (PROMPTFORWORD 12186 . 26531) (
\CREATELINEBUFFER 26533 . 28708) (\PROMPTFORWORDBIN 28710 . 31646) (\REMOTE.BIN 31648 . 33890) (
\REMOTE.EXEC.OUTCHARFN 33892 . 38114) (CHATSERVER.FONT 38116 . 38507)) (39151 41493 (SIMPLECHATSERVER 
39161 . 41491)))))
STOP