(FILECREATED "25-Jun-84 21:20:24" {ERIS}<LISP>FUGUE6>LIBRARY>RS232EXEC.;1 36142
previous date: "20-NOV-83 20:35:41" {ERIS}<LISP>LIBRARY>RS232EXEC.;1)
(* Copyright (c) 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT RS232EXECCOMS)
(RPAQQ RS232EXECCOMS ((FILES (SYSLOAD)
RS232)
(DECLARE: EVAL@COMPILE DONTCOPY (P (OR (GETMACROPROP (QUOTE
RS232INITIALIZECHECK)
COMPILERMACROPROPS)
(LOADFROM (QUOTE RS232)))))
(LOCALVARS . T)
(DECLARE: EVAL@COMPILE (RECORDS RS232COMMANDLSTENTRY RS232COMMANDUSERSENTRY))
(ADDVARS (RS232EXEC.USERS NIL)
(RS232EXEC.HOSTS)
(RS232EXEC.DIRECTORIES LISPUSERS LISP LISP>LIBRARY LISP>FUGUE
LISP>CURRENT))
(INITVARS (RS232EXEC.DEFAULTLOGFILE (UNPACKFILENAME
"<LISP>COMMANDSERVER>LOGSHEET"))
(\RS232EXEC.WHITEBT (MAKEBITTABLE (CHARCODE (SPACE TAB NULL))))
(\RS232EXEC.TIMEOUT.mins 3)
(\RS232EXEC.TIMER (SETUPTIMER 0)))
(GLOBALVARS RS232EXEC.USERS RS232EXEC.HOSTS RS232EXEC.DIRECTORIES
\RS232EXEC.WHITEBT \RS232EXEC.TIMER)
(SPECVARS \RS232EXEC.TIMEOUT.mins 1MIN.tics MODEMANSWERTEST)
(FNS RS232EXEC.ADDUSER RS232EXEC.DELUSER RS232EXEC.SERVER
\RS232EXEC.CHECK.MODEMANSWER \RS232EXECSERVER.TERPRI
\RS232EXEC.LOGFILE.NOTE RS232READ&ECHO.LINE \RS232.DSPRUBOUTCHAR
\RS232COMMAND.EVAL \RS232COMMAND.TERM \RS232COMMAND.SPEED
\RS232COMMAND.LOGIN \RS232COMMAND.LOGOUT \RS232COMMAND.CONN)
(ALISTS (RS232COMMANDSLST EVAL TERMINAL QUIT SPEED LOGIN CONN PASSWORD LOGOUT))
(COMS (* Should be elsewhere)
(EXPORT (DECLARE: EVAL@COMPILE DONTCOPY (MACROS STRINGNCHARS
\FILLINSTRPTR
CHARCODE.DIGIT.WEIGHT)))
(GLOBALRESOURCES \STRINGTRIM.BITTABLE)
(MACROS STRINGTRIM \STRINGTRIM.OLDPTR STRINGLEFTTRIM STRINGRIGHTTRIM)
(FNS MATCHSTRING.FROM.LIST FIND.MAXIMAL.SUBSTRING STRINGTRIM
STRINGLEFTTRIM STRINGRIGHTTRIM \STRINGTRIMAUX \STRINGTRIMAUX1))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA \RS232EXEC.LOGFILE.NOTE)))))
(FILESLOAD (SYSLOAD)
RS232)
(DECLARE: EVAL@COMPILE DONTCOPY
(OR (GETMACROPROP (QUOTE RS232INITIALIZECHECK)
COMPILERMACROPROPS)
(LOADFROM (QUOTE RS232)))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: EVAL@COMPILE
[DECLARE: EVAL@COMPILE
(RECORD RS232COMMANDLSTENTRY (COMMANDNAME COMMANDFN COMMANDDOC COMMANDNEEDSLOGIN SHORTSCANP))
(RECORD RS232COMMANDUSERSENTRY (USERID CRYPTWORD WHEELP))
]
)
(ADDTOVAR RS232EXEC.USERS NIL)
(ADDTOVAR RS232EXEC.HOSTS )
(ADDTOVAR RS232EXEC.DIRECTORIES LISPUSERS LISP LISP>LIBRARY LISP>FUGUE LISP>CURRENT)
(RPAQ? RS232EXEC.DEFAULTLOGFILE (UNPACKFILENAME "<LISP>COMMANDSERVER>LOGSHEET"))
(RPAQ? \RS232EXEC.WHITEBT (MAKEBITTABLE (CHARCODE (SPACE TAB NULL))))
(RPAQ? \RS232EXEC.TIMEOUT.mins 3)
(RPAQ? \RS232EXEC.TIMER (SETUPTIMER 0))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS RS232EXEC.USERS RS232EXEC.HOSTS RS232EXEC.DIRECTORIES \RS232EXEC.WHITEBT
\RS232EXEC.TIMER)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(SPECVARS \RS232EXEC.TIMEOUT.mins 1MIN.tics MODEMANSWERTEST)
)
(DEFINEQ
(RS232EXEC.ADDUSER
(LAMBDA (NAME PASSWORD WHEELP) (* JonL "10-OCT-83 17:38")
(* Someday, this database should be kept on a file, and any entries/deletions to this internal list should be
reflected in an update to the database file.)
(PROG ((UNAME (U-CASE (MKATOM NAME)))
USERINFO)
(OR (SETQ USERINFO (FASSOC UNAME RS232EXEC.USERS))
(push RS232EXEC.USERS (SETQ USERINFO (create RS232COMMANDUSERSENTRY
USERID ← UNAME))))
(replace CRYPTWORD of USERINFO with (AND PASSWORD (HASH.PASSWORD PASSWORD)))
(replace WHEELP of USERINFO with WHEELP)
(RETURN T))))
(RS232EXEC.DELUSER
(LAMBDA (NAME) (* JonL "10-OCT-83 17:40")
(PROG ((UNAME (U-CASE (MKATOM NAME)))
USERINFO)
(if (SETQ USERINFO (FASSOC UNAME RS232EXEC.USERS))
then (SETQ RS232EXEC.USERS (DREMOVE USERINFO RS232EXEC.USERS))
(RETURN T)))))
(RS232EXEC.SERVER
(LAMBDA (LOGFILE MODEMANSWERTEST LISTENINGSPEED) (* JonL "20-NOV-83 20:34")
(DECLARE (SPECVARS LOGFILE MODEMANSWERTEST LISTENINGSPEED))
(RS232INITIALIZECHECK)
(\RS232INSURE.LINEBUFFER 580) (* Input buffer is at least as big as the data portion
of an ethernet packet.)
(OR (FIXP LISTENINGSPEED)
(SETQ LISTENINGSPEED 1200))
(AND (PROG1 RS232EXEC.DEFAULTLOGFILE (* Comment PPLossage))
(NLISTP RS232EXEC.DEFAULTLOGFILE)
(SETQ RS232EXEC.DEFAULTLOGFILE (UNPACKFILENAME RS232EXEC.DEFAULTLOGFILE)))
(RESETLST (RESETSAVE RECLAIMWAIT MAX.SMALLP)
(RESETSAVE NIL (LIST (QUOTE CNDIR)
(DIRECTORYNAME T)))
(PROG ((PROMPTMSG "←")
(TIMEOUT.tics (ITIMES \RS232EXEC.TIMEOUT.mins 60 \RCLKSECOND))
(1MIN.tics (ITIMES 60 \RCLKSECOND))
(10SECS.tics (ITIMES 10 \RCLKSECOND))
(3SECS.tics (ITIMES 3 \RCLKSECOND))
(SUCCESSIVE.LONGRINGS 0)
(SPEEDFLIPFLOPS 0)
(RS232LOSTCHARFN (FUNCTION (LAMBDA (X)
(if (EQ X (QUOTE FramingError))
then (OR MODEMANSWERTEST (HELP
"Connections at wrong speed"))
(PROG ((POS (OR (STKPOS (QUOTE RS232READ&ECHO.LINE)
)
(STKPOS (QUOTE
\RS232EXEC.CHECK.MODEMANSWER)))))
(if POS
then (RETFROM POS (QUOTE FramingError))))
)
(SETUPTIMER 0 \RS232DING.BOX)
(* To stop that abominable flashing)
(\RS232DING))))
LOGGEDINP WHEELP DISPLAYTERMP CLINE COMM COMMWORDP NCHARS I)
(DECLARE (SPECVARS TIMEOUT.tics 1MIN.tics 10SECS.tics 3SECS.tics
SUCCESSIVE.LONGRINGS LOGGEDINP WHEELP DISPLAYTERMP
RS232LOSTCHARFN))
(if LOGFILE
then (OR (EQ T LOGFILE)
(type? STREAM LOGFILE)
(SETQ LOGFILE (if (OR (LITATOM LOGFILE)
(STRINGP LOGFILE))
then (PACKFILENAME (NCONC (UNPACKFILENAME LOGFILE)
RS232EXEC.DEFAULTLOGFILE)
)
else T)))
(SETQ LOGFILE (if (EQ T LOGFILE)
then (GETSTREAM T (QUOTE OUTPUT))
elseif (OR (OPENP LOGFILE (SETQ I (QUOTE APPEND)))
(OPENP LOGFILE (SETQ I (QUOTE OUTPUT))))
then (GETSTREAM LOGFILE I)
else (OPENSTREAM LOGFILE (QUOTE APPEND)
(QUOTE OLD/NEW))))
(printout LOGFILE T T
"Commencement of RS232 CommandServer Service is at "
(GDATE)
T))
BEGINLISTENING
(SETQ LOGGEDINP (SETQ WHEELP (SETQ DISPLAYTERMP NIL)))
(FRPTQ 8 (RECLAIM))
(CNDIR (QUOTE {DSK}))
(RS232INIT LISTENINGSPEED 8 NIL NIL (AND MODEMANSWERTEST (QUOTE (DTR RTS))))
(if MODEMANSWERTEST
then (SETQ SPEEDFLIPFLOPS 0)
(SELECTQ (\RS232EXEC.CHECK.MODEMANSWER)
(NIL (GO GETLINE))
(TIMEREXPIRED? (SETQ CLINE (QUOTE TIMEREXPIRED?))
(GO ANALYZELINE))
(RESTART (GO BEGINLISTENING))
((FramingError)
(GO FLIPSPEED))
(SHOULDNT (QUOTE \RS232EXEC.CHECK.MODEMANSWER)))
else (GO GETLINE))
FLIPSPEED
(if (IGREATERP (add SPEEDFLIPFLOPS 1)
4)
then (\RS232EXEC.LOGFILE.NOTE 24 "Connection failure (wrong speed?)")
(RS232MODEMHANGUP)
(GO BEGINLISTENING))
(APPLY (FUNCTION RS232INIT)
(CONS (SELECTQ (fetch BAUDRATE of RS232INIT)
(300 1200)
(1200 300)
(SHOULDNT))
(CDR RS232INIT)))
GETLINE
(SETQ CLINE (RS232READ&ECHO.LINE PROMPTMSG TIMEOUT.tics DISPLAYTERMP NIL NIL
RS232COMMANDSLST))
ANALYZELINE
(if (NOT (STRINGP CLINE))
then (if (LISTP CLINE)
then (* Command with SHORTSCANP has already found its
COMMANDLSTENTRY)
(SETQ COMM CLINE)
(SETQ CLINE)
(\RS232.CHECKUART)
(GO RUNCOMMAND))
(SELECTQ CLINE
((TIMEREXPIRED?)
(if (AND (PROG1 MODEMANSWERTEST
(* Comment PPLossage))
(OR (EQ MODEMANSWERTEST (QUOTE PEEK))
(RS232MODEMSTATUSP (QUOTE DSR))))
then (\RS232EXECSERVER.TERPRI)
(SETQ I
(CONCAT (PROG1 "Auto LOGOUT "
(* Comment PPLossage))
(if LOGGEDINP
then (if WHEELP
then "of Wheel "
else "of User ")
else "")
(OR LOGGEDINP "")
" (idle for more than "
(MKSTRING \RS232EXEC.TIMEOUT.mins)
" minutes)"))
(RS232WRITECHARS I)
(\RS232EXECSERVER.TERPRI)
(RS232WRITEBYTE (CHARCODE ↑G)
T)
(RS232MODEMHANGUP)
(\RS232EXEC.LOGFILE.NOTE 24 I))
(GO BEGINLISTENING))
((RS232CLEARBUFFER)
(\RS232EXECSERVER.TERPRI)
(RS232WRITECHARS
"Input buffer capacity exceeded -- try again!")
(RS232CLEARBUFFER (QUOTE INPUT))
(GO GETLINE))
((ABORT)
(RS232WRITESTRING " XXX ")
(GO GETLINE))
((FramingError)
(GO FLIPSPEED))
(PROGN (\RS232EXECSERVER.TERPRI)
(RS232WRITECHARS
"Shouldn't Happen -- RS232COMMAND.SERVER Please report to LispSupport")
(GO GETLINE)))
else (SETQ SPEEDFLIPFLOPS 0)) (* Trim "white space" chars off right end of line --
RS232READ&ECHO.LINE doesn't allow them to accumulate on
the left)
(\RS232.CHECKUART)
(SETQ CLINE (STRINGRIGHTTRIM CLINE \RS232EXEC.WHITEBT))
(\RS232.CHECKUART)
(if (ZEROP (SETQ NCHARS (STRINGNCHARS CLINE)))
then (GO GETLINE)
elseif (PROG1 (SETQ I (STRPOSL \RS232EXEC.WHITEBT CLINE))
(\RS232.CHECKUART))
then (* Delimit the initial word of CLINE by index I)
(add I -1))
(SETQ COMM (ASSOC (MATCHSTRING.FROM.LIST (U-CASE (SUBSTRING CLINE 1 I))
RS232COMMANDSLST T)
RS232COMMANDSLST))
(if (NULL (AND COMM (fetch (RS232COMMANDLSTENTRY COMMANDNAME) of COMM)))
then (* Looks like he doesn't know what he's doing)
(RS232WRITECHARS " ??" T)
(GO GETLINE)
elseif (AND (NOT LOGGEDINP)
(fetch (RS232COMMANDLSTENTRY COMMANDNEEDSLOGIN) of COMM))
then (RS232WRITECHARS " Not logged in ??" T)
(GO GETLINE))
(SETQ CLINE (AND I (SETQ I (PROG1 (STRPOSL \RS232EXEC.WHITEBT CLINE (ADD1 I)
T)
(\RS232.CHECKUART)))
(PROG1 (SUBSTRING CLINE I NIL CLINE)
(\RS232.CHECKUART))))
(\RS232EXECSERVER.TERPRI)
RUNCOMMAND
(SETQ COMM (NLSETQ (APPLY* (fetch (RS232COMMANDLSTENTRY COMMANDFN) of COMM)
CLINE)))
(if COMM
then (if (EQ (CAR COMM)
(QUOTE \RS232COMMAND.LOGOUT))
then (* Special-case for this one)
(GO BEGINLISTENING))
(RS232WRITESTRING " ==> ")
(RS232WRITESTRING (MKSTRING (CAR COMM)))
elseif (NOT (AND (EQ 17 (CAR (SETQ COMM (PROG1 (ERRORN)
(\RS232.CHECKUART)))))
(EQ (CAADR COMM)
(QUOTE NOERROR))))
then (* Note that (ERROR (QUOTE NOERROR)) elects not to come
here)
(RS232WRITESTRING " [Error: ")
(if (EQ 17 (CAR COMM))
then (RS232WRITESTRING (MKSTRING (CAADR COMM)))
(RS232WRITESTRING " ")
(RS232WRITESTRING (MKSTRING (CDADR COMM)
T))
else (RS232WRITESTRING (ERRORSTRING (CAR COMM)))
(RS232WRITESTRING " ")
(RS232WRITESTRING (MKSTRING (CADR COMM)
T)))
(RS232WRITESTRING " ]")) (* Remember, GETLINE will call \RS232EXECSERVER.TERPRI
which will force output.)
(GO GETLINE)))))
(\RS232EXEC.CHECK.MODEMANSWER
(LAMBDA NIL
(DECLARE (USEDFREE MODEMANSWERTEST TIMEOUT.tics 10SECS.tics 3SECS.tics LOGFILE
SUCCESSIVE.LONGRINGS)) (* JonL "20-NOV-83 20:23")
(* Wait until we hear someone who has dialed-in, and
whom the modem has answered.)
(repeatuntil (SELECTQ MODEMANSWERTEST
((RING READY RINGREADY)
(RS232MODEMSTATUSP (SELECTQ MODEMANSWERTEST
(RING (QUOTE RI))
(READY (QUOTE DSR))
(RINGREADY (QUOTE (OR RI DSR)))
NIL)))
(PEEK (RS232PEEKBYTE))
(\ILLEGAL.ARG MODEMANSWERTEST))
do (\RS232CHECK.BLOCK))
(PROG NIL
(if (AND (NEQ MODEMANSWERTEST (QUOTE PEEK))
(RS232MODEMSTATUSP (QUOTE RI)))
then (* Ascertain that the phone has stopped ringing)
(AND (during 10SECS.tics timerUnits (QUOTE TICKS) usingTimer \RS232EXEC.TIMER
when (NOT (RS232MODEMSTATUSP (QUOTE RI))) do (RETURN)
finally (if (ILEQ 10 (add SUCCESSIVE.LONGRINGS 1))
then (HELP "Modem wedged in RI state?")
else (\RS232EXEC.LOGFILE.NOTE 0
"****** Modem continues RI for longer than 10 seconds.")
(RS232MODEMHANGUP)
(RETURN T)))
(RETURN (QUOTE RESTART))))
(SETQ SUCCESSIVE.LONGRINGS 0)
(\RS232EXEC.LOGFILE.NOTE 24 "Dial-in detected"))))
(\RS232EXECSERVER.TERPRI
(LAMBDA NIL (* JonL "11-JUL-83 18:23")
(* Here is the place which ought to be sensitive to CR/LF -- to install some padding if necessary.
Currently, we just delay long enough for Interlisp-D's display printout routines to do their thing.)
(RS232WRITEBYTE (CHARCODE CR)
T)
(\RS232CHECK.BLOCK 10)
(RS232WRITEBYTE (CHARCODE LF)
T)
(\RS232CHECK.BLOCK 40)
T))
(\RS232EXEC.LOGFILE.NOTE
(LAMBDA NARGS
(DECLARE (SPECVARS LOGFILE)) (* JonL "15-SEP-83 13:36")
(if LOGFILE
then (FRESHLINE LOGFILE)
(PRIN1 (GDATE))
(TAB (ARG NARGS 1)
0 LOGFILE)
(for I from 2 to NARGS do (PRIN1 (ARG NARGS I)
LOGFILE)))))
(RS232READ&ECHO.LINE
(LAMBDA (PROMPTSTRING TIMEOUT.tics DISPLAYTERMP WHITESPACETERMINS? NOECHOP COMMANDS.ALIST)
(* JonL "10-OCT-83 17:51")
(DECLARE (SPECVARS DISPLAYTERMP))
(\RS232.CHECKUART)
(PROG ((NCHARS 0)
(LINEBUFFERSIZE 256)
C CLINE COMM COMMWORDP RUBBING?)
(DECLARE (SPECVARS RUBBING?))
BEGIN
(\RS232INSURE.LINEBUFFER LINEBUFFERSIZE)
(SETQ CLINE \RS232STRPTR)
(SETQ LINEBUFFERSIZE (STRINGNCHARS CLINE))
(OR (IGEQ LINEBUFFERSIZE 256)
(SHOULDNT "Line Buffer size"))
(change (STRINGNCHARS CLINE)
(SETQ NCHARS 0))
(\RS232EXECSERVER.TERPRI)
(RS232WRITESTRING PROMPTSTRING T)
(SETQ RUBBING?)
(SETQ COMMWORDP COMMANDS.ALIST)
GETNEXTBYTE
(if (NULL (SETQ C (RS232READBYTE TIMEOUT.tics (QUOTE TICS))))
then (* Flush him if he's idle too long)
(RETURN (QUOTE TIMEREXPIRED?)))
CHECKBYTE
(SELCHARQ C
((↑A BS)
(if (AND RUBBING? (NOT DISPLAYTERMP)
(ZEROP NCHARS))
then (SETQ RUBBING?)
(if (NOT NOECHOP)
then (RS232WRITEBYTE (CHARCODE \)
T)))
(if (NOT (ZEROP NCHARS))
then (add NCHARS -1)
(SETQ C (GLC CLINE))
(if (NOT NOECHOP)
then (OR (\RS232.DSPRUBOUTCHAR C DISPLAYTERMP)
(PROGN (* This, just to share code with the reprint from ↑R)
(SETQ RUBBING? T)
(SETQ C (CHARCODE ↑R))
(GO CHECKBYTE))))
(if (ZEROP NCHARS)
then (if (AND RUBBING? (NOT DISPLAYTERMP))
then (SETQ RUBBING?)
(RS232WRITEBYTE (CHARCODE \)
T))
(GO BEGIN)))
(GO GETNEXTBYTE))
((↑Q)
(if DISPLAYTERMP
then (* Someday, figure out something better to do here.)
NIL)
(GO BEGIN))
((↑R)
(if (AND (NOT NOECHOP)
(OR RUBBING? (NEQ 0 NCHARS)))
then (if DISPLAYTERMP
then (* Someday, figure out something better to do here.)
)
(\RS232EXECSERVER.TERPRI)
(RS232WRITESTRING PROMPTSTRING)
(RS232WRITESTRING CLINE))
(SETQ RUBBING?)
(RS232FORCEOUTPUT)
(GO GETNEXTBYTE))
((↑V)
(if (NULL (SETQ C (RS232READBYTE TIMEOUT.tics (QUOTE TICS))))
then (RETURN (QUOTE TIMEREXPIRED?))))
((?)
(if COMMANDS.ALIST
then (for X in COMMANDS.ALIST when (OR (PROG1 LOGGEDINP
(* Comment PPLossage))
(NOT (fetch (RS232COMMANDLSTENTRY
COMMANDNEEDSLOGIN)
of X)))
do (\RS232EXECSERVER.TERPRI)
(RS232WRITESTRING (fetch (RS232COMMANDLSTENTRY COMMANDNAME)
of X))
(RS232WRITEBYTE (CHARCODE SPACE))
(RS232WRITESTRING (OR (fetch (RS232COMMANDLSTENTRY COMMANDDOC)
of X)
" ")
T))
(PROGN (* This, just to share code with the reprint from ↑R)
(SETQ RUBBING? T)
(SETQ C (CHARCODE ↑R))
(GO CHECKBYTE))))
((ESC)
(if COMMWORDP
then (* Try command completion)
(if (SETQ COMM (MATCHSTRING.FROM.LIST CLINE COMMANDS.ALIST T))
then (PROG ((MAYBECOMM? COMM)
(M (fetch (STRINGP LENGTH) of CLINE))
N)
(if (LISTP MAYBECOMM?)
then (SETQ MAYBECOMM? (FIND.MAXIMAL.SUBSTRING
MAYBECOMM?)))
(OR (STRINGP MAYBECOMM?)
(SETQ MAYBECOMM? (MKSTRING MAYBECOMM?)))
(change (STRINGNCHARS CLINE)
(SETQ NCHARS (SETQ N (STRINGNCHARS MAYBECOMM?)))
)
(if (NEQ N M)
then (SETQ MAYBECOMM? (SUBSTRING MAYBECOMM?
(ADD1 M)
NIL MAYBECOMM?))
(RPLSTRING CLINE (ADD1 M)
MAYBECOMM?)
(RS232WRITECHARS MAYBECOMM?)))
(if (AND (NLISTP COMM)
(SETQ C (ASSOC (MATCHSTRING.FROM.LIST CLINE
COMMANDS.ALIST T)
COMMANDS.ALIST))
(fetch (RS232COMMANDLSTENTRY SHORTSCANP)
of C))
then (RETURN C)
elseif (NLISTP COMM)
then (change (STRINGNCHARS CLINE)
(add NCHARS 1))
(RPLCHARCODE CLINE NCHARS (CHARCODE SPACE))
(RS232WRITEBYTE (CHARCODE SPACE))
else (* Lose! Didn't make a perfect match!)
(RS232WRITEBYTE (CHARCODE ↑G)))
else (RS232WRITEBYTE (CHARCODE ↑G)))
(RS232FORCEOUTPUT)
(GO GETNEXTBYTE)))
((EOL CR LF)
(RETURN CLINE))
((DEL)
(RETURN (QUOTE ABORT)))
(if (ZEROP (\SYNCODE \RS232EXEC.WHITEBT C))
then (* Don't worry much about non-white-space characters)
elseif (NOT COMMANDS.ALIST)
then (if WHITESPACETERMINS?
then (if (ZEROP NCHARS)
then (GO GETNEXTBYTE)
else (RETURN CLINE)))
elseif (ZEROP NCHARS)
then (* Don't put white-space characters at the beginning of
a command line)
(GO GETNEXTBYTE)
elseif (NEQ C (CHARCODE NULL))
then (* Most "white space" characters will terminate a word.)
(if COMMWORDP
then (* Try once to see if this is an "early" quitter)
(if (AND (SETQ COMMWORDP (ASSOC (MATCHSTRING.FROM.LIST CLINE
COMMANDS.ALIST T)
COMMANDS.ALIST))
(fetch (RS232COMMANDLSTENTRY SHORTSCANP) of COMMWORDP))
then (RETURN COMMWORDP))
(SETQ COMMWORDP))))
(\RS232.CHECKUART)
(if RUBBING?
then (OR NOECHOP (RS232WRITEBYTE (CHARCODE \)))
(SETQ RUBBING?))
(\PUTBASEBYTE \RS232LINEBUFFER NCHARS C)
(change (STRINGNCHARS CLINE)
(add NCHARS 1))
(if (IGEQ NCHARS LINEBUFFERSIZE)
then (RETURN (QUOTE RS232CLEARBUFFER))) (* Now for the normal echo of his typed-in character)
(OR NOECHOP (RS232WRITEBYTE C T))
(GO GETNEXTBYTE))))
(\RS232.DSPRUBOUTCHAR
(LAMBDA (C DISPLAYTERMP) (* JonL "14-SEP-83 19:05")
(DECLARE (SPECVARS RUBBING?))
(if DISPLAYTERMP
then (RS232WRITECHARS "")
(RS232WRITEBYTE C T)
T
else (if (NOT RUBBING?)
then (RS232WRITEBYTE (SETQ RUBBING? (CHARCODE \))))
(RS232WRITEBYTE (CHCON1 C)
T))))
(\RS232COMMAND.EVAL
(LAMBDA (STR) (* JonL "14-SEP-83 20:03")
(DECLARE (GLOBALVARS \STRINGOFDS)
(SPECVARS WHEELP))
(if (NOT WHEELP)
then (ERROR "EVAL not available to non-WHEELs."))
(if (AND (STRINGP STR)
(NOT (ZEROP (NCHARS STR))))
then (EVAL (PROG1 (READ STR)
(PUTHASH STR NIL \STRINGOFDS)))
else (ERROR " ??"))))
(\RS232COMMAND.TERM
(LAMBDA (STR) (* JonL "10-OCT-83 17:47")
(* DISPLAYTERMP should be a FVAR bound by
RS232COMMAND.SERVER)
(DECLARE (USEDFREE DISPLAYTERMP))
((LAMBDA (I)
(if (OR (NOT (STRINGP STR))
(ZEROP (NCHARS STR))
(AND (FMEMB (NTHCHARCODE STR 1)
(CHARCODE (D d)))
(FMEMB (NTHCHARCODE STR 1)
(CHARCODE (E e)))
(NULL (STRPOSL \RS232EXEC.WHITEBT STR))))
then (* Latter AND is a quick test for "DEscribe")
NIL
else (* Next AND is a quick test for "DIsplay")
(SETQ DISPLAYTERMP (AND (FMEMB (NTHCHARCODE STR 1)
(CHARCODE (D d)))
(FMEMB (NTHCHARCODE STR 1)
(CHARCODE (I i)))
(NULL (STRPOSL \RS232EXEC.WHITEBT STR)))))
(if DISPLAYTERMP
then " DISPLAY"
else " STANDARD")))))
(\RS232COMMAND.SPEED
(LAMBDA (STR) (* JonL "10-OCT-83 17:47")
(if (AND (STRINGP STR)
(NEQ 0 (NCHARS STR)))
then (PROG ((SPEED 0)
(RADIX 10))
(SETQ STR (STRINGTRIM STR \RS232EXEC.WHITEBT))
(if (EQ (NTHCHARCODE STR (NCHARS STR))
(CHARCODE Q))
then (GLC STR)
(SETQ RADIX 8))
(for C instring STR do (SETQ SPEED (IPLUS (ITIMES RADIX SPEED)
(CHARCODE.DIGIT.WEIGHT C))))
(APPLY (FUNCTION RS232INIT)
(CONS SPEED (CDR RS232INIT)))
(AND MODEMANSWERTEST (RS232MODEMCONTROL (QUOTE (DTR RTS))))))
(MKSTRING (fetch (RS232CHARACTERISTICS BAUDRATE) of RS232INIT))))
(\RS232COMMAND.LOGIN
(LAMBDA (NAME) (* JonL "10-OCT-83 17:52")
(DECLARE (USEDFREE DISPLAYTERMP))
(\RS232.CHECKUART)
(PROG (UNAME USERINFO CRYPTWORD PASSW I)
(DECLARE (SPECVARS LOGGEDINP WHEELP))
(repeatuntil (AND (STRINGP NAME)
(NOT (ZEROP (STRINGNCHARS NAME))))
do (SETQ NAME (RS232READ&ECHO.LINE "Login: (name?) " 1MIN.tics DISPLAYTERMP
(CHARCODE (SPACE TAB))))
(AND (LITATOM NAME)
(SELECTQ NAME
(TIMEREXPIRED? (ERROR (QUOTE Time% out)))
(ABORT (RS232WRITESTRING " XXX ")
(ERROR (QUOTE NOERROR)))
NIL)))
(SETQ NAME (STRINGTRIM NAME \RS232EXEC.WHITEBT))
(\RS232.CHECKUART)
(if (SETQ I (PROG1 (STRPOSL \RS232EXEC.WHITEBT NAME)
(\RS232.CHECKUART)))
then (* Since white-space characters have been trimmed of
left and right ends, then this must be an embedded
"space")
(PROG ((J (STRPOSL \RS232EXEC.WHITEBT NAME I T)))
(\RS232.CHECKUART)
(if J
then (SETQ PASSW (SUBSTRING NAME J (PROG1 (STRPOSL \RS232EXEC.WHITEBT
NAME J)
(\RS232.CHECKUART))))
(\RS232.CHECKUART)
(SETQ NAME (SUBSTRING NAME 1 (SUB1 I)
NAME))
else (SHOULDNT (QUOTE \RS232COMMAND.LOGIN)))))
(\RS232.CHECKUART)
(SETQ UNAME (U-CASE (MKATOM NAME)))
(\RS232.CHECKUART)
(if (NULL (SETQ USERINFO (FASSOC UNAME RS232EXEC.USERS)))
then (ERROR NAME "Unknown user name"))
(until (STRINGP PASSW)
do (SETQ PASSW (RS232READ&ECHO.LINE " (Password) " 1MIN.tics DISPLAYTERMP
(CHARCODE (SPACE TAB))
T))
(AND (LITATOM NAME)
(SELECTQ NAME
(TIMEREXPIRED? (ERROR (QUOTE Time% out)))
(ABORT (RS232WRITESTRING " XXX ")
(ERROR (QUOTE NOERROR)))
NIL)))
(if (OR (NULL (SETQ I (fetch (RS232COMMANDUSERSENTRY CRYPTWORD) of USERINFO)))
(EQUAL I (HASH.PASSWORD (U-CASE PASSW))))
then (SETQ LOGGEDINP UNAME)
else (ERROR " wrong password"))
(SETQ WHEELP (fetch (RS232COMMANDUSERSENTRY WHEELP) of USERINFO))
(\RS232EXEC.LOGFILE.NOTE 24 (if WHEELP
then "Wheel "
else "User ")
UNAME " logged in")
(RETURN (QUOTE OK)))))
(\RS232COMMAND.LOGOUT
(LAMBDA NIL (* JonL "10-OCT-83 17:52")
(\RS232EXECSERVER.TERPRI)
(RS232WRITECHARS "Bye, bye.")
(\RS232EXECSERVER.TERPRI)
(AND MODEMANSWERTEST (RS232MODEMHANGUP))
(\RS232EXEC.LOGFILE.NOTE 24 (if LOGGEDINP
then (if WHEELP
then "LOGOUT of Wheel "
else "LOGOUT of user ")
else "LOGOUT ")
(OR LOGGEDINP ""))
(QUOTE \RS232COMMAND.LOGOUT)))
(\RS232COMMAND.CONN
(LAMBDA (STR) (* JonL "10-OCT-83 17:45")
(PROG (HOST DIR)
(if (AND (STRINGP STR)
(NOT (ZEROP (NCHARS STR))))
then (PROG ((L (UNPACKFILENAME STR)))
(SETQ HOST (LISTGET L (QUOTE HOST)))
(SETQ DIR (LISTGET L (QUOTE DIRECTORY))))
else (RETURN (DIRECTORYNAME T)))
(if (NULL HOST)
elseif (EQ HOST (QUOTE DSK))
then (* Temporary kludge since ALTO file system doesn't
support local directories)
(SETQ DIR)
elseif (NOT (FMEMB HOST RS232EXEC.HOSTS))
then (ERROR HOST " not a permitted host"))
(if (NULL DIR)
elseif (NOT (FMEMB DIR RS232EXEC.DIRECTORIES))
then (ERROR DIR " not a permitted directory"))
(RETURN (CNDIR (if (AND HOST DIR)
then (PACKFILENAME (QUOTE HOST)
HOST
(QUOTE DIRECTORY)
DIR)
else (OR HOST DIR (QUOTE {DSK}))))))))
)
(ADDTOVAR RS232COMMANDSLST (EVAL \RS232COMMAND.EVAL "{s-expression}" T)
(TERMINAL \RS232COMMAND.TERM "{DISPLAY or not}")
(QUIT \RS232COMMAND.LOGOUT " | Quit and Logout.")
(SPEED \RS232COMMAND.SPEED "{change RS232 speed -- decimal number}")
(LOGIN \RS232COMMAND.LOGIN "Login for Command service" NIL T)
(CONN \RS232COMMAND.CONN
"Connect to directory (on local file server), or to {DSK} if no arg"
T)
(PASSWORD \RS232COMMAND.PASSW "Change the logged-in user's password" T T)
(LOGOUT \RS232COMMAND.LOGOUT " | Quit and Logout."))
(* Should be elsewhere)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS STRINGNCHARS MACRO (= . NCHARS))
(PUTPROPS STRINGNCHARS DMACRO ((STR)
(ffetch (STRINGP LENGTH) of STR)))
(PUTPROPS \FILLINSTRPTR DMACRO (OPENLAMBDA (STRPTR STRBASE STROFFST STRLENGTH)
(replace (STRINGP BASE) of STRPTR with STRBASE)
(freplace (STRINGP OFFST) of STRPTR with STROFFST)
(freplace (STRINGP LENGTH) of STRPTR with STRLENGTH)
STRPTR))
(PUTPROPS \FILLINSTRPTR MACRO (OPENLAMBDA (STRPTR STRBASE STROFFST STRLENGTH)
(replace (STRINGP BASE) of STRPTR with STRBASE)
(replace (STRINGP OFFST) of STRPTR with STROFFST)
(replace (STRINGP LENGTH) of STRPTR with STRLENGTH)
STRPTR))
(PUTPROPS CHARCODE.DIGIT.WEIGHT MACRO (OPENLAMBDA (C)
(if (OR (ILESSP C (CHARCODE 0))
(IGREATERP C (CHARCODE 9)))
then (ERROR (CHARACTER C)
"Bad digit")
else (IDIFFERENCE C (CHARCODE 0)))))
)
)
(* END EXPORTED DEFINITIONS)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(PUTDEF (QUOTE \STRINGTRIM.BITTABLE)
(QUOTE GLOBALRESOURCES)
(QUOTE (\ALLOCBLOCK (CONSTANT (FOLDHI (EXPT 2 BITSPERBYTE)
BITSPERCELL)))))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \STRINGTRIM.BITTABLE)
)
(RPAQQ \STRINGTRIM.BITTABLE NIL)
(DECLARE: EVAL@COMPILE
(PUTPROPS STRINGTRIM MACRO (X
(if (ILESSP 2 (LENGTH X))
then (CONS (QUOTE \STRINGTRIM.OLDPTR)
X)
else (QUOTE IGNOREMACRO))))
(PUTPROPS \STRINGTRIM.OLDPTR MACRO (OPENLAMBDA (STR CHARSET OLDPTR)
(STRINGLEFTTRIM (STRINGRIGHTTRIM STR CHARSET OLDPTR)
CHARSET OLDPTR)))
(PUTPROPS STRINGLEFTTRIM MACRO ((STR CHARSET . OLDPTR)
(\STRINGTRIMAUX STR CHARSET T . OLDPTR)))
(PUTPROPS STRINGRIGHTTRIM MACRO ((STR CHARSET . OLDPTR)
(\STRINGTRIMAUX STR CHARSET NIL . OLDPTR)))
)
(DEFINEQ
(MATCHSTRING.FROM.LIST
(LAMBDA (STR L ALISTFLG) (* JonL "16-SEP-83 15:10")
(* Searches the car's of L for a string for which STR is an initial substring. Returns the unique best match, if
there is one, or a list of all matches if there is more than one (with the exact match at the beginning, if there
is one) or NIL if there are no matches.)
(\RS232.CHECKUART)
(if (NOT (STRINGP STR))
then (SETQ STR (MKSTRING STR))
(\RS232.CHECKUART))
(for Y in L bind ITEM EXACTMATCH FIRSTPARTIALMATCH MULTIPLES TESTSTR STRPTR (#CHARS.STR
←(STRINGNCHARS STR))
do (SETQ ITEM (if ALISTFLG
then (CAR Y)
else Y))
(if (NOT (STRINGP (SETQ TESTSTR ITEM)))
then (if (NULL STRPTR)
then (SETQ STRPTR (ALLOCSTRING 0))
(\RS232.CHECKUART))
(SETQ TESTSTR (SUBSTRING TESTSTR 1 NIL STRPTR))
(\RS232.CHECKUART))
(if (PROG1 (STRPOS STR TESTSTR 1 NIL T)
(\RS232.CHECKUART))
then (if (EQ #CHARS.STR (STRINGNCHARS TESTSTR))
then (* AHA! An exact match!)
(SETQ EXACTMATCH ITEM)
elseif (NOT FIRSTPARTIALMATCH)
then (SETQ FIRSTPARTIALMATCH ITEM)
elseif (NULL MULTIPLES)
then (SETQ MULTIPLES (LIST ITEM FIRSTPARTIALMATCH))
else (push MULTIPLES ITEM)
(\RS232.CHECKUART)))
finally (RETURN (PROG1 (if (NULL MULTIPLES)
then (OR EXACTMATCH FIRSTPARTIALMATCH)
else (if EXACTMATCH
then (push MULTIPLES EXACTMATCH))
MULTIPLES)
(\RS232.CHECKUART))))))
(FIND.MAXIMAL.SUBSTRING
(LAMBDA (L) (* JonL "15-SEP-83 14:40")
(if (NLISTP L)
then (ALLOCSTRING 0)
else ((LAMBDA (MINLENGTHWORD MINLENGTH N)
(for X in (CDR L) when (IGREATERP MINLENGTH (SETQ N (NCHARS X)))
do (SETQ MINLENGTHWORD X)
(SETQ MINLENGTH N))
(for I to MINLENGTH until (PROG2 (SETQ N (NTHCHARCODE MINLENGTHWORD I))
(find X in L suchthat (NEQ N (NTHCHARCODE X I))))
do NIL finally (RETURN (SUBSTRING MINLENGTHWORD 1 (SUB1 I)))))
(CAR L)
(NCHARS (CAR L))))))
(STRINGTRIM
(LAMBDA (STR CHARSET OLDPTR) (* JonL "27-JAN-83 19:29")
(OR (STRINGP OLDPTR)
(AND OLDPTR (\ILLEGAL.ARG OLDPTR))
(SETQ OLDPTR (ALLOCSTRING 0)))
(\MACRO.MX (STRINGTRIM STR CHARSET OLDPTR))))
(STRINGLEFTTRIM
(LAMBDA (STR CHARSET OLDPTR) (* JonL "27-JAN-83 19:23")
(\MACRO.MX (STRINGLEFTTRIM STR CHARSET OLDPTR))))
(STRINGRIGHTTRIM
(LAMBDA (STR CHARSET OLDPTR) (* JonL "27-JAN-83 19:23")
(\MACRO.MX (STRINGRIGHTTRIM STR CHARSET OLDPTR))))
(\STRINGTRIMAUX
(LAMBDA (STR CHARSET LEFTP OLDPTR) (* JonL "14-SEP-83 21:39")
(SETQ STR (\DTEST STR (QUOTE STRINGP)))
(if (NOT (STRINGP OLDPTR))
then (SETQ OLDPTR (ALLOCSTRING 0)))
(PROG ((CHARTABLEP (type? CHARTABLE CHARSET))
(BASE (fetch (STRINGP BASE) of STR))
(OFFST (fetch (STRINGP OFFST) of STR))
(STRLEN (fetch (STRINGP LENGTH) of STR))
(INCREMENT (if LEFTP
then 1
else -1))
(#STRIPPED 0))
(GLOBALRESOURCE (\STRINGTRIM.BITTABLE)
(if (NOT CHARTABLEP)
then (\ZEROBYTES \STRINGTRIM.BITTABLE 0 (CONSTANT (SUB1 (EXPT 2
BITSPERBYTE))))
(if (LISTP CHARSET)
then (for J in CHARSET do (\STRINGTRIMAUX1
\STRINGTRIM.BITTABLE J))
elseif (STRINGP CHARSET)
then (for J instring CHARSET do (\STRINGTRIMAUX1
\STRINGTRIM.BITTABLE J))
else (\ILLEGAL.ARG CHARSET)))
(for old #STRIPPED from 0 to (SUB1 STRLEN) as J
from (if LEFTP
then OFFST
else (IPLUS OFFST STRLEN -1))
by INCREMENT when (ZEROP (if CHARTABLEP
then (\SYNCODE CHARSET (\GETBASEBYTE BASE J)
)
else (\GETBASEBIT \STRINGTRIM.BITTABLE
(\GETBASEBYTE BASE J))))
do (* So not all the characters of the string were excluded
by the test)
(\FILLINSTRPTR OLDPTR BASE (if LEFTP
then (IPLUS OFFST #STRIPPED)
else OFFST)
(IDIFFERENCE STRLEN #STRIPPED))
(RETURN)
finally (\FILLINSTRPTR OLDPTR NIL 0 0))))
OLDPTR))
(\STRINGTRIMAUX1
(LAMBDA (TABLE J) (* JonL "27-JAN-83 19:32")
(\PUTBASEBIT TABLE (if (CHARCODEP J)
then J
else (CHCON1 J))
1)))
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA \RS232EXEC.LOGFILE.NOTE)
)
(PUTPROPS RS232EXEC COPYRIGHT ("Xerox Corporation" 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3279 28324 (RS232EXEC.ADDUSER 3289 . 3999) (RS232EXEC.DELUSER 4001 . 4330) (
RS232EXEC.SERVER 4332 . 12559) (\RS232EXEC.CHECK.MODEMANSWER 12561 . 14072) (\RS232EXECSERVER.TERPRI
14074 . 14566) (\RS232EXEC.LOGFILE.NOTE 14568 . 14913) (RS232READ&ECHO.LINE 14915 . 21572) (
\RS232.DSPRUBOUTCHAR 21574 . 21967) (\RS232COMMAND.EVAL 21969 . 22399) (\RS232COMMAND.TERM 22401 .
23448) (\RS232COMMAND.SPEED 23450 . 24214) (\RS232COMMAND.LOGIN 24216 . 26732) (\RS232COMMAND.LOGOUT
26734 . 27246) (\RS232COMMAND.CONN 27248 . 28322)) (30877 35902 (MATCHSTRING.FROM.LIST 30887 . 32626)
(FIND.MAXIMAL.SUBSTRING 32628 . 33270) (STRINGTRIM 33272 . 33526) (STRINGLEFTTRIM 33528 . 33697) (
STRINGRIGHTTRIM 33699 . 33870) (\STRINGTRIMAUX 33872 . 35691) (\STRINGTRIMAUX1 35693 . 35900)))))
STOP