(FILECREATED "11-AUG-83 13:20:15" {PHYLUM}<LISPCORE>SOURCES>PASSWORDS.;28 57551Q
changes to: (FNS PROMPTFORWORD \PROMPTFORWORDBIN \INTERNAL/GETPASSWORD \LOGIN.READ)
previous date: "26-JUL-83 22:02:35" {PHYLUM}<LISPCORE>SOURCES>PASSWORDS.;27)
(* Copyright (c) 1982, 1983 by Xerox Corporation)
(PRETTYCOMPRINT PASSWORDSCOMS)
(RPAQQ PASSWORDSCOMS ((FNS LOGIN SETPASSWORD \LOGIN.READ \INTERNAL/GETPASSWORD)
[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 (LIST (HARRAY 10Q)))
(\GETPASSWORD.LOCK (CREATE.MONITORLOCK "InternalGETPASSWORD")))
(DECLARE: EVAL@COMPILE DONTCOPY (GLOBALVARS LOGINPASSWORDS USERNAME
\GETPASWORD.LOCK)
(PROP DMACRO EMPASSWORDLOC)
(LOCALVARS . T))
[COMS (* Here is the real PROMPTFORWORD stuff)
(FNS PROMPTFORWORD \PROMPTFORWORDBIN \PROMPTFORWORDERASE)
(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]
(COMS (* Bells and Whistles)
(GLOBALRESOURCES (\PlayTimer (SETUPTIMER 0)))
(FNS RINGBELLS PLAYTUNE))))
(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: "26-JAN-83 15:44")
(PROG ((INFO (GETHASH HOST LOGINPASSWORDS)))
(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 PASSWORD)
(CDR INFO]
(T (FRPLACA (OR INFO (PUTHASH HOST (CONS)
LOGINPASSWORDS))
(CONS USER PASSWORD]
(RETURN HOST])
(\LOGIN.READ
[LAMBDA (HOST DEFAULTNAME MSG CONNECTFLG NSFLG) (* bvm: "11-AUG-83 12:57")
(COND
((AND HOST (NOT NSFLG)
(STRPOS ":" HOST))
(SETQ NSFLG T)))
(PROG [(PROMPT (COND
(NSFLG "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
(NSFLG (CHARCODE (CR LF)))
(T (* default)
NIL]
(COND
(CONNECTFLG (SETQ PROMPT "Connect to ")
(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
((EQ CONNECTFLG (QUOTE ALWAYS))
(CONS DEFAULTNAME (PROMPTFORWORD (CONCAT PROMPT " " DEFAULTNAME
" (password) ")
NIL NIL T (QUOTE *)
NIL TERMINATIONS)))
(T (RESETLST [OR (TTY.PROCESSP)
(RESETSAVE (TTY.PROCESS (THIS.PROCESS]
(RESETBUFS (CONS (MKATOM (PROMPTFORWORD PROMPT DEFAULTNAME
HELPFN T NIL NIL
TERMINATIONS
\KEYBOARD.STREAM))
(PROMPTFORWORD " (password) " NIL NIL T
(QUOTE *)
NIL NIL \KEYBOARD.STREAM]
(FRESHLINE T])
(\INTERNAL/GETPASSWORD
[LAMBDA (HOST ALWAYSASK DIRECTORY MSG DEFAULTNAME) (* bvm: "11-AUG-83 12:58")
(* 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)
(CAR (NLSETQ (WITH.MONITOR \GETPASSWORD.LOCK
(PROG ((INFO (GETHASH HOST LOGINPASSWORDS))
PWD PASSWORDADDR NAME/PASS DISKNAME)
(COND
([AND (NOT ALWAYSASK)
(SETQ NAME/PASS (COND
(DIRECTORY (ASSOC DIRECTORY (CDR INFO)))
(T (CAR INFO]
(* We already have login info)
(RETURN NAME/PASS)))
(COND
[DIRECTORY (OR INFO (SETQ INFO (PUTHASH HOST (CONS)
LOGINPASSWORDS)))
[SETQ NAME/PASS
(COND
((NULL ALWAYSASK)
(* First time, guess that no password is needed)
(CONS DIRECTORY ""))
(T (\LOGIN.READ HOST DIRECTORY MSG T]
(COND
(NAME/PASS (RPLACD INFO (CONS NAME/PASS
(CDR INFO]
(T [COND
((NOT DEFAULTNAME)
(SETQ DISKNAME (USERNAME NIL T T))
(SETQ DEFAULTNAME (OR (CAAR INFO)
DISKNAME]
[SETQ PASSWORDADDR (COND
([AND (EQ (SYSTEMTYPE)
(QUOTE D))
(NOT (ZEROP (SETQ PASSWORDADDR (EMPASSWORDLOC]
(EMPOINTER PASSWORDADDR]
[COND
((AND (NULL ALWAYSASK)
PASSWORDADDR
(EQ DEFAULTNAME DISKNAME)
(IGREATERP (NCHARS (SETQ PWD (GetBcplString
PASSWORDADDR)))
0))
(SETQ NAME/PASS (CONS DEFAULTNAME PWD)))
(T (SETQ NAME/PASS (\LOGIN.READ HOST DEFAULTNAME MSG))
(COND
[(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)))
(FRPLACA (OR INFO (PUTHASH HOST (CONS)
LOGINPASSWORDS))
NAME/PASS)))
(RETURN NAME/PASS])
)
(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 (LIST (HARRAY 10Q)))
(RPAQ? \GETPASSWORD.LOCK (CREATE.MONITORLOCK "InternalGETPASSWORD"))
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS LOGINPASSWORDS USERNAME \GETPASWORD.LOCK)
)
(PUTPROPS EMPASSWORDLOC DMACRO [LAMBDA NIL (* lmm "24-MAR-83 06:46")
(fetch (IFPAGE UserPswdAddr)
of \InterfacePage])
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(* 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)
(* bvm: "11-AUG-83 13:11")
(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)
[COND
((AND PROMPT.STR (NOT (STRINGP PROMPT.STR)))
(SETQ PROMPT.STR (MKSTRING PROMPT.STR]
[COND
(CANDIDATE.STR (SETQ CANDIDATE.STR (MKSTRING CANDIDATE.STR))
(COND
((ZEROP (NCHARS CANDIDATE.STR))
(SETQ CANDIDATE.STR]
(SETQ ECHO.CHANNEL (GETSTREAM (OR ECHO.CHANNEL T)
(QUOTE OUTPUT)))
(COND
[(NULL TERMINCHARS.LST)
(SETQ TERMINCHARS.LST (CHARCODE (EOL ESCAPE SPACE LF TAB]
((OR (NLISTP TERMINCHARS.LST)
([LAMBDA (CONVERTIBLEP LOSERP)
[for C in TERMINCHARS.LST do (COND
((NOT (CHARCODEP C))
(COND
((AND (LITATOM C)
(EQ 1 (NCHARS C)))
(SETQ CONVERTIBLEP T))
(T (RETURN (SETQ LOSERP T]
[COND
((AND CONVERTIBLEP (NOT LOSERP))
(SETQ TERMINCHARS.LST (MAPCAR TERMINCHARS.LST (FUNCTION (LAMBDA (C)
(OR (FIXP C)
(CHCON1 C]
LOSERP]))
(\ILLEGAL.ARG TERMINCHARS.LST)))
(COND
((AND TIMELIMIT.secs (NOT (FIXP TIMELIMIT.secs)))
(\ILLEGAL.ARG TIMELIMIT.secs)))
[COND
((AND OLDSTRING (NOT (STRINGP OLDSTRING)))
(\ILLEGAL.ARG OLDSTRING))
[(AND (OR (NULL OLDSTRING)
(IGEQ 2 (ffetch (STRINGP LENGTH) of OLDSTRING)))
(NOT (type? ARRAYBLOCK \PROMPTFORWORD.BUFFER)))
(SETQ \PROMPTFORWORD.BUFFER (\ALLOCBLOCK (FOLDHI \PROMPTFORWORD.BUFFERSIZE
BYTESPERCELL)))
(COND
(OLDSTRING (freplace (STRINGP BASE) of OLDSTRING with \PROMPTFORWORD.BUFFER)
(freplace (STRINGP OFFST) of OLDSTRING with 0)
(freplace (STRINGP LENGTH) of OLDSTRING with \PROMPTFORWORD.BUFFERSIZE]
(OLDSTRING (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))
(COND
((NEQ NEWOFFST OFFST)
(freplace (STRINGP LENGTH) of OLDSTRING
with (IDIFFERENCE (ffetch (STRINGP LENGTH) of OLDSTRING)
(IDIFFERENCE NEWOFFST OFFST)))
(freplace (STRINGP OFFST) of OLDSTRING with NEWOFFST]
[COND
((NOT (TERMTABLEP \PROMPTFORWORDTTBL))
(SETQ \PROMPTFORWORDTTBL (for I (TTBL ←(COPYTERMTABLE (QUOTE ORIG))) from 0
to 37Q do (SELCHARQ I
((EOL ESCAPE SPACE LF TAB))
(ECHOCONTROL I (QUOTE INDICATE)
TTBL))
finally (PROGN (ECHOMODE NIL TTBL)
(CONTROL T TTBL)
(RETURN TTBL]
[COND
((AND DONTECHOTYPEIN.FLG (NEQ DONTECHOTYPEIN.FLG T))
(SETQ DONTECHOTYPEIN.FLG (COND
((EQ (NCHARS DONTECHOTYPEIN.FLG)
1)
(NTHCHARCODE DONTECHOTYPEIN.FLG 1))
(T 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 (fetch (STREAMOFDISPLAYSTREAM DISPLAYSTREAM) of ECHO.CHANNEL))
CHAR X0Y0 BUFSTRPTR SAVEDBUFS BEGUNTYPING? RUBBING? ?HELPMSGTRIEDP ?HELPMSGLIST)
(DECLARE (SPECVARS X0Y0))
[COND
((NOT (\DISPLAYSTREAMP TTYD))
(SETQ TTYD NIL))
(T (RESETSAVE (TTYDISPLAYSTREAM TTYD]
[COND
(OLDSTRING (SETQ CHARBUFFER (\ADDBASE (ffetch (STRINGP BASE) of OLDSTRING)
(FOLDHI (ffetch (STRINGP OFFST)
of OLDSTRING)
BYTESPERWORD)))
(SETQ CHARBUFFERSIZE (ffetch (STRINGP LENGTH) of OLDSTRING]
[COND
[KEYBD.CHANNEL (SETQ KEYBD.CHANNEL (GETSTREAM KEYBD.CHANNEL (QUOTE INPUT]
((NOT (TTY.PROCESSP))
(* 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]
[COND
[(NULL \CARET)
(AND TTYD (RESETSAVE (CARET T]
(T (\CHECKCARET (TTYDISPLAYSTREAM]
A [COND
(PROMPT.STR (PRIN1 PROMPT.STR ECHO.CHANNEL)
(\OUTCHAR ECHO.CHANNEL (CHARCODE SPACE]
[COND
(TTYD (SETQ X0Y0 (create POSITION
XCOORD ←(DSPXPOSITION NIL TTYD)
YCOORD ←(DSPYPOSITION NIL TTYD]
B (COND
[(NEQ I 0)
(* 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))
(COND
((NEQ DONTECHOTYPEIN.FLG T)
(for J from 0 to (SUB1 I) do (\OUTCHAR ECHO.CHANNEL
(OR DONTECHOTYPEIN.FLG
(\GETBASEBYTE CHARBUFFER J]
((NULL CANDIDATE.STR)
NIL)
(CANDIDATE.STR (* 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 (COND
((EQ -1 (SETQ CHAR
(\PROMPTFORWORDBIN KEYBD.CHANNEL TTYD
TIMELIMIT.secs
Timer)))
(SETQ TIMELIMIT.secs T))
(T (FMEMB CHAR TERMINCHARS.LST)))
do (* -1 is the signal from \PROMPTFORWORDBIN that the
timer ran out.)
[COND
((IGEQ I CHARBUFFERSIZE) (* 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))
(COND
(OLDSTRING (freplace (STRINGP BASE) of OLDSTRING with CHARBUFFER)
(freplace (STRINGP OFFST) of OLDSTRING with 0)
(freplace (STRINGP LENGTH) of OLDSTRING with
CHARBUFFERSIZE]
LOOKATCHAR
(COND
((SELCHARQ CHAR
((↑A BS RUBOUT DEL)
(COND
[(IGREATERP I 0)
(SETQ BEGUNTYPING? T)
(add I -1)
(COND
((NEQ DONTECHOTYPEIN.FLG T)
([LAMBDA (C)
(COND
[TTYD (COND
((NULL (DSPRUBOUTCHAR TTYD C))
(SETQ CHAR (CHARCODE ↑R))
(GO LOOKATCHAR]
(T (COND
((NOT RUBBING?)
(\OUTCHAR ECHO.CHANNEL (CHARCODE \))
(SETQ RUBBING? T)))
(\OUTCHAR ECHOSTREAM C]
(OR DONTECHOTYPEIN.FLG (\GETBASEBYTE CHARBUFFER I]
(T (SETQ RUBBING?)))
NIL)
((↑R ↑W ↑Q)
(COND
[(IGREATERP I 0)
[COND
((NEQ DONTECHOTYPEIN.FLG T)
(COND
(TTYD (\PROMPTFORWORDERASE TTYD X0Y0))
(T (TERPRI ECHOSTREAM]
(COND
((EQ CHAR (CHARCODE ↑R))
(SETQ WANT.ECHO.IN.BAD.PLACE)
(GO B))
(T (SETQ BEGUNTYPING? T)
(SETQ I 0]
(T (SETQ RUBBING?)))
NIL)
((↑V)
[COND
((NOT DONTECHOTYPEIN.FLG)
(* Well, so echo the ↑V)
(COND
((AND \CARETFLG TTYD)
(\SHOWCARET TTYD)
(SETQ \CARETDOWN T))
((AND RUBBING? (NOT TTYD))
(\OUTCHAR ECHO.CHANNEL (CHARCODE \))
(SETQ RUBBING?)))
(\OUTCHAR ECHO.CHANNEL (CHARCODE ↑V]
[COND
((EQ -1 (SETQ CHAR (\PROMPTFORWORDBIN KEYBD.CHANNEL TTYD
TIMELIMIT.secs Timer)
))
(RETURN (SETQ TIMELIMIT.secs T]
(COND
([AND TTYD (NOT DONTECHOTYPEIN.FLG)
(NULL (DSPRUBOUTCHAR TTYD (CHARCODE ↑V]
(* Losing case of ↑ and V echo split between lines)
(SETQ WANT.ECHO.IN.BAD.PLACE T)))
T)
((?)
(FRESHLINE ECHO.CHANNEL)
[COND
((AND GENERATE?LIST.FN (NOT ?HELPMSGTRIEDP))
(SETQ ?HELPMSGLIST (OR (STRINGP GENERATE?LIST.FN)
(APPLY* GENERATE?LIST.FN
PROMPT.STR OCANDIDATE)))
(SETQ ?HELPMSGTRIEDP T))
((NOT ?HELPMSGTRIEDP)
(SETQ ?HELPMSGLIST (QUOTE ??]
(COND
((LISTP ?HELPMSGLIST)
(\OUTCHAR ECHO.CHANNEL (CHARCODE {))
(\OUTCHAR ECHO.CHANNEL (CHARCODE SPACE))
[MAPC ?HELPMSGLIST (FUNCTION (LAMBDA (X)
(PRIN1 X ECHO.CHANNEL)
(\OUTCHAR ECHO.CHANNEL (CHARCODE SPACE]
(\OUTCHAR ECHO.CHANNEL (CHARCODE })))
(T (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) (* If the SELCHARQ does't select out any of its
"special" characters, then just fall through here)
(COND
((AND (NOT BEGUNTYPING?)
(IGREATERP I 0)) (* This is the case of the CANDIDATE.STR having been
proffered, but the user starts typing something else.)
(COND
(DONTECHOTYPEIN.FLG (* Don't need to do anything if type-in isn't being
echoed))
(TTYD (\PROMPTFORWORDERASE TTYD X0Y0))
(T (TERPRI ECHO.CHANNEL)))
(SETQ I 0)))
(\PUTBASEBYTE CHARBUFFER I CHAR)
(add I 1)
(SETQ BEGUNTYPING? T)
(COND
((NEQ DONTECHOTYPEIN.FLG T)
(* Well, so echo the typed-in character already!)
(COND
((AND RUBBING? (NOT TTYD))
(\OUTCHAR ECHO.CHANNEL (CHARCODE \))
(SETQ RUBBING?))
((AND WANT.ECHO.IN.BAD.PLACE TTYD)
(SETQ CHAR (CHARCODE ↑R))
(GO LOOKATCHAR)))
(\OUTCHAR ECHO.CHANNEL (OR DONTECHOTYPEIN.FLG CHAR]
(* Note that we shouldn't get here unless the caret is
off)
(RETURN (COND
[(EQ T TIMELIMIT.secs) (* Ha, we overflowed the time limit.)
(COND
(OCANDIDATE (COND
(OLDSTRING (SUBSTRING OCANDIDATE 1 NIL OLDSTRING))
(T (CONCAT OCANDIDATE]
[(IGREATERP I 0)
(COND
(OLDSTRING (freplace (STRINGP LENGTH) of OLDSTRING with I)
OLDSTRING)
(T (\GETBASESTRING CHARBUFFER 0 I]
(T NIL])
(\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) (* JonL " 7-MAY-83 18:49")
(* X0Y0 is a POSITION where the user started typing in (or where the default CANDIDATE was started) Currently, for
non DISPLAYSTREAMP echo streams, a POSITION is just null.)
(PROG ((0X (fetch XCOORD of X0Y0))
(0Y (fetch YCOORD of X0Y0))
(Y (DSPYPOSITION NIL DS)))
(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 (DSPLEFTMARGIN NIL DS)
(IDIFFERENCE Y (FONTDESCENT (DSPFONT NIL DS)))
(IDIFFERENCE 0Y Y))))))
)
(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))
)
(* Bells and Whistles)
(RPAQQ \PlayTimer NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \PlayTimer)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(PUTDEF (QUOTE \PlayTimer)
(QUOTE GLOBALRESOURCES)
(QUOTE (SETUPTIMER 0)))
)
(DEFINEQ
(RINGBELLS
(LAMBDA NIL (* JonL "25-JUL-83 20:49")
(SELECTQ (MACHINETYPE)
(DANDELION (PROG ((L1 (QUOTE ((1000 . 1000)
(800 . 1000)
(600 . 1000)
(500 . 1000)
(400 . 1000)
(NIL . 500)
(440 . 1000)
(484 . 1000)
(540 . 1000)
(600 . 1000))))
(L2 (QUOTE ((2000 . 1000)
(1600 . 1000)
(1200 . 1000)
(1000 . 1000)
(800 . 1000)
(NIL . 500)
(880 . 1000)
(968 . 1000)
(1080 . 1000)
(1188 . 1000)))))
(to 6
do (PLAYTUNE L1)
(swap L1 L2)
(PRIN3 (CONSTANT (CHARACTER (CHARCODE ↑G)))
T))))
(GLOBALRESOURCE (\PlayTimer)
(for I to 6
do (* Flash the whole screen at him!)
(if (ODDP I)
then (BLOCK 160))
(BLOCK 160)
(UNINTERRUPTABLY
(VIDEOCOLOR (PROG1 (VIDEOCOLOR T)
(during 160 usingTimer \PlayTimer
do NIL)))))))))
(PLAYTUNE
(LAMBDA (L) (* JonL "25-JUL-83 20:48")
(* L is a list of Frequency/Duration pairs. The durations are in TICKS which means that a "tune" must be re-scaled
between the DLion and the other machines.)
(GLOBALRESOURCE (\PlayTimer)
(for X in L
do (if (CAR X)
then (BEEPON (CAR X))
else (BEEPOFF))
(forDuration (CDR X) timerUnits (QUOTE TICKS) usingTimer \PlayTimer
do (* Just "busy-wait" to pass the time)
NIL)))
(BEEPOFF)))
)
(PUTPROPS PASSWORDS COPYRIGHT ("Xerox Corporation" 3676Q 3677Q))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3436Q 15716Q (LOGIN 3450Q . 4367Q) (SETPASSWORD 4371Q . 5453Q) (\LOGIN.READ 5455Q .
10473Q) (\INTERNAL/GETPASSWORD 10475Q . 15714Q)) (17434Q 52274Q (PROMPTFORWORD 17446Q . 46364Q) (
\PROMPTFORWORDBIN 46366Q . 50630Q) (\PROMPTFORWORDERASE 50632Q . 52272Q)) (53776Q 57422Q (RINGBELLS
54010Q . 56220Q) (PLAYTUNE 56222Q . 57420Q)))))
STOP