(FILECREATED " 8-MAY-83 00:52:26" {PHYLUM}<LISPCORE>FUGUE>RS232COMMANDSERVICE.;7 25011
changes to: (FNS RS232COMMAND.SERVER)
previous date: "22-APR-83 17:20:24" {PHYLUM}<LISPCORE>SOURCES>RS232COMMANDSERVICE.;5)
(* Copyright (c) 1983 by Xerox Corporation)
(PRETTYCOMPRINT RS232COMMANDSERVICECOMS)
(RPAQQ RS232COMMANDSERVICECOMS ((FILES (SYSLOAD)
RS232 RS232LOGIN RS232CHAT)
(DECLARE: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY
(P (OR (GETMACROPROP (QUOTE RS232INITIALIZECHECK)
COMPILERMACROPROPS)
(LOADFROM (QUOTE RS232)))
(OR (RECLOOK (QUOTE RS232CHATEXITSTATE))
(LOADFROM (QUOTE RS232CHAT)))))
(LOCALVARS . T)
(DECLARE: EVAL@COMPILE DONTCOPY (RECORDS RS232COMMANDLSTENTRY
RS232COMMANDUSERSENTRY))
(ADDVARS (RS232COMMANDSERVICE.USERS (JONL "FOOBAR" T))
(RS232COMMANDSERVICE.DIRECTORIES LISPUSERS LISP LISP>CURRENT)
)
(INITVARS (RS232COMMANDSERVICE.DEFAULTLOGFILE (UNPACKFILENAME
"<LISP>COMMANDSERVER>LOGSHEET"))
(\RS232COMMANDSERVER.WHITEBT (MAKEBITTABLE
(CHARCODE (SPACE TAB NULL))))
(\RS232COMMANDSERVER.TIMEOUT.mins 3)
(\RS232COMMANDSERVER.DSRBYPASS NIL))
(GLOBALVARS RS232COMMANDSERVICE.USERS RS232COMMANDSERVICE.DIRECTORIES
\RS232COMMANDSERVER.WHITEBT)
(SPECVARS \RS232COMMANDSERVER.TIMEOUT.mins
\RS232COMMANDSERVER.DSRBYPASS)
(FNS RS232COMMAND.SERVER \RS232COMMANDSERVER.TERPRI
\RS232COMMANDSERVER.WRONGSPEED RS232READ&ECHO.LINE
\RS232COMMAND.EVAL \RS232COMMAND.TERM \RS232COMMAND.SPEED
\RS232COMMAND.LOGIN \RS232COMMAND.CONN)
(ALISTS (RS232COMMANDSLST EVAL TERMINAL QUIT SPEED LOGIN CONN LOGOUT))
(COMS (* Should be elsewhere)
(FNS STRINGENCRYPT)
(GLOBALRESOURCES \STRINGTRIM.BITTABLE)
(MACROS STRINGTRIM \STRINGTRIM.OLDPTR STRINGLEFTTRIM
STRINGRIGHTTRIM)
(FNS MATCHSTRING.FROM.LIST FIND.MAXIMAL.SUBSTRING STRINGTRIM
STRINGLEFTTRIM STRINGRIGHTTRIM \STRINGTRIMAUX
\STRINGTRIMAUX1))))
(FILESLOAD (SYSLOAD)
RS232 RS232LOGIN RS232CHAT)
(DECLARE: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY
(OR (GETMACROPROP (QUOTE RS232INITIALIZECHECK)
COMPILERMACROPROPS)
(LOADFROM (QUOTE RS232)))
(OR (RECLOOK (QUOTE RS232CHATEXITSTATE))
(LOADFROM (QUOTE RS232CHAT)))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: EVAL@COMPILE DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD RS232COMMANDLSTENTRY (COMMANDNAME COMMANDFN COMMANDDOC COMMANDNEEDSLOGIN))
(RECORD RS232COMMANDUSERSENTRY (USERID CRYPTWORD WHEELP))
]
)
(ADDTOVAR RS232COMMANDSERVICE.USERS (JONL "FOOBAR" T))
(ADDTOVAR RS232COMMANDSERVICE.DIRECTORIES LISPUSERS LISP LISP>CURRENT)
(RPAQ? RS232COMMANDSERVICE.DEFAULTLOGFILE (UNPACKFILENAME "<LISP>COMMANDSERVER>LOGSHEET"))
(RPAQ? \RS232COMMANDSERVER.WHITEBT (MAKEBITTABLE (CHARCODE (SPACE TAB NULL))))
(RPAQ? \RS232COMMANDSERVER.TIMEOUT.mins 3)
(RPAQ? \RS232COMMANDSERVER.DSRBYPASS NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS RS232COMMANDSERVICE.USERS RS232COMMANDSERVICE.DIRECTORIES
\RS232COMMANDSERVER.WHITEBT)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(SPECVARS \RS232COMMANDSERVER.TIMEOUT.mins \RS232COMMANDSERVER.DSRBYPASS)
)
(DEFINEQ
(RS232COMMAND.SERVER
(LAMBDA (LOGFILE) (* JonL " 8-MAY-83 00:45")
(\RS232INSURE.LINEBUFFER 580) (* Input buffer is at least as big as the data portion
of an ethernet packet.)
(PROG ((PROMPTMSG "←")
(TIMEOUT.tics (ITIMES \RS232COMMANDSERVER.TIMEOUT.mins 60 \RCLKSECOND))
(SPEED 300)
LOGGEDINP WHEELP DISPLAYTERMP \CLINE \COMM COMMWORDP NCHARS I)
(DECLARE (SPECVARS LOGGEDINP WHEELP DISPLAYTERMP))
(AND (PROG1 RS232COMMANDSERVICE.DEFAULTLOGFILE (* Comment PPLossage))
(NLISTP RS232COMMANDSERVICE.DEFAULTLOGFILE)
(SETQ RS232COMMANDSERVICE.DEFAULTLOGFILE (UNPACKFILENAME
RS232COMMANDSERVICE.DEFAULTLOGFILE)))
(if LOGFILE
then (OR (EQ T LOGFILE)
(type? STREAM LOGFILE)
(SETQ LOGFILE (if (OR (LITATOM LOGFILE)
(STINGP LOGFILE))
then (PACKFILENAME (NCONC (UNPACKFILENAME LOGFILE)
RS232COMMANDSERVICE.DEFAULTLOGFILE)
)
else T)))
(SETQ LOGFILE (if (SETQ I (OPENP LOGFILE (QUOTE APPEND)))
then I
else (if (OPENP LOGFILE)
then (CLOSEF LOGFILE))
(OPENFILE LOGFILE (QUOTE APPEND))))
(printout LOGFILE T T "Commencement of RS232 CommandServer Service is at "
(GDATE)
T))
(GO A)
QUIT(RS232MODEMCONTROL NIL)
(BLOCK 5000)
A (SETQ LOGGEDINP (SETQ WHEELP (SETQ DISPLAYTERMP NIL)))
(CNDIR (QUOTE {DSK}))
(RS232INIT (SETQ SPEED 1200))
(RS232MODEMCONTROL (QUOTE (DTR RTS))) (* Wait until we hear someone who has dialed-in, and
whom the modem has answered.)
(until (OR \RS232COMMANDSERVER.DSRBYPASS (RS232MODEMSTATUSP (QUOTE (OR RI DSR))))
do (\RS232CHECK.BLOCK))
TRYSPEED
(if (AND (NULL \RS232COMMANDSERVER.DSRBYPASS)
(SETQ I (\RS232COMMANDSERVER.WRONGSPEED TIMEOUT.tics)))
then (if (OR (EQ I (QUOTE TIMEREXPIRED?))
(EQ SPEED 300))
then (AND LOGFILE \RS232COMMANDSERVER.DSRBYPASS (printout LOGFILE (GDATE)
.TAB 24
"Connection failure (wrong speed?)"
T))
(GO QUIT)
else (RS232INIT (SETQ SPEED 300))
(GO TRYSPEED)))
B (SETQ \CLINE (RS232READ&ECHO.LINE PROMPTMSG TIMEOUT.tics DISPLAYTERMP NIL T
RS232COMMANDSLST))
(if (NOT (STRINGP \CLINE))
then (SELECTQ \CLINE
((QUIT)
(if (RS232MODEMSTATUSP (QUOTE DSR))
then (\RS232COMMANDSERVER.TERPRI)
(SETQ I (CONCAT "Auto QUIT (idle for more than " (MKSTRING
\RS232COMMANDSERVER.TIMEOUT.mins)
" minutes)"))
(RS232WRITECHARS I)
(\RS232COMMANDSERVER.TERPRI)
(RS232WRITEBYTE (CHARCODE ↑G)
T)
(AND LOGFILE (printout LOGFILE (GDATE)
.TAB 28 I T)))
(GO QUIT))
((RS232CLEARBUFFER)
(\RS232COMMANDSERVER.TERPRI)
(RS232WRITECHARS "Input buffer capacity exceeded -- try again!")
(\RS232COMMANDSERVER.TERPRI)
(RS232CLEARBUFFER (QUOTE INPUT))
(GO B))
(SHOULDNT))) (* Trim "white space" chars off right end of line --
RS232READ&ECHO.LINE doesn't allow them to accumulate on
the left)
(SETQ \CLINE (STRINGRIGHTTRIM \CLINE \RS232COMMANDSERVER.WHITEBT))
(if (ZEROP (SETQ NCHARS (fetch (STRINGP LENGTH) of \CLINE)))
then (GO B)
elseif (SETQ I (STRPOSL \RS232COMMANDSERVER.WHITEBT \CLINE))
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))
(SELECTQ (AND \COMM (fetch (RS232COMMANDLSTENTRY COMMANDNAME) of \COMM))
((NIL) (* Looks like he doesn't know what he's doing)
(RS232WRITECHARS " ??" T)
(GO B))
((LOGOUT QUIT)
(\RS232COMMANDSERVER.TERPRI)
(RS232WRITECHARS "Bye, bye.")
(\RS232COMMANDSERVER.TERPRI)
(if LOGFILE
then (printout LOGFILE (GDATE)
.TAB 24 "LOGOUT ")
(if LOGGEDINP
then (printout LOGFILE "of user " LOGGEDINP " "))
(TERPRI LOGFILE))
(GO QUIT))
((EVAL)
(if (NOT WHEELP)
then (RS232WRITECHARS " ??" T)
(GO B)))
(if (AND (NOT LOGGEDINP)
(fetch (RS232COMMANDLSTENTRY COMMANDNEEDSLOGIN) of \COMM))
then (RS232WRITECHARS " Not logged in ??" T)
(GO B)))
(SETQ \CLINE (AND I (SETQ I (STRPOSL \RS232COMMANDSERVER.WHITEBT \CLINE (ADD1 I)
T))
(SUBSTRING \CLINE I NIL \CLINE)))
(\RS232COMMANDSERVER.TERPRI)
(if (SETQ \COMM (NLSETQ (APPLY* (fetch (RS232COMMANDLSTENTRY COMMANDFN) of \COMM)
\CLINE)))
then (RS232WRITECHARS " ==> ")
(RS232WRITECHARS (MKSTRING (CAR \COMM)))
else (RS232WRITECHARS " [Error: ")
(RS232WRITECHARS (ERRORSTRING (CAR (SETQ \COMM (ERRORN)))))
(RS232WRITECHARS " ")
(RS232WRITECHARS (MKSTRING (CADR \COMM)))
(RS232WRITECHARS " ]"))
(RS232FORCEOUTPUT)
(GO B))))
(\RS232COMMANDSERVER.TERPRI
(LAMBDA NIL (* JonL "14-APR-83 14:27")
(* 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.)
(for C instring \RS232CHAT.EOLsequence
do (RS232WRITEBYTE C T)
(\RS232CHECK.BLOCK 10))
(SERVICEIRING)
T))
(\RS232COMMANDSERVER.WRONGSPEED
(LAMBDA (TIMEOUT.tics) (* JonL "27-JAN-83 23:29")
(PROG ((RS232LOSTCHARFN (FUNCTION (LAMBDA (X)
(AND (EQ X (QUOTE FramingError))
(RETFROM (QUOTE \RS232COMMANDSERVER.WRONGSPEED)
T)))))
(TIMEOUTP NIL))
(DECLARE (SPECVARS RS232LOSTCHARFN))
(during TIMEOUT.tics
timerUnits (QUOTE TICS)
do (if (RS232PEEKBYTE)
then (RETURN))
finally (SETQ TIMEOUTP (QUOTE TIMEREXPIRED?)))
(RETURN TIMEOUTP))))
(RS232READ&ECHO.LINE
(LAMBDA (PROMPTSTRING TIMEOUT.tics DISPLAYTERMP NOECHOP COMMANDLINEP COMMANDS.ALIST)
(* JonL "22-APR-83 14:47")
(PROG ((NCHARS 0)
C CLINE COMM COMMWORDP RUBBING?)
BEGIN
(\RS232COMMANDSERVER.TERPRI)
(RS232WRITECHARS PROMPTSTRING T)
(SETQ NCHARS 0)
(SETQ CLINE \RS232STRPTR)
(replace (STRINGP BASE) of CLINE with \RS232LINEBUFFER)
(replace (STRINGP LENGTH) of CLINE with 0)
(replace (STRINGP OFFST) of CLINE with 0)
(SETQ RUBBING?)
(SETQ COMMWORDP COMMANDLINEP)
GETNEXTBYTE
(if (NULL (SETQ C (RS232READBYTE TIMEOUT.tics (QUOTE TICS))))
then (* Flush him if he's idle too long)
(RETURN (QUOTE QUIT)))
CHECKBYTE
(SELCHARQ C
((↑A BS DEL)
(if (ZEROP NCHARS)
then (if RUBBING?
then (SETQ RUBBING?)
(if (NOT NOECHOP)
then (RS232WRITEBYTE (CHARCODE \))))
else (add NCHARS -1)
(SETQ C (GLC CLINE))
(if NOECHOP
then NIL
elseif DISPLAYTERMP
then (RS232WRITEBYTE ERASECHARCODE)
else (if (NOT RUBBING?)
then (RS232WRITEBYTE (SETQ RUBBING? (CHARCODE \))))
(RS232WRITEBYTE (CHCON1 C))
(if (ZEROP NCHARS)
then (RS232WRITEBYTE (CHARCODE \))
(GO BEGIN))))
(RS232FORCEOUTPUT)
(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.)
)
(\RS232COMMANDSERVER.TERPRI)
(RS232WRITECHARS PROMPTSTRING)
(for BYTE instring CLINE do (RS232WRITEBYTE BYTE)))
(SETQ RUBBING?)
(RS232FORCEOUTPUT)
(GO GETNEXTBYTE))
((↑V)
(if (NULL (SETQ C (RS232READBYTE TIMEOUT.tics (QUOTE TICS))))
then (RETURN (QUOTE QUIT))))
((?)
(if COMMANDLINEP
then (MAPC COMMANDS.ALIST (FUNCTION (LAMBDA (X)
(\RS232COMMANDSERVER.TERPRI)
(RS232WRITECHARS (fetch (RS232COMMANDLSTENTRY COMMANDNAME)
of X))
(RS232WRITEBYTE (CHARCODE SPACE))
(RS232WRITECHARS (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 ((MULTIPLES (LISTP COMM))
(M (fetch (STRINGP LENGTH) of CLINE))
N)
(if MULTIPLES
then (SETQ COMM (FIND.MAXIMAL.SUBSTRING COMM)))
(OR (STRINGP COMM)
(SETQ COMM (MKSTRING COMM)))
(SETQ NCHARS (SETQ N (fetch (STRINGP LENGTH)
of COMM)))
(OR MULTIPLES (add NCHARS 1))
(replace (STRINGP LENGTH) of CLINE with NCHARS)
(if (NEQ N M)
then (SETQ COMM (SUBSTRING COMM (ADD1 M)))
(RPLSTRING CLINE (ADD1 M)
COMM)
(RS232WRITECHARS COMM))
(RS232WRITEBYTE (if MULTIPLES
then (CHARCODE ↑G)
else
(* Win! A perfect match!)
(RPLCHARCODE CLINE (ADD1 N)
(CHARCODE SPACE))
(CHARCODE SPACE))))
else (RS232WRITEBYTE (CHARCODE ↑G)))
(RS232FORCEOUTPUT)
(GO GETNEXTBYTE)))
((EOL CR LF) (* Currently, only these guys are permitted to terminate
such "line")
(RETURN CLINE))
(if (AND COMMANDLINEP (EQ 1 (\SYNCODE \RS232COMMANDSERVER.WHITEBT C)))
then (* We don't include "white space" characters at the
beginning of the line)
(if (ZEROP NCHARS)
then (GO GETNEXTBYTE)
elseif (NEQ C (CHARCODE NULL))
then (* Most "white space" characters will terminate a word.)
(SETQ COMMWORDP))))
(if RUBBING?
then (OR NOECHOP (RS232WRITEBYTE (CHARCODE \)))
(SETQ RUBBING?))
(\PUTBASEBYTE \RS232LINEBUFFER NCHARS C)
(replace (STRINGP LENGTH) of \RS232STRPTR with (add NCHARS 1))
(if (IGEQ NCHARS \RS232LINEBUFFER.SIZE)
then (RETURN (QUOTE RS232CLEARBUFFER))) (* Now for the normal echo of his typed-in character)
(OR NOECHOP (RS232WRITEBYTE C T))
(GO GETNEXTBYTE))))
(\RS232COMMAND.EVAL
(LAMBDA (STR) (* JonL "14-APR-83 16:05")
(DECLARE (GLOBALVARS \STRINGOFDS))
(AND (STRINGP STR)
(PROG ((Z (READ STR)))
(PUTHASH STR NIL \STRINGOFDS)
(RETURN (EVAL Z))))))
(\RS232COMMAND.TERM
(LAMBDA (STR) (* JonL "14-APR-83 16:05")
(* DISPLAYTERMP should be a FVAR bound by
RS232COMMAND.SERVER)
((LAMBDA (I)
(if (OR (NOT (STRINGP STR))
(ZEROP (NCHARS (SETQ STR (STRINGRIGHTTRIM STR \RS232COMMANDSERVER.WHITEBT))))
(AND (SETQ I (STRPOS "DE" (SETQ STR (U-CASE STR))))
(IGREATERP I (OR (STRPOSL \RS232COMMANDSERVER.WHITEBT STR)
0))))
then (RS232WRITECHARS (if DISPLAYTERMP
then " DISPLAY"
else " STANDARD"))
(\RS232COMMANDSERVER.TERPRI)
else (SETQ DISPLAYTERMP (AND (SETQ I (STRPOS "DI" STR))
(IGREATERP I (OR (STRPOSL \RS232COMMANDSERVER.WHITEBT STR)
0)))))))))
(\RS232COMMAND.SPEED
(LAMBDA (STR) (* JonL "22-APR-83 14:01")
(PROG ((Z (READ STR)))
(PUTHASH STR NIL \STRINGOFDS)
(APPLY (FUNCTION RS232INIT)
(CONS Z (CDR RS232INIT)))
(RS232SETMODEMCONTROL RTS))))
(\RS232COMMAND.LOGIN
(LAMBDA (NAME) (* JonL "19-APR-83 07:22")
(PROG ((USERINFO (FASSOC (SETQ NAME (U-CASE (MKATOM NAME)))
RS232COMMANDSERVICE.USERS))
CRYPTWORD PASSW)
(DECLARE (SPECVARS LOGGEDINP WHEELP))
(OR USERINFO (ERROR "Unknown user name"))
(OR (SETQ LOGGEDINP (AND (SETQ PASSW (RS232READ&ECHO.LINE " (PASSWORD) "
(DEFERREDCONSTANT (ITIMES 60
\RCLKSECOND))
DISPLAYTERMP T))
(EQUAL (STRINGENCRYPT (U-CASE PASSW))
(fetch (RS232COMMANDUSERSENTRY CRYPTWORD) of USERINFO))
NAME))
(ERROR " wrong password"))
(SETQ WHEELP (fetch (RS232COMMANDUSERSENTRY WHEELP) of USERINFO))
(RETURN (QUOTE OK)))))
(\RS232COMMAND.CONN
(LAMBDA (STR) (* JonL "14-APR-83 17:43")
(PROG (LEN LEFTP RIGHTP DIR)
(if (OR (NOT (STRINGP STR))
(ZEROP (SETQ LEN (fetch (STRINGP LENGTH) of STR))))
then (RETURN (CNDIR (QUOTE {DSK})))
elseif (STRPOSL (QUOTE ({ }))
STR)
then (ERROR " Device specification not permitted"))
(SETQ LEFTP (NEQ (NTHCHARCODE STR 1)
(CHARCODE <)))
(SETQ RIGHTP (NEQ (NTHCHARCODE STR LEN)
(CHARCODE >)))
(if (OR LEFTP RIGHTP)
then (SETQ STR (CONCAT (if LEFTP
then "<"
else "")
STR
(if RIGHTP
then ">"
else ""))))
(SETQ DIR (FILENAMEFIELD STR (QUOTE DIRECTORY)))
(OR (FMEMB DIR RS232COMMANDSERVICE.DIRECTORIES)
(ERROR " not a permitted directory"))
(RETURN (CNDIR DIR)))))
)
(ADDTOVAR RS232COMMANDSLST (EVAL \RS232COMMAND.EVAL "{s-expression}" T)
(TERMINAL \RS232COMMAND.TERM "{DISPLAY or not}")
(QUIT NIL " | Quit and Logout.")
(SPEED \RS232COMMAND.SPEED "{change RS232 speed -- decimal number}")
(LOGIN \RS232COMMAND.LOGIN "Login for Command service")
(CONN \RS232COMMAND.CONN
"Connect to directory (on local file server), or to {DSK} if no arg"
T)
(LOGOUT NIL " | Quit and Logout."))
(* Should be elsewhere)
(DEFINEQ
(STRINGENCRYPT
(LAMBDA (STR) (* JonL "14-APR-83 16:48")
(* Eventually this will take a STRINGP input, and encrypt it using some "secure" standard
(such as DES) and return a STRINGP as the result)
STR))
)
(RPAQQ \STRINGTRIM.BITTABLE NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \STRINGTRIM.BITTABLE)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(PUTDEF (QUOTE \STRINGTRIM.BITTABLE)
(QUOTE GLOBALRESOURCES)
(QUOTE (\ALLOCBLOCK (CONSTANT (FOLDHI (EXPT 2 BITSPERBYTE)
BITSPERCELL)))))
)
(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 "29-JAN-83 18:21")
(* 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.)
(OR (STRINGP STR)
(SETQ STR (MKSTRING STR)))
(for Y in L bind ITEM EXACTMATCH FIRSTPARTIALMATCH MULTIPLES TESTSTR STRPTR
(#CHARS.STR ←(fetch (STRINGP LENGTH) of STR))
do (SETQ ITEM (if ALISTFLG
then (CAR Y)
else Y))
(OR (STRINGP (SETQ TESTSTR ITEM))
(SETQ TESTSTR (SUBSTRING TESTSTR 1 NIL (OR STRPTR (SETQ STRPTR (ALLOCSTRING 0))))))
(if (STRPOS STR TESTSTR 1 NIL T)
then (if (EQ #CHARS.STR (fetch (STRINGP LENGTH) of 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)))
finally (RETURN (if (NULL MULTIPLES)
then (OR EXACTMATCH FIRSTPARTIALMATCH)
else (if EXACTMATCH
then (push MULTIPLES EXACTMATCH))
MULTIPLES)))))
(FIND.MAXIMAL.SUBSTRING
(LAMBDA (L) (* JonL "29-JAN-83 17:58")
(if (NLISTP L)
then (ALLOCSTRING 0)
else ((LAMBDA (MINLENGTH MINLENGTHWORD N)
(for X in L do (if (IGREATERP MINLENGTH (SETQ N (NCHARS X)))
then (SETQ MINLENGTH N)
(SETQ MINLENGTHWORD X)))
(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)))))
MAX.FIXP))))
(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 "27-JAN-83 19:48")
(SETQ STR (\DTEST STR (QUOTE STRINGP)))
((LAMBDA (CHARTABLEP STRLEN BASE OFFST STARTINDEX INCREMENT BYTE #STRIPPED)
(GLOBALRESOURCE (\STRINGTRIM.BITTABLE)
(if (NOT LEFTP)
then (SETQ STARTINDEX STRLEN)
(SETQ INCREMENT -1))
(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)))
(if (NOT (STRINGP OLDPTR))
then (SETQ OLDPTR (ALLOCSTRING 0)))
(replace (STRINGP BASE) of OLDPTR with BASE)
(SETQ BASE (\ADDBASE BASE OFFST))
(SETQ #STRIPPED (for I to STRLEN as J from (SUB1 STARTINDEX) by INCREMENT
do (SETQ BYTE (\GETBASEBYTE BASE J))
(if (ZEROP (if CHARTABLEP
then (\SYNCODE CHARSET BYTE)
else (\GETBASEBIT \STRINGTRIM.BITTABLE
BYTE)))
then (RETURN (SUB1 I)))
finally (RETURN STRLEN)))
(replace (STRINGP LENGTH) of OLDPTR with (IDIFFERENCE STRLEN #STRIPPED))
(replace (STRINGP OFFST) of OLDPTR with (if LEFTP
then (IPLUS OFFST #STRIPPED)
else OFFST))))
(type? CHARTABLE CHARSET)
(fetch (STRINGP LENGTH) of STR)
(fetch (STRINGP BASE) of STR)
(fetch (STRINGP OFFST) of STR)
1 1)
OLDPTR))
(\STRINGTRIMAUX1
(LAMBDA (TABLE J) (* JonL "27-JAN-83 19:32")
(\PUTBASEBIT TABLE (if (CHARCODEP J)
then J
else (CHCON1 J))
1)))
)
(PUTPROPS RS232COMMANDSERVICE COPYRIGHT ("Xerox Corporation" 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3306 18481 (RS232COMMAND.SERVER 3316 . 8913) (\RS232COMMANDSERVER.TERPRI 8915 . 9402) (
\RS232COMMANDSERVER.WRONGSPEED 9404 . 9984) (RS232READ&ECHO.LINE 9986 . 15303) (\RS232COMMAND.EVAL
15305 . 15579) (\RS232COMMAND.TERM 15581 . 16407) (\RS232COMMAND.SPEED 16409 . 16699) (
\RS232COMMAND.LOGIN 16701 . 17516) (\RS232COMMAND.CONN 17518 . 18479)) (18981 19278 (STRINGENCRYPT
18991 . 19276)) (20136 24921 (MATCHSTRING.FROM.LIST 20146 . 21654) (FIND.MAXIMAL.SUBSTRING 21656 .
22285) (STRINGTRIM 22287 . 22541) (STRINGLEFTTRIM 22543 . 22712) (STRINGRIGHTTRIM 22714 . 22885) (
\STRINGTRIMAUX 22887 . 24710) (\STRINGTRIMAUX1 24712 . 24919)))))
STOP