(FILECREATED "11-Jan-84 17:36:16" {PHYLUM}<LISPCORE>SOURCES>PASSWORDS.;46 67741Q
changes to: (FNS \LOGIN.READ \INTERNAL/GETPASSWORD)
previous date: " 3-Jan-84 13:33:37" {PHYLUM}<LISPCORE>SOURCES>PASSWORDS.;45)
(* Copyright (c) 1982, 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT PASSWORDSCOMS)
(RPAQQ PASSWORDSCOMS [(FNS LOGIN SETPASSWORD \LOGIN.READ \INTERNAL/GETPASSWORD \ADJUST.USERNAME
\ENCRYPT.PWD \DECRYPT.PWD)
[DECLARE: DONTEVAL@LOAD COPYWHEN (NEQ (COMPILEMODE)
(QUOTE D))
(* INTERLISP-D handles this special)
(ADDVARS (BEFORESYSOUTFORMS (CLRHASH LOGINPASSWORDS))
(BEFOREMAKESYSFORMS (CLRHASH LOGINPASSWORDS]
(P (MOVD? (QUOTE NILL)
(QUOTE CLBUFS))
(MOVD? (QUOTE NILL)
(QUOTE CREATE.MONITORLOCK)))
(INITVARS (LOGINPASSWORDS (HASHARRAY 10Q))
(\GETPASSWORD.LOCK (CREATE.MONITORLOCK "GetPassword"))
(DEFAULTREGISTRY)
(\AFTERLOGINFNS))
(DECLARE: EVAL@COMPILE DONTCOPY (GLOBALVARS LOGINPASSWORDS USERNAME
\GETPASSWORD.LOCK DEFAULTREGISTRY
\AFTERLOGINFNS)
(PROP DMACRO EMPASSWORDLOC)
(EXPORT (MACROS \DECRYPT.PWD.CHAR))
(LOCALVARS . T))
(COMS (* This should be elsewhere)
(FNS \BITMAPHORIZONTALEXTENT))
(COMS (* Here is the real PROMPTFORWORD stuff)
(FNS PROMPTFORWORD \PROMPTFORWORDBIN \PROMPTFORWORDERASE
\PROMPTFORWORDBOUT)
(DECLARE: EVAL@COMPILE DONTCOPY (CONSTANTS (\PROMPTFORWORD.BUFFERSIZE
400Q))
(GLOBALVARS \PROMPTFORWORDTTBL \PROMPTFORWORD.BUFFER
\PROMPTFORWORD.LOCK \PROMPTFORWORD.TIMER)
(SPECVARS TERMINCHARS.LST))
(DECLARE: DONTEVAL@LOAD DOCOPY (INITVARS (\PROMPTFORWORDTTBL NIL)
(\PROMPTFORWORD.BUFFER NIL)
(\PROMPTFORWORD.LOCK
(CREATE.MONITORLOCK
"PromptForWord"))
(\PROMPTFORWORD.TIMER
(SETUPTIMER 0])
(DEFINEQ
(LOGIN
(LAMBDA (HOST FLG DIRECTORY MSG) (* JonL "19-JUL-83 04:13")
(* Hacked by bvm " 2-MAR-83 12:42")
(* Forces a login at HOST optionally connecting to DIRECTORY, and returns the name logged in.
MSG is optional message string to print before asking)
(CAR (\INTERNAL/GETPASSWORD HOST (NEQ FLG (QUOTE QUIET))
DIRECTORY MSG))))
(SETPASSWORD
[LAMBDA (HOST USER PASSWORD DIRECTORY) (* bvm: " 3-NOV-83 22:14")
(PROG [(INFO (GETHASH HOST LOGINPASSWORDS))
(ENCRYPTED (\ENCRYPT.PWD (CONCAT PASSWORD]
(SETQ USER (\DTEST USER (QUOTE LITATOM)))
[COND
[DIRECTORY (SETQ DIRECTORY (\DTEST DIRECTORY (QUOTE LITATOM)))
(RPLACD (OR INFO (SETQ INFO (PUTHASH HOST (CONS)
LOGINPASSWORDS)))
(CONS (CONS DIRECTORY ENCRYPTED)
(CDR INFO]
(T (FRPLACA (OR INFO (PUTHASH HOST (CONS)
LOGINPASSWORDS))
(CONS USER ENCRYPTED]
(RETURN HOST])
(\LOGIN.READ
[LAMBDA (HOST DEFAULTNAME MSG CONNECTFLG OSTYPE) (* bvm: "11-Jan-84 17:34")
[COND
((AND HOST (NOT OSTYPE)
(STRPOS ":" HOST))
(SETQ OSTYPE (QUOTE NS]
(PROG [(PROMPT (COND
((EQ OSTYPE (QUOTE NS))
"Login (<return> to terminate): ")
(T "Login: ")))
(HELPFN
"
You are being asked for a user name and password for login.
Type <return> to accept the given user name, or <BS> to back
up over it, or type a new name followed by <return>.
")
(TERMINATIONS (COND
((EQ OSTYPE (QUOTE NS))
(CHARCODE (CR LF)))
(T (* default)
NIL]
(COND
(CONNECTFLG (SETQ PROMPT (CONCAT "Connect password for " DEFAULTNAME ": "))
(SETQ HELPFN "Type <return> followed by the password for the directory.
")))
[COND
(HOST (SETQ PROMPT (CONCAT "{" HOST "} " PROMPT]
[COND
(MSG (SETQ PROMPT (CONCAT MSG (CONSTANT (CHARACTER (CHARCODE EOL)))
PROMPT]
(FRESHLINE T)
(RETURN (PROG1 [COND
(CONNECTFLG (CONS DEFAULTNAME (PROMPTFORWORD PROMPT NIL NIL T
(QUOTE *)
NIL TERMINATIONS)))
(T (RESETLST [OR (TTY.PROCESSP)
(RESETSAVE (TTY.PROCESS (THIS.PROCESS]
(RESETBUFS (PROG ((NAME (PROMPTFORWORD PROMPT DEFAULTNAME
HELPFN T NIL NIL
TERMINATIONS)))
[COND
((AND HOST DEFAULTREGISTRY
(SELECTQ OSTYPE
((NIL IFS)
T)
NIL)
(NOT (STRPOS "." NAME)))
(PRIN1 "." T)
(PRIN1 DEFAULTREGISTRY T)
(SETQ NAME (CONCAT NAME "."
DEFAULTREGISTRY]
(RETURN (CONS (MKATOM NAME)
(PROMPTFORWORD " (password) "
NIL NIL T
(QUOTE *]
(FRESHLINE T])
(\INTERNAL/GETPASSWORD
[LAMBDA (HOST ALWAYSASK DIRECTORY MSG DEFAULTNAME) (* bvm: "11-Jan-84 17:34")
(* returns (name . password) with which to login (or connect if DIRECTORY given) at HOST, performing an alto-style
login if necessary, or if ALWAYSASK is true. MSG is optional message string to print before asking)
(PROG ((INFO (GETHASH HOST LOGINPASSWORDS))
INFOCHANGED PWD PASSWORDADDR NAME/PASS NEWNAME/PASS DISKNAME OSTYPE)
(COND
([AND (NOT ALWAYSASK)
(SETQ NAME/PASS (COND
(DIRECTORY (ASSOC DIRECTORY (CDR INFO)))
(T (CAR INFO] (* We already have login info)
(RETURN NAME/PASS)))
[SETQ RESULT
(WITH.MONITOR
\GETPASSWORD.LOCK (* Don't grab the monitor til now, since we don't really
care if what we fetched above was about to change)
(CAR (NLSETQ
(PROG (PWD PASSWORDADDR NEWNAME/PASS DISKNAME OSTYPE)
(COND
(DIRECTORY (OR INFO (SETQ INFO (PUTHASH HOST (CONS)
LOGINPASSWORDS)))
[SETQ NEWNAME/PASS (COND
((NULL ALWAYSASK)
(* First time, guess that no password is needed)
(CONS DIRECTORY ""))
(T (\LOGIN.READ HOST DIRECTORY MSG T]
[COND
(NEWNAME/PASS
(COND
[(AND NAME/PASS (EQ (CAR NAME/PASS)
(CAR NEWNAME/PASS)))
(RPLACD NAME/PASS (\ENCRYPT.PWD (CDR NEWNAME/PASS]
(T (RPLACD INFO (CONS (CONS (CAR NEWNAME/PASS)
(\ENCRYPT.PWD (CDR
NEWNAME/PASS)))
(CDR INFO]
(RETURN NEWNAME/PASS))
(T [COND
((EQ (SYSTEMTYPE)
(QUOTE D))
[SETQ OSTYPE (COND
(HOST (GETOSTYPE HOST))
(T (QUOTE LOCAL]
(COND
([NOT (ZEROP (SETQ PASSWORDADDR (EMPASSWORDLOC]
(SETQ PASSWORDADDR (EMPOINTER PASSWORDADDR]
(SETQ DISKNAME (\ADJUST.USERNAME (USERNAME NIL T T)
OSTYPE))
[SETQ DEFAULTNAME (COND
((NOT DEFAULTNAME)
(OR (CAAR INFO)
DISKNAME))
(T (\ADJUST.USERNAME DEFAULTNAME OSTYPE]
[COND
[(AND (NULL ALWAYSASK)
PASSWORDADDR
(EQ DEFAULTNAME DISKNAME)
(IGREATERP (NCHARS (SETQ PWD (GetBcplString PASSWORDADDR)))
0))
(SETQ NAME/PASS (CONS DEFAULTNAME (COND
((EQ OSTYPE (QUOTE UNIX))
(L-CASE PWD))
(T PWD]
(T (SETQ NAME/PASS (\LOGIN.READ HOST DEFAULTNAME MSG NIL OSTYPE))
(SETQ INFOCHANGED T)
(COND
((EQ OSTYPE (QUOTE NS))
(* Don't touch alto login)
)
[(EQ (CAR NAME/PASS)
DISKNAME)
(AND PASSWORDADDR (SetBcplString PASSWORDADDR (CDR NAME/PASS]
([OR (NULL HOST)
(AND PASSWORDADDR DISKNAME (ZEROP (\GETBASE PASSWORDADDR
0))
(NEQ (U-CASE (CAR NAME/PASS))
(QUOTE GUEST]
(* There was no password before, or user forced login)
(AND (GETD (QUOTE SETUSERNAME))
(SETUSERNAME (CAR NAME/PASS)))
(AND PASSWORDADDR (SetBcplString PASSWORDADDR (CDR NAME/PASS]
(COND
((NULL HOST)
(CLRHASH LOGINPASSWORDS)
(SETQ INFO)))
(\ENCRYPT.PWD (CDR NAME/PASS))
(FRPLACA (OR INFO (PUTHASH HOST (CONS)
LOGINPASSWORDS))
NAME/PASS)))
(RETURN NAME/PASS]
[COND
((AND INFOCHANGED RESULT)
(for FN in \AFTERLOGINFNS
do (* Report change to any user packages that cache user
info)
(APPLY* FN HOST (CAR RESULT]
(RETURN RESULT])
(\ADJUST.USERNAME
[LAMBDA (NAME OSTYPE) (* bvm: "10-NOV-83 21:00")
(PROG (POS)
(SELECTQ OSTYPE
[(NIL IFS)
(COND
((AND DEFAULTREGISTRY (NOT (STRPOS "." NAME)))
(SETQ NAME (PACK* NAME "." DEFAULTREGISTRY]
[LOCAL (COND
((SETQ POS (STRPOS "." NAME)) (* For folks who login at the alto exec using a
registry, get rid of it)
(SETQ NAME (SUBSTRING NAME 1 (SUB1 POS]
(UNIX (SETQ NAME (L-CASE NAME)))
[NS (COND
((AND CH.DEFAULT.DOMAIN (NOT (STRPOS (QUOTE :)
NAME)))
(SETQ NAME (PACK* NAME (QUOTE :)
CH.DEFAULT.DOMAIN]
NIL)
(RETURN NAME])
(\ENCRYPT.PWD
[LAMBDA (STR) (* bvm: " 3-NOV-83 22:09")
(* * Destructively disguises the characters of STR so that passwords are not stored in clear text anywhere.
Decode with \DECRYPT.PWD, or macro \DECRYPT.PWD.CHAR)
(for I from 1 do (RPLCHARCODE STR I (LOGXOR (OR (NTHCHARCODE STR I)
(RETURN STR))
73])
(\DECRYPT.PWD
[LAMBDA (STR) (* bvm: " 3-NOV-83 22:09")
(* undoes \ENCRYPT.PWD. Easy, it being its own inverse)
(\ENCRYPT.PWD (CONCAT STR])
)
(DECLARE: DONTEVAL@LOAD COPYWHEN (NEQ (COMPILEMODE)
(QUOTE D))
(* INTERLISP-D handles this special)
(ADDTOVAR BEFORESYSOUTFORMS (CLRHASH LOGINPASSWORDS))
(ADDTOVAR BEFOREMAKESYSFORMS (CLRHASH LOGINPASSWORDS))
)
(MOVD? (QUOTE NILL)
(QUOTE CLBUFS))
(MOVD? (QUOTE NILL)
(QUOTE CREATE.MONITORLOCK))
(RPAQ? LOGINPASSWORDS (HASHARRAY 10Q))
(RPAQ? \GETPASSWORD.LOCK (CREATE.MONITORLOCK "GetPassword"))
(RPAQ? DEFAULTREGISTRY )
(RPAQ? \AFTERLOGINFNS )
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS LOGINPASSWORDS USERNAME \GETPASSWORD.LOCK DEFAULTREGISTRY \AFTERLOGINFNS)
)
(PUTPROPS EMPASSWORDLOC DMACRO [LAMBDA NIL (* lmm "24-MAR-83 06:46")
(fetch (IFPAGE UserPswdAddr)
of \InterfacePage])
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS \DECRYPT.PWD.CHAR MACRO ((CHAR)
(LOGXOR CHAR 111Q)))
)
(* END EXPORTED DEFINITIONS)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(* This should be elsewhere)
(DEFINEQ
(\BITMAPHORIZONTALEXTENT
(LAMBDA (BM) (* JonL "10-NOV-83 07:32")
(for X (HEIGHT ←(BITMAPHEIGHT BM)) from (SUB1 (BITMAPWIDTH BM)) by -1 to 0
do (if (find Y from 0 to (SUB1 HEIGHT) suchthat (NOT (ZEROP (BITMAPBIT BM X Y))))
then (RETURN (ADD1 X)))
finally (RETURN 0))))
)
(* Here is the real PROMPTFORWORD stuff)
(DEFINEQ
(PROMPTFORWORD
(LAMBDA (PROMPT.STR CANDIDATE.STR GENERATE?LIST.FN ECHO.CHANNEL DONTECHOTYPEIN.FLG TIMELIMIT.secs
TERMINCHARS.LST KEYBD.CHANNEL OLDSTRING)
(* JonL "10-NOV-83 08:36")
(DECLARE (SPECVARS TERMINCHARS.LST))
(RESETLST (OBTAIN.MONITORLOCK \PROMPTFORWORD.LOCK NIL T)
(* Don't let this guy go anywhere
(not even error checking) until the previous guy is
finished)
(if (AND PROMPT.STR (NOT (STRINGP PROMPT.STR)))
then (SETQ PROMPT.STR (MKSTRING PROMPT.STR)))
(if CANDIDATE.STR
then (SETQ CANDIDATE.STR (MKSTRING CANDIDATE.STR))
(if (ZEROP (NCHARS CANDIDATE.STR))
then (SETQ CANDIDATE.STR)))
(SETQ ECHO.CHANNEL (\OUTSTREAMARG (OR ECHO.CHANNEL T)))
(if (NULL TERMINCHARS.LST)
then (SETQ TERMINCHARS.LST (CHARCODE (EOL ESCAPE SPACE LF TAB)))
elseif (CHARCODEP TERMINCHARS.LST)
then (SETQ TERMINCHARS.LST (MKLIST TERMINCHARS.LST))
elseif (OR (NLISTP TERMINCHARS.LST)
((LAMBDA (CONVERTIBLEP LOSERP)
(for C in TERMINCHARS.LST
do (if (NOT (CHARCODEP C))
then (if (AND (OR (LITATOM C)
(STRINGP C))
(EQ 1 (NCHARS C)))
then (SETQ CONVERTIBLEP T)
else (RETURN (SETQ LOSERP T)))))
(if (AND CONVERTIBLEP (NOT LOSERP))
then (SETQ TERMINCHARS.LST (MAPCAR TERMINCHARS.LST
(FUNCTION (LAMBDA (C)
(OR (FIXP C)
(CHCON1 C)))))))
LOSERP)))
then (\ILLEGAL.ARG TERMINCHARS.LST))
(if (AND TIMELIMIT.secs (NOT (FIXP TIMELIMIT.secs)))
then (\ILLEGAL.ARG TIMELIMIT.secs))
(if (AND OLDSTRING (NOT (STRINGP OLDSTRING)))
then (\ILLEGAL.ARG OLDSTRING)
elseif (AND (OR (NULL OLDSTRING)
(IGEQ 2 (ffetch (STRINGP LENGTH) of OLDSTRING)))
(NOT (type? ARRAYBLOCK \PROMPTFORWORD.BUFFER)))
then (SETQ \PROMPTFORWORD.BUFFER (\ALLOCBLOCK (FOLDHI \PROMPTFORWORD.BUFFERSIZE
BYTESPERCELL)))
(if OLDSTRING
then (freplace (STRINGP BASE) of OLDSTRING with \PROMPTFORWORD.BUFFER)
(freplace (STRINGP OFFST) of OLDSTRING with 0)
(freplace (STRINGP LENGTH) of OLDSTRING with
\PROMPTFORWORD.BUFFERSIZE))
elseif OLDSTRING
then (PROG ((OFFST (ffetch (STRINGP OFFST) of OLDSTRING))
NEWOFFST) (* Assures that the OFFST will be at the first byte in a
word)
(SETQ NEWOFFST (CEIL OFFST BYTESPERWORD))
(if (NEQ NEWOFFST OFFST)
then (add (ffetch (STRINGP LENGTH) of OLDSTRING)
(IDIFFERENCE OFFST NEWOFFST))
(freplace (STRINGP OFFST) of OLDSTRING with NEWOFFST))))
(if (NOT (TERMTABLEP \PROMPTFORWORDTTBL))
then (SETQ \PROMPTFORWORDTTBL (for I (TTBL ←(COPYTERMTABLE (QUOTE ORIG)))
from 0 to 31
do (SELCHARQ I
((EOL ESCAPE SPACE LF TAB))
(ECHOCONTROL I (QUOTE INDICATE)
TTBL))
finally (PROGN (ECHOMODE NIL TTBL)
(CONTROL T TTBL)
(RETURN TTBL)))))
(if (AND DONTECHOTYPEIN.FLG (NEQ DONTECHOTYPEIN.FLG T))
then (SETQ DONTECHOTYPEIN.FLG (if (EQ (NCHARS DONTECHOTYPEIN.FLG)
1)
then (NTHCHARCODE DONTECHOTYPEIN.FLG 1)
else T)))
(* Note that this code isn't re-entrant, so things like
\PROMPTFORWORD.BUFFER don't need to be GLOBALRESOURCES)
(RESETSAVE (SETTERMTABLE \PROMPTFORWORDTTBL))
(PROG ((OCANDIDATE CANDIDATE.STR)
(CHARBUFFER \PROMPTFORWORD.BUFFER)
(CHARBUFFERSIZE \PROMPTFORWORD.BUFFERSIZE)
(I 0)
(Timer (SETUPTIMER 0 \PROMPTFORWORD.TIMER (QUOTE SECONDS)))
(TTYD (DISPLAYSTREAMP ECHO.CHANNEL))
CHAR X0Y0 BUFSTRPTR SAVEDBUFS BEGUNTYPING? RUBBING? ?HELPMSGTRIEDP ?HELPMSGLIST
CARETWIDTH)
(DECLARE (SPECVARS X0Y0 CARETWIDTH))
(if OLDSTRING
then (SETQ CHARBUFFER (\ADDBASE (ffetch (STRINGP BASE) of OLDSTRING)
(FOLDHI (ffetch (STRINGP OFFST) of OLDSTRING)
BYTESPERWORD)))
(SETQ CHARBUFFERSIZE (ffetch (STRINGP LENGTH) of OLDSTRING)))
(if TTYD
then (RESETSAVE (CARET T)) (* Insures that any caret is "down" in the former
window, and that we have a standard caret defined for
the one coming up)
(if (NEQ ECHO.CHANNEL (TTYDISPLAYSTREAM))
then (RESETSAVE (TTYDISPLAYSTREAM ECHO.CHANNEL))
(\CHECKCARET (TTYDISPLAYSTREAM))
(* Could there possibly be a new caret for this "new"
window))
(SETQ CARETWIDTH (\BITMAPHORIZONTALEXTENT (CAR (CARET)))))
(if KEYBD.CHANNEL
then (SETQ KEYBD.CHANNEL (\INSTREAMARG KEYBD.CHANNEL))
elseif (NOT (TTY.PROCESSP))
then
(* This means that we will be reading from the SYSBUFFER keyboard, and being the TTY.PROCESS is the way to assign
control of it. Note that if a stream is passed as argument which read from the keyboard, then this code won't be
done, and the RESETBUFS code won't be done either. NIL)
(RESETSAVE (TTY.PROCESS (THIS.PROCESS))))
A (if PROMPT.STR
then (for C instring PROMPT.STR do (\PROMPTFORWORDBOUT ECHO.CHANNEL C
CARETWIDTH))
(\PROMPTFORWORDBOUT ECHO.CHANNEL (CHARCODE SPACE)
CARETWIDTH))
(if TTYD
then (SETQ X0Y0 (create POSITION
XCOORD ←(DSPXPOSITION NIL TTYD)
YCOORD ←(DSPYPOSITION NIL TTYD))))
B (if (NEQ I 0)
then
(* If this is not the first time around, then perhaps re-echo the string accumulated so far
(remember, ? and ↑R may call for this re-echo))
(if (NEQ DONTECHOTYPEIN.FLG T)
then (for J from 0 to (SUB1 I)
do (\PROMPTFORWORDBOUT ECHO.CHANNEL (OR DONTECHOTYPEIN.FLG
(\GETBASEBYTE
CHARBUFFER J))
CARETWIDTH)))
elseif (NULL CANDIDATE.STR)
then NIL
elseif CANDIDATE.STR
then (* Now, start out with a "candidate" if the call
supplied one.)
(for C instring CANDIDATE.STR
do (\PUTBASEBYTE CHARBUFFER I C)
(add I 1))
(SETQ CANDIDATE.STR NIL)
(* Note that (NCHARS CANDIDATE.STR) cannot be zero, so by going around this loop again, the
(NEQ I 0) branch will be taken)
(GO B))
(bind WANT.ECHO.IN.BAD.PLACE until (if (EQ -1 (SETQ CHAR
(\PROMPTFORWORDBIN KEYBD.CHANNEL
TTYD
TIMELIMIT.secs
Timer)))
then (SETQ TIMELIMIT.secs T)
else (FMEMB CHAR TERMINCHARS.LST))
do (* -1 is the signal from \PROMPTFORWORDBIN that the
timer ran out.)
(if (IGEQ I CHARBUFFERSIZE)
then (* Can't you see how a LET* would be useful here!)
((LAMBDA (NEWSIZE)
((LAMBDA (NEWBUF)
(\MOVEBYTES CHARBUFFER 0 NEWBUF 0 CHARBUFFERSIZE)
(SETQ CHARBUFFERSIZE NEWSIZE)
(SETQ CHARBUFFER NEWBUF))
(\ALLOCBLOCK (FOLDHI NEWSIZE BYTESPERCELL))))
(LLSH CHARBUFFERSIZE 1))
(if OLDSTRING
then (freplace (STRINGP BASE) of OLDSTRING with CHARBUFFER)
(freplace (STRINGP OFFST) of OLDSTRING with 0)
(freplace (STRINGP LENGTH) of OLDSTRING with
CHARBUFFERSIZE)))
LOOKATCHAR
(if (SELCHARQ CHAR
((↑A BS RUBOUT DEL)
(if (IGREATERP I 0)
then (SETQ BEGUNTYPING? T)
(add I -1)
(if (NEQ DONTECHOTYPEIN.FLG T)
then ((LAMBDA (C)
(if TTYD
then (if (NULL (DSPRUBOUTCHAR
TTYD C))
then (SETQ CHAR
(CHARCODE ↑R))
(GO LOOKATCHAR))
else (if (NOT RUBBING?)
then (\PROMPTFORWORDBOUT
ECHO.CHANNEL
(CHARCODE \)
CARETWIDTH)
(SETQ RUBBING? T))
(\PROMPTFORWORDBOUT
ECHO.CHANNEL C
CARETWIDTH)))
(OR DONTECHOTYPEIN.FLG
(\GETBASEBYTE CHARBUFFER I))))
else (SETQ RUBBING?))
NIL)
((↑R ↑W ↑Q)
(if (IGREATERP I 0)
then (if (NEQ DONTECHOTYPEIN.FLG T)
then (if TTYD
then (\PROMPTFORWORDERASE TTYD X0Y0)
else (TERPRI ECHO.CHANNEL)))
(if (EQ CHAR (CHARCODE ↑R))
then (SETQ WANT.ECHO.IN.BAD.PLACE)
(GO B)
else (SETQ BEGUNTYPING? T)
(SETQ I 0))
else (SETQ RUBBING?))
NIL)
((↑V)
(if (NOT DONTECHOTYPEIN.FLG)
then (* Well, so echo the ↑V)
(if (AND \CARETFLG TTYD)
then (\SHOWCARET TTYD)
(SETQ \CARETDOWN T)
elseif (AND RUBBING? (NOT TTYD))
then (BOUT ECHO.CHANNEL (CHARCODE \))
(SETQ RUBBING?))
(\PROMPTFORWORDBOUT ECHO.CHANNEL (CHARCODE ↑V)
CARETWIDTH))
(if (EQ -1 (SETQ CHAR (\PROMPTFORWORDBIN KEYBD.CHANNEL TTYD
TIMELIMIT.secs
Timer)))
then (RETURN (SETQ TIMELIMIT.secs T)))
(if (AND TTYD (NOT DONTECHOTYPEIN.FLG)
(NULL (DSPRUBOUTCHAR TTYD (CHARCODE ↑V))))
then (* Losing case of ↑ and V echo split between lines)
(SETQ WANT.ECHO.IN.BAD.PLACE T))
T)
((?)
(FRESHLINE ECHO.CHANNEL)
(if (AND GENERATE?LIST.FN (NOT ?HELPMSGTRIEDP))
then (SETQ ?HELPMSGLIST (OR (STRINGP GENERATE?LIST.FN)
(APPLY* GENERATE?LIST.FN
PROMPT.STR
OCANDIDATE)))
(SETQ ?HELPMSGTRIEDP T)
elseif (NOT ?HELPMSGTRIEDP)
then (SETQ ?HELPMSGLIST (QUOTE ??)))
(if (LISTP ?HELPMSGLIST)
then (\PROMPTFORWORDBOUT ECHO.CHANNEL (CHARCODE {)
CARETWIDTH)
(\PROMPTFORWORDBOUT ECHO.CHANNEL (CHARCODE SPACE)
CARETWIDTH)
(MAPC ?HELPMSGLIST (FUNCTION (LAMBDA (X)
(PRIN1 X ECHO.CHANNEL)
(\PROMPTFORWORDBOUT ECHO.CHANNEL
(CHARCODE SPACE)
CARETWIDTH))))
(\PROMPTFORWORDBOUT ECHO.CHANNEL (CHARCODE })
CARETWIDTH)
else (PRIN1 ?HELPMSGLIST ECHO.CHANNEL)
(* FOO we'd really like this FRESHLINE to be just a
MOVETO some initial position.))
(FRESHLINE ECHO.CHANNEL)
(GO A))
T)
then (* If the SELCHARQ does't select out any of its
"special" characters, then just fall through here)
(if (AND (NOT BEGUNTYPING?)
(IGREATERP I 0))
then (* This is the case of the CANDIDATE.STR having been
proffered, but the user starts typing something else.)
(if DONTECHOTYPEIN.FLG
then (* Don't need to do anything if type-in isn't being
echoed)
elseif TTYD
then (\PROMPTFORWORDERASE TTYD X0Y0)
else (TERPRI ECHO.CHANNEL))
(SETQ I 0))
(\PUTBASEBYTE CHARBUFFER I CHAR)
(add I 1)
(SETQ BEGUNTYPING? T)
(if (NEQ DONTECHOTYPEIN.FLG T)
then (* Well, so echo the typed-in character already!)
(if (AND RUBBING? (NOT TTYD))
then (\PROMPTFORWORDBOUT ECHO.CHANNEL (CHARCODE
\)
CARETWIDTH)
(SETQ RUBBING?)
elseif (AND WANT.ECHO.IN.BAD.PLACE TTYD)
then (SETQ CHAR (CHARCODE ↑R))
(GO LOOKATCHAR))
(\PROMPTFORWORDBOUT ECHO.CHANNEL (OR DONTECHOTYPEIN.FLG
CHAR)
CARETWIDTH))))
(* Note that we shouldn't get here unless the caret is
off)
(SETQ CHARBUFFER (if (EQ T TIMELIMIT.secs)
then (* Ha, we overflowed the time limit.)
(if OCANDIDATE
then (if OLDSTRING
then (SUBSTRING OCANDIDATE 1 NIL OLDSTRING)
else (CONCAT OCANDIDATE)))
elseif (IGREATERP I 0)
then (if OLDSTRING
then (freplace (STRINGP LENGTH) of OLDSTRING
with I)
OLDSTRING
else (\GETBASESTRING CHARBUFFER 0 I))
else NIL))
(if (AND \DRIBBLE.OFD (EQ ECHO.CHANNEL \TERM.OFD))
then (if PROMPT.STR
then (PRIN1 PROMPT.STR \DRIBBLE.OFD)
(SPACES 1 \DRIBBLE.OFD))
(if (AND CHARBUFFER (NULL DONTECHOTYPEIN.FLG))
then (PRIN1 CHARBUFFER \DRIBBLE.OFD)))
(RETURN CHARBUFFER)))))
(\PROMPTFORWORDBIN
[LAMBDA (INSTREAM DISPLAYECHOSTREAM TIMELIMIT.secs Timer)
(* bvm: "11-AUG-83 13:16")
(* Takes in one character from the KEYBD.CHANNEL)
(DECLARE (SPECVARS TERMINCHARS.LST))
(PROG (CHAR)
STARTOVER
[during (OR TIMELIMIT.secs 74Q) timerUnits (QUOTE SECONDS) usingTimer Timer
until [SETQ CHAR (COND
((NULL INSTREAM)
(\GETSYSBUF))
((READP INSTREAM T)
(BIN INSTREAM))
((\EOFP INSTREAM)
(CAR TERMINCHARS.LST]
do (COND
(DISPLAYECHOSTREAM (\TTYBACKGROUND))
(T (BLOCK]
(COND
((AND (NULL TIMELIMIT.secs)
(NULL CHAR))
(RINGBELLS)
(GO STARTOVER)))
(COND
((AND DISPLAYECHOSTREAM \CARETFLG) (* Take the flashing caret down, for we're probably
going to echo the typed-in character.)
(\SHOWCARET DISPLAYECHOSTREAM)
(SETQ \CARETDOWN T))) (* -1 is the signal that the timer expired)
(RETURN (OR CHAR -1])
(\PROMPTFORWORDERASE
[LAMBDA (DS X0Y0) (* rmk: "23-AUG-83 21:39")
(* DS is guaranteed to be a display stream. X0Y0 is a POSITION where the user started typing in
(or where the default CANDIDATE was started))
(PROG (Y (DD (fetch IMAGEDATA of DS))
(0X (fetch XCOORD of X0Y0))
(0Y (fetch YCOORD of X0Y0)))
(SETQ Y (ffetch DDYPOSITION of DD))
(MOVETO 0X 0Y DS)
(DSPCLEOL DS 0X)
(if (NOT (IEQP 0Y Y))
then (* Foobar, how can you tell if the stupid window has
been scrolling?)
(DSPCLEOL DS (ffetch DDLeftMargin of DD)
(IDIFFERENCE Y (FONTDESCENT (fetch DDFONT of DD)))
(IDIFFERENCE 0Y Y])
(\PROMPTFORWORDBOUT
(LAMBDA (STREAM CHAR CARETWIDTH) (* JonL "10-NOV-83 07:12")
(if (AND TTYD (IGREATERP (IPLUS (DSPXPOSITION NIL STREAM)
(OR (\STREAMCHARWIDTH CHAR STREAM \PROMPTFORWORDTTBL)
0)
CARETWIDTH)
(DSPRIGHTMARGIN NIL STREAM)))
then (* past right margin so force EOL)
(TERPRI STREAM))
(BOUT STREAM CHAR)))
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(RPAQQ \PROMPTFORWORD.BUFFERSIZE 400Q)
(CONSTANTS (\PROMPTFORWORD.BUFFERSIZE 400Q))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \PROMPTFORWORDTTBL \PROMPTFORWORD.BUFFER \PROMPTFORWORD.LOCK
\PROMPTFORWORD.TIMER)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(SPECVARS TERMINCHARS.LST)
)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQ? \PROMPTFORWORDTTBL NIL)
(RPAQ? \PROMPTFORWORD.BUFFER NIL)
(RPAQ? \PROMPTFORWORD.LOCK (CREATE.MONITORLOCK "PromptForWord"))
(RPAQ? \PROMPTFORWORD.TIMER (SETUPTIMER 0))
)
(PUTPROPS PASSWORDS COPYRIGHT ("Xerox Corporation" 3676Q 3677Q 3700Q))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3626Q 23713Q (LOGIN 3640Q . 4557Q) (SETPASSWORD 4561Q . 5727Q) (\LOGIN.READ 5731Q .
11461Q) (\INTERNAL/GETPASSWORD 11463Q . 21116Q) (\ADJUST.USERNAME 21120Q . 22435Q) (\ENCRYPT.PWD
22437Q . 23275Q) (\DECRYPT.PWD 23277Q . 23711Q)) (26007Q 26637Q (\BITMAPHORIZONTALEXTENT 26021Q .
26635Q)) (26721Q 66466Q (PROMPTFORWORD 26733Q . 61551Q) (\PROMPTFORWORDBIN 61553Q . 64015Q) (
\PROMPTFORWORDERASE 64017Q . 65554Q) (\PROMPTFORWORDBOUT 65556Q . 66464Q)))))
STOP