(FILECREATED "20-Jul-85 18:05:35" {ERIS}<LISPCORE>LIBRARY>MAILCLIENT.;12 52767
changes to: (FNS GV.ADDTOITEM MS.SENDOPERATION \RESPTOCHECKVAL MS.RETRIEVEOPERATION
\RECEIVEMESSAGEITEM)
previous date: " 8-Jun-85 22:41:28" {ERIS}<LISPCORE>LIBRARY>MAILCLIENT.;11)
(* Copyright (c) 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT MAILCLIENTCOMS)
(RPAQQ MAILCLIENTCOMS ((COMS (* Sending mail)
(FNS GV.STARTSEND GV.ADDRECIPIENT GV.CHECKVALIDITY GV.STARTITEM
GV.ADDTOITEM GV.SEND MS.EXPAND)
(* Internal Sending)
(FNS MS.SENDOPERATION \FINDMAILSERVER \MAILSERVERSOCKETS \RECEIVEACK
\RESPTOCHECKVAL \RESPTOEXPAND \RESPTOSTARTSEND)
(VARS (\MAILIOTIMEOUT NIL)
(\MAILSERVERENQUIRYSOC 46)
(\MAILSERVERNAME (QUOTE (Maildrop . ms)))
(\MAILSERVERPOLLINGSOC 44)
(\MAILSERVERSOCKETCACHE)
(\MAILSERVERRETRIEVALSOC 47))
(GLOBALVARS \MAILIOTIMEOUT \MAILSERVERENQUIRYSOC \MAILSERVERNAME
\MAILSERVERPOLLINGSOC \MAILSERVERSOCKETCACHE
\MAILSERVERRETRIEVALSOC)
(ADDVARS (\SYSTEMCACHEVARS \MAILSERVERSOCKETCACHE)))
(COMS (* Receiving mail)
(FNS GV.PORTFROMNAME GV.POLLNEWMAIL GV.OPENMAILBOX GV.NEXTMESSAGE
GV.RETRIEVEMESSAGE GV.CLOSEMAILBOX)
(ADDVARS (MAILSERVERTYPES (GV GV.POLLNEWMAIL GV.OPENMAILBOX
GV.NEXTMESSAGE GV.RETRIEVEMESSAGE
GV.CLOSEMAILBOX GV.PORTFROMNAME)))
(COMS (* Not currently used)
(FNS GV.READTOC GV.WRITETOC GV.DELETEMESSAGE))
(* Internal Receiving)
(FNS MS.RETRIEVEOPERATION \CONNECTTOMAILSERVER \OPENMAILSERVER
\RESPTOOPENMAILBOX \RESPTONEXTMESSAGE \RESPTORETRIEVEMESSAGE
\RECEIVEMESSAGEITEM \RECEIVELONGWORD)
(INITVARS (GV.MAILBOX.TIMEOUT 12000))
(GLOBALVARS GV.MAILBOX.TIMEOUT))
(COMS (* LAFITEMODE GV)
(ALISTS (LAFITEMODELST GV GRAPEVINE))
(FNS GV.INIT.MAIL.USER GETMAILSERVEROPS \GV.MAILSERVERTYPE)
(FNS \GV.SENDMESSAGE \GV.SENDRECIPIENTS)
(FNS \GV.SEND.PARSE \GV.PARSERECIPIENTS \GV.PARSE.ARPA.ADDRESS
\GV.PARSERECIPIENTS1 \GV.PARSE.SINGLE.ADDRESS \GV.REPACKADDRESS
\GV.COLLECTADDRESSES \CHECKMESSAGEADDRESSES \LAFITE.CHOOSE.REPLYTO)
(FNS GV.MAKEANSWERFORM GETREGISTRY LA.PRINTADDRESSES)
(ADDVARS (MAILSERVERTYPES))
(INITVARS (ARPANETGATEWAY.REGISTRY (QUOTE AG))
(LAFITEREPLYTOMENU))
(ADDVARS (LISPSUPPORT (GV "LispSupport.pa"))
(LAFITESUPPORT (GV "LafiteSupport.pa"))
(TEDITSUPPORT (GV "TEditSupport.pa")))
(VARS LAFITEREPLYTOMENUITEMS)
(GLOBALVARS \LAFITEUSERDATA MAILSERVERTYPES ARPANETGATEWAY.REGISTRY
LAFITEREPLYTOMENUITEMS LAFITEREPLYTOMENU)
(PROP FILEDEF MAINTAIN))
(DECLARE: DOEVAL@COMPILE DONTCOPY (EXPORT (RECORDS OPENEDMAILBOX NEXTMESSAGE))
(RECORDS MAILPORT GVMAILPARSE)
(COMS * MAILCLIENTCONSTANTCOMS)
(FILES (LOADCOMP)
GRAPEVINE PUP BSP LAFITE LAFITEMAIL))
(DECLARE: DONTEVAL@LOAD DOCOPY (FILES GRAPEVINE))))
(* Sending mail)
(DEFINEQ
(GV.STARTSEND
[LAMBDA (SENDER KEY RETURN VALIDATEFLG) (* bvm: " 5-Nov-84 15:39")
(* * returns either a socket to use to send the rest of the message on or NIL * *)
(PROG (SENDINGSOCKET STARTSENDRESULT)
(COND
((SETQ SENDINGSOCKET (\FINDMAILSERVER))
(COND
((SETQ STARTSENDRESULT (MS.SENDOPERATION \OP.STARTSEND SENDINGSOCKET
[LIST (\CHECKNAME SENDER)
(\CHECKKEY KEY)
(\CHECKNAME RETURN)
(LIST \3BYTEKLUDGEKEY (COND
(VALIDATEFLG 1)
(T 0]
(FUNCTION \RESPTOSTARTSEND)))
(RETURN SENDINGSOCKET))
(T (* print the reason for failure *)
(AND NIL (printout PROMPTWINDOW "Couldn't start sending the message - reason: "
STARTSENDRESULT T))
(RETURN NIL])
(GV.ADDRECIPIENT
[LAMBDA (SOCKET NAME) (* M.Yonke "15-JUN-83 15:20")
(MS.SENDOPERATION \OP.ADDRECIPIENT SOCKET (LIST (\CHECKNAME NAME])
(GV.CHECKVALIDITY
[LAMBDA (SOCKET) (* M.Yonke "15-JUN-83 15:53")
(MS.SENDOPERATION \OP.CHECKVALIDITY SOCKET NIL (FUNCTION \RESPTOCHECKVAL])
(GV.STARTITEM
[LAMBDA (SOCKET TYPE) (* M.Yonke "15-JUN-83 15:31")
(* If TYPE is not supplied assume text *)
(MS.SENDOPERATION \OP.STARTITEM SOCKET (LIST (OR (AND TYPE (SMALLP TYPE))
\I.TEXT])
(GV.ADDTOITEM
[LAMBDA (SOCKET STR) (* bvm: "20-Jul-85 16:58")
(* * * Can't use \SENDITEM here because not in usual Grapevine STR format -- no maxLength or padding -- so we do it
by hand and no response is given * *)
(PROG ((OUTSTREAM (fetch GVOUTSTREAM of SOCKET))
WASOPEN INSTREAM #CHARS)
[SETQ #CHARS (OR (SELECTQ (TYPENAME STR)
(STRINGP (NCHARS STR))
(STREAM (GETFILEINFO [COND
((OPENED STR)
(SETQ WASOPEN (SETQ INSTREAM STR)))
(T (SETQ INSTREAM (OPENSTREAM
STR
(QUOTE INPUT]
(QUOTE LENGTH)))
[LITATOM (COND
((INFILEP STR)
(GETFILEINFO (SETQ INSTREAM (OPENSTREAM
STR
(QUOTE INPUT)))
(QUOTE LENGTH]
NIL)
(NCHARS (SETQ STR (MKSTRING STR]
(COND
((AND INSTREAM (NEQ (GETFILEPTR INSTREAM)
0))
(SETFILEPTR INSTREAM 0)))
(MS.SENDOPERATION \OP.ADDTOITEM SOCKET)
(while (IGREATERP #CHARS MAX.SMALLP)
do (* Stream bigger than can be sent in one chunk.
Note this cannot be the string case, because all
strings have lengths le MAX.SMALLP)
(\WOUT OUTSTREAM MAX.SMALLP)
(COPYBYTES INSTREAM OUTSTREAM MAX.SMALLP)
(SETQ #CHARS (IDIFFERENCE #CHARS MAX.SMALLP))
(MS.SENDOPERATION \OP.ADDTOITEM SOCKET))
(\WOUT OUTSTREAM #CHARS)
(COND
(INSTREAM (COPYBYTES INSTREAM OUTSTREAM)
(OR WASOPEN (CLOSEF INSTREAM)))
(T (for CHAR instring STR do (BOUT OUTSTREAM CHAR])
(GV.SEND
[LAMBDA (SOCKET) (* bvm: "23-Mar-84 12:42")
(MS.SENDOPERATION \OP.SEND SOCKET NIL (FUNCTION \RECEIVEACK])
(MS.EXPAND
[LAMBDA (SOCKET NAME) (* M.Yonke "15-JUN-83 15:53")
(* * Does the mailserver Expand operation -- named to avoid conflict with the database version -- DBEXPAND * *)
(MS.SENDOPERATION \OP.MSEXPAND SOCKET (LIST (\CHECKNAME NAME))
(FUNCTION \RESPTOEXPAND])
)
(* Internal Sending)
(DEFINEQ
(MS.SENDOPERATION
[LAMBDA (OP SOCKET ARGS RESPONSEFN) (* bvm: "20-Jul-85 16:59")
(* * basic workhorse for communicating with a mail server -
sends an OP and ARGS and fields a response, if appropriate * *)
(COND
[SOCKET (COND
([NLSETQ (LET ((STREAM (fetch GVOUTSTREAM of SOCKET)))
(\WOUT STREAM OP)
(for ARG in ARGS do (\SENDITEM STREAM ARG]
(COND
[RESPONSEFN (CAR (NLSETQ (PROGN (FORCEOUTPUT (fetch GVOUTSTREAM of SOCKET))
(APPLY* RESPONSEFN (fetch GVINSTREAM
of SOCKET]
(T T]
(T (* We're in the middle -
nothing for it but to bail out)
EC.STREAMLOST])
(\FINDMAILSERVER
[LAMBDA (ERRORFLG) (* M.Yonke "15-JUN-83 15:16")
(* * Open a BSP connection to a nearby, responsive mail server and returns it * *)
(if (OPENCLOSESTSOCKET (\MAILSERVERSOCKETS ERRORFLG)
\MAILSERVERPOLLINGSOC \MAILSERVERENQUIRYSOC NIL \MAILIOTIMEOUT)
elseif ERRORFLG
then (ERROR "Couldn't open connection for" \MAILSERVERNAME)
NIL])
(\MAILSERVERSOCKETS
[LAMBDA (ERRORFLG) (* bvm: "21-MAY-83 20:00")
(PROG (SOCKETS)
(RETURN (COND
([AND \MAILSERVERSOCKETCACHE (NOT (TIMEREXPIRED? (CAR \MAILSERVERSOCKETCACHE]
(CDR \MAILSERVERSOCKETCACHE))
(T (SETQ \MAILSERVERSOCKETCACHE (AND (SETQ SOCKETS
(LOCATESOCKETS \MAILSERVERNAME ERRORFLG))
(CONS (SETUPTIMER \MAILSOCKETTIMEOUT)
SOCKETS)))
SOCKETS])
(\RECEIVEACK
[LAMBDA (STREAM) (* M.Yonke " 3-JUN-83 16:43")
(* any byte will do -
it seems to be 0 when I've noticed)
(if (BIN STREAM)
then T])
(\RESPTOCHECKVAL
[LAMBDA (INSTREAM) (* bvm: "20-Jul-85 16:58")
(* As per documentation -
bad guys followed by count of good guys which I CONS on
the front)
(bind N until (EQ (SETQ N (\WIN INSTREAM))
0)
collect (CONS N (\RECEIVERNAME INSTREAM)) finally (RETURN (CONS (\WIN INSTREAM)
$$VAL])
(\RESPTOEXPAND
[LAMBDA (INSTREAM) (* bvm: "11-MAY-83 16:11")
(* As per documentation -
names followed by a code which I interpret and CONS on
the front)
(while (\RECEIVEBOOL INSTREAM) collect (\RECEIVERNAME INSTREAM)
finally (RETURN (CONS (SELECTQ (BIN INSTREAM)
((0 2)
T)
((1 3)
EC.BADRNAME)
(SHOULDNT))
$$VAL])
(\RESPTOSTARTSEND
[LAMBDA (INSTREAM) (* M.Yonke "26-MAY-83 10:45")
(SELECTC (BIN INSTREAM)
(\RC.SENDSTARTED T)
(\RC.PASSWORDINVALID (QUOTE InvalidPassword))
(\RC.SENDERNOTREGISTERED (QUOTE SenderNotRegistered))
(\RC.RETURNTONOTREGISTERED (QUOTE ReturnToNotRegistered))
(\RC.COMMUNICATIONFAILURE (QUOTE NetworkCommunicationsFailure))
(SHOULDNT])
)
(RPAQQ \MAILIOTIMEOUT NIL)
(RPAQQ \MAILSERVERENQUIRYSOC 46)
(RPAQQ \MAILSERVERNAME (Maildrop . ms))
(RPAQQ \MAILSERVERPOLLINGSOC 44)
(RPAQQ \MAILSERVERSOCKETCACHE NIL)
(RPAQQ \MAILSERVERRETRIEVALSOC 47)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \MAILIOTIMEOUT \MAILSERVERENQUIRYSOC \MAILSERVERNAME \MAILSERVERPOLLINGSOC
\MAILSERVERSOCKETCACHE \MAILSERVERRETRIEVALSOC)
)
(ADDTOVAR \SYSTEMCACHEVARS \MAILSERVERSOCKETCACHE)
(* Receiving mail)
(DEFINEQ
(GV.PORTFROMNAME
[LAMBDA (SERVERNAME) (* bvm: " 1-Jan-84 17:11")
(AND (SETQ SERVERNAME (GV.READCONNECT SERVERNAME))
(ETHERPORT SERVERNAME])
(GV.POLLNEWMAIL
[LAMBDA (GVPORT REGISTEREDNAME) (* bvm: "14-Nov-84 10:10")
(PROG ((SOC (\GETMISCSOCKET))
(OUTPUP (ALLOCATE.PUP))
(RESULT (QUOTE ?))
INPUP)
(SETUPPUP OUTPUP (fetch (MAILPORT HOST#) of GVPORT)
(fetch (MAILPORT SOCKET#) of GVPORT)
\PT.LAURELCHECK NIL SOC T)
(PUTPUPSTRING OUTPUP REGISTEREDNAME)
(to \MAXETHERTRIES when (SETQ INPUP (EXCHANGEPUPS SOC OUTPUP NIL T))
do (SELECTC (fetch PUPTYPE of INPUP)
(\PT.NEWMAIL (SETQ RESULT T)
(RETURN))
(\PT.NONEWMAIL (SETQ RESULT NIL)
(RETURN))
(\PT.NOMAILBOX (RETURN))
[\PT.ERROR (AND PUPTRACEFLG (PRINTERRORPUP INPUP PUPTRACEFILE))
(COND
((EQ (fetch ERRORPUPCODE of INPUP)
\PUPE.NOSOCKET)
(RETURN]
NIL)
finally (AND PUPTRACEFLG (printout PUPTRACEFILE "Mail check timed out" T)))
(AND INPUP (RELEASE.PUP INPUP))
(RELEASE.PUP OUTPUP)
(RETURN RESULT])
(GV.OPENMAILBOX
[LAMBDA (GVPORT REGISTEREDNAME PASSWORD MAILSERVER) (* bvm: "14-Nov-84 10:14")
(PROG (MAILBOX INBOXRESULT)
(RETURN (SELECTQ (GV.POLLNEWMAIL GVPORT REGISTEREDNAME)
(NIL (QUOTE EMPTY))
(? NIL)
(COND
([AND (SETQ MAILBOX (\CONNECTTOMAILSERVER GVPORT))
(SETQ INBOXRESULT (MS.RETRIEVEOPERATION \OP.OPENINBOX MAILBOX
(LIST (\CHECKNAME
REGISTEREDNAME)
(\CHECKKEY PASSWORD))
(FUNCTION
\RESPTOOPENMAILBOX]
(COND
((SMALLP INBOXRESULT)
(create OPENEDMAILBOX
MAILBOX ← MAILBOX
#OFMESSAGES ← INBOXRESULT))
(T (* Return failure reason)
(CONS NIL INBOXRESULT])
(GV.NEXTMESSAGE
[LAMBDA (MAILBOX) (* DECLARATIONS: (RECORD (ANOTHERMESSAGE? ARCHIVED?
DELETED?)))
(* bvm: " 5-Nov-84 13:13")
(PROG (RESULT)
(SETQ RESULT (MS.RETRIEVEOPERATION \OP.NEXTMESSAGE MAILBOX NIL (FUNCTION \RESPTONEXTMESSAGE)
))
(COND
((fetch ANOTHERMESSAGE? of RESULT)
(RETURN (LIST (QUOTE DELETED)
(fetch DELETED? of RESULT)
(QUOTE ARCHIVED)
(fetch ARCHIVED? of RESULT])
(GV.RETRIEVEMESSAGE
[LAMBDA (MAILBOX MSGOUTFILE) (* M.Yonke "25-MAY-83 17:11")
(PROG [(MSGOUTSTREAM (GETSTREAM MSGOUTFILE (QUOTE OUTPUT]
(DECLARE (SPECVARS MSGOUTSTREAM))
(RETURN (if (NLSETQ (MS.RETRIEVEOPERATION \OP.READMESSAGE MAILBOX NIL
(FUNCTION \RESPTORETRIEVEMESSAGE)))
then (* presumably if an error didn't occur then we made it
*)
T
else NIL])
(GV.CLOSEMAILBOX
[LAMBDA (MAILBOX FLUSHP) (* bvm: " 9-May-84 14:13")
(COND
((BSPOPENP (fetch GVINSTREAM of MAILBOX))
(PROG1 [COND
(FLUSHP (MS.RETRIEVEOPERATION \OP.FLUSH MAILBOX NIL (FUNCTION \RECEIVEACK]
(CLOSEBSPSTREAM (fetch GVINSTREAM of MAILBOX)
\ETHERTIMEOUT])
)
(ADDTOVAR MAILSERVERTYPES (GV GV.POLLNEWMAIL GV.OPENMAILBOX GV.NEXTMESSAGE GV.RETRIEVEMESSAGE
GV.CLOSEMAILBOX GV.PORTFROMNAME))
(* Not currently used)
(DEFINEQ
(GV.READTOC
[LAMBDA (MAILBOX) (* M.Yonke "25-MAY-83 14:37")
(MS.RETRIEVEOPERATION \OP.READTOC MAILBOX NIL (FUNCTION \RECEIVESTRING])
(GV.WRITETOC
[LAMBDA (MAILBOX REMARK) (* M.Yonke "25-MAY-83 14:37")
(MS.RETRIEVEOPERATION \OP.WRITETOC MAILBOX (LIST REMARK)
(FUNCTION \RECEIVEACK])
(GV.DELETEMESSAGE
[LAMBDA (MAILBOX) (* M.Yonke "25-MAY-83 14:37")
(MS.RETRIEVEOPERATION \OP.DELETEMESSAGE MAILBOX NIL (FUNCTION \RECEIVEACK])
)
(* Internal Receiving)
(DEFINEQ
(MS.RETRIEVEOPERATION
[LAMBDA (OP MAILBOX ARGS RESPONSEFN) (* bvm: "20-Jul-85 17:00")
(* * basic workhorse for communicating with a mail server -
sends an OP and ARGS to MAILBOX and fields a response, if appropriate)
(LET ((OUTSTREAM (fetch GVOUTSTREAM of MAILBOX)))
(\WOUT OUTSTREAM OP)
(for E in ARGS do (\SENDITEM OUTSTREAM E))
(FORCEOUTPUT OUTSTREAM)
(COND
(RESPONSEFN (APPLY* RESPONSEFN (fetch GVINSTREAM of MAILBOX)))
(T T])
(\CONNECTTOMAILSERVER
[LAMBDA (PORT) (* bvm: "30-Oct-84 15:26")
(* Open a BSP connection to mail server)
(RESETVARS ((\RTP.DEFAULTTIMEOUT GV.MAILBOX.TIMEOUT))
(* * Crufty!!!! OPENBSPSTREAM should allow RFC timeout to be specified)
(RETURN (\OPENGVCONNECTION (CONS (CAR PORT)
\MAILSERVERRETRIEVALSOC])
(\OPENMAILSERVER
[LAMBDA (PORT POLLSOC CONNSOC TIMEOUT) (* M.Yonke "26-MAY-83 10:47")
(* EchoMe polling to determine responsiveness is to POLLSOC, connection will go to CONNSOC.
We poll in order from nearest to farest by hop order, use broadcast on local net if appropriate, and hope not to
engage too many folks before the real thing comes along. The basic structure of this is owed to Taft)
(COND
(PORT (PROG ((SOC (\GETMISCSOCKET))
(OUTPUP (ALLOCATE.PUP))
INPUP) (* This sends out an echoMe packet to poll MS)
(SETUPPUP OUTPUP (CAR PORT)
(OR POLLSOC (CDR PORT)
\MAILSERVERPOLLINGSOC)
\PT.ECHOME NIL SOC)
(RETURN (COND
((AND (SETQ INPUP (EXCHANGEPUPS SOC OUTPUP NIL T))
(EQ (fetch PUPTYPE of INPUP)
\PT.IAMECHO)
(\OPENGVCONNECTION (CONS (fetch PUPSOURCE of INPUP)
(OR CONNSOC
(fetch PUPSOURCESOCKET of INPUP)))
TIMEOUT])
(\RESPTOOPENMAILBOX
[LAMBDA (INSTREAM) (* bvm: " 5-Nov-84 16:29")
(SELECTC (\BIN INSTREAM)
(\RC.NAMEANDPASSWORDVALID (\WIN INSTREAM))
(\RC.BADPASSWORD (QUOTE BadPassword))
(PROGN (* There are actually 5 values for the return code, but
most of them are impossible, since Lafite has
authenticated NAME)
NIL])
(\RESPTONEXTMESSAGE
[LAMBDA (INSTREAM) (* bvm: "11-MAY-83 15:55")
(LIST (\RECEIVEBOOL INSTREAM)
(\RECEIVEBOOL INSTREAM)
(\RECEIVEBOOL INSTREAM])
(\RESPTORETRIEVEMESSAGE
[LAMBDA (INSTREAM) (* bvm: "21-Feb-84 12:38")
(until (\EOFP INSTREAM) do (\RECEIVEMESSAGEITEM INSTREAM) finally (BSPGETMARK INSTREAM])
(\RECEIVEMESSAGEITEM
[LAMBDA (STREAM) (* bvm: "20-Jul-85 17:00")
(* * Ignores all items except of type text -- e.g. the message * *)
(DECLARE (USEDFREE MSGOUTSTREAM))
(PROG ((W (\WIN STREAM))
(LW (\RECEIVELONGWORD STREAM)))
RETRY
[SELECTC W
[(LIST \I.TEXT \I.OLDTEDITFORMATTING \I.TEDITFORMATTING)
(to LW do (\OUTCHAR MSGOUTSTREAM (BIN STREAM]
(COND
((AND NIL (EQ PUPTRACEFLG T))
(printout PUPTRACEFILE "FIELD " W T)
(to LW bind (PUPSTREAM ←(\GETSTREAM PUPTRACEFILE (QUOTE OUTPUT)))
do (\OUTCHAR PUPSTREAM (BIN STREAM)))
(TERPRI PUPTRACEFILE))
(T (to LW do (BIN STREAM]
(COND
((ODDP LW)
(BIN STREAM)))
(RETURN W])
(\RECEIVELONGWORD
[LAMBDA (STREAM) (* bvm: "11-MAY-83 14:49")
(* Read a 32-bit number, low-word is first)
(PROG ((LO (\WIN STREAM))
(HI (\WIN STREAM)))
(RETURN (\MAKENUMBER HI LO])
)
(RPAQ? GV.MAILBOX.TIMEOUT 12000)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS GV.MAILBOX.TIMEOUT)
)
(* LAFITEMODE GV)
(ADDTOVAR LAFITEMODELST (GV \GV.SEND.PARSE \GV.SENDMESSAGE GV.MAKEANSWERFORM GV.INIT.MAIL.USER)
(GRAPEVINE . GV))
(DEFINEQ
(GV.INIT.MAIL.USER
[LAMBDA NIL (* bvm: "13-Nov-84 11:38")
(PROG (GVUSERNAME FULLNAME PASS MAILSERVERS AUTHENTICATED?)
(COND
(\LAFITEUSERDATA (RETURN \LAFITEUSERDATA)))
(SETQ GVUSERNAME (FULLUSERNAME T))
(SETQ FULLNAME (CONCAT (CAR GVUSERNAME)
"."
(CDR GVUSERNAME)))
(COND
((NEQ [SETQ AUTHENTICATED? (GV.AUTHENTICATE GVUSERNAME (SETQ PASS (GV.MAKEKEY
(CDR (\INTERNAL/GETPASSWORD]
T)
(printout PROMPTWINDOW T "Cannot authenticate user " FULLNAME " because: " (SETQ
\LAFITE.AUTHENTICATION.FAILURE AUTHENTICATED?)
"."))
([NULL (SETQ MAILSERVERS (CDR (GV.EXPAND GVUSERNAME]
(printout PROMPTWINDOW T "There are no mail servers for user " FULLNAME))
(T (SETQ \LAFITEUSERDATA
(create LAFITEUSERDATA
FULLUSERNAME ← FULLNAME
UNPACKEDUSERNAME ← GVUSERNAME
ENCRYPTEDPASSWORD ← PASS
SHORTUSERNAME ← FULLNAME
MAILSERVERS ←(for MAILSERVER in MAILSERVERS bind SERVEROPS SERVERPORT
SERVERDEF
when [COND
((NULL (SETQ SERVEROPS (GETMAILSERVEROPS MAILSERVER)))
NIL)
((NULL (SETQ SERVERPORT (APPLY* (fetch (MAILSERVEROPS
SERVERPORTFROMNAME)
of SERVEROPS)
MAILSERVER)))
(printout PROMPTWINDOW T "Can't find address of "
MAILSERVER)
NIL)
(T (SETQ SERVERDEF
(create MAILSERVER
MAILPORT ← SERVERPORT
MAILSERVERNAME ← MAILSERVER
MAILSERVEROPS ← SERVEROPS]
collect SERVERDEF)))
(RETURN \LAFITEUSERDATA])
(GETMAILSERVEROPS
[LAMBDA (MAILSERVER) (* bvm: "12-Nov-84 17:52")
(PROG ((SERVERTYPE (\GV.MAILSERVERTYPE MAILSERVER))
OPS)
(RETURN (COND
([AND SERVERTYPE (SETQ OPS (OR (ASSOC SERVERTYPE MAILSERVERTYPES)
(AND (EQ SERVERTYPE (QUOTE MTP))
(PROGN (FILESLOAD (SYSLOAD FROM VALUEOF
LISPUSERSDIRECTORIES)
MTP)
(ASSOC SERVERTYPE MAILSERVERTYPES]
(CDR OPS))
(T (printout PROMPTWINDOW T "Lafite cannot retrieve mail from " MAILSERVER)
NIL])
(\GV.MAILSERVERTYPE
[LAMBDA (MAILSERVERNAME) (* bvm: " 1-Jan-84 17:48")
(* * type is determined by the name currently * *)
(COND
((UCASE.STREQUAL (SUBSTRING MAILSERVERNAME -3)
".MS")
(QUOTE GV))
((UCASE.STREQUAL MAILSERVERNAME "MAXC")
(QUOTE MTP])
)
(DEFINEQ
(\GV.SENDMESSAGE
[LAMBDA (MSG PARSE EDITORWINDOW ABORTWINDOW) (* bvm: "11-Mar-85 23:54")
(* * This is the real mail sender for the GrapeVine * *)
(* * MSG is the entire text of the message -- RECIPIENTS is a parsed list of recipients * *)
(PROG ((PWINDOW (AND EDITORWINDOW (GETPROMPTWINDOW EDITORWINDOW)))
(RECIPIENTS (fetch GVPRECIPIENTS of PARSE))
(FROMFIELD (fetch GVPFROM of PARSE))
(FORMATTING (fetch GVPFORMAT of PARSE))
(DATEFIELD (CONCAT "Date: " (DATE (DATEFORMAT NO.SECONDS TIME.ZONE SPACES))
LAFITEEOL))
(FAILURECNT 0)
DATELEN SENDINGSOCKET RECIPIENTSCHECK SENDRESULT SENDERFIELD SENDER TYPE ABORTMENU)
[COND
((NOT (TYPENAMEP MSG (QUOTE STREAM)))
(RETURN (\ILLEGAL.ARG MSG]
(SETQ FORMATTING (SELECTQ FORMATTING
((MULTIMEDIA TEDIT)
T)
(TEXT NIL)
(\ILLEGAL.ARG FORMATTING)))
[COND
(PWINDOW (CLEARW PWINDOW)
(printout PWINDOW "Delivering " (COND
(FORMATTING "formatted ")
(T ""))
"to "
(LENGTH RECIPIENTS)
" recipient")
(COND
((CDR RECIPIENTS)
(printout PWINDOW (QUOTE s]
LP (COND
((NULL (\LAFITE.GET.USER.DATA)) (* \LAFITE.GET.USER.DATA didn't make it -- get out *)
(RETURN)))
[SETQ SENDERFIELD (SETQ SENDER (COND
((fetch (LAFITEUSERDATA FULLUSERNAME) of \LAFITEUSERDATA))
(T (* Huh? we just set it)
(GO LP]
[COND
((SETQ TYPE (COND
((NULL FROMFIELD)
"From: ")
((OR (PROG1 T
(* would like to suppress this, but at this point we have no way of knowing whether the text of the message includes
the sender's registry)
)
(CDR FROMFIELD)
(NOT (UCASE.STREQUAL (CONCAT (CAAR FROMFIELD)
"."
(CDAR FROMFIELD))
SENDERFIELD)))
"Sender: ")))
(SETQ SENDERFIELD (CONCAT TYPE SENDERFIELD LAFITEEOL]
[COND
(FORMATTING (TEDIT.INSERT MSG DATEFIELD 1)
[TEDIT.INSERT MSG SENDERFIELD (ADD1 (SETQ DATELEN (NCHARS DATEFIELD]
(* Do tedit conversion now, before we have the stream
tied up)
[SETQ MSG (PROG1 (COERCETEXTOBJ MSG (QUOTE SPLIT))
(TEDIT.DELETE MSG 1 (IPLUS DATELEN (NCHARS SENDERFIELD]
(SETQ FORMATTING (CDR MSG))
(SETQ MSG (CAR MSG))
[PROGN (* Temporary until GETFILEINFO is fixed)
(COND
((NOT (OPENP MSG (QUOTE INPUT)))
(SETQ MSG (OPENSTREAM MSG (QUOTE INPUT)))
(SETQ FORMATTING (OPENSTREAM FORMATTING (QUOTE INPUT]
(COND
((IGREATERP (IPLUS (GETFILEINFO MSG (QUOTE LENGTH))
(GETFILEINFO FORMATTING (QUOTE LENGTH)))
(IDIFFERENCE 99999 24))
(RETURN (\LAFITE.SEND.FAIL EDITORWINDOW
"Message too long to send formatted. Either break it up or send it as plain text."]
STARTSEND
(as I to 3 until (SETQ SENDINGSOCKET (GV.STARTSEND (fetch (LAFITEUSERDATA UNPACKEDUSERNAME)
of \LAFITEUSERDATA)
(fetch (LAFITEUSERDATA ENCRYPTEDPASSWORD)
of \LAFITEUSERDATA)
(fetch (LAFITEUSERDATA UNPACKEDUSERNAME)
of \LAFITEUSERDATA)
T))
do (* loop 3 times trying to start this send *)
(DISMISS 1000))
[COND
((NULL SENDINGSOCKET)
(RETURN (\LAFITE.SEND.FAIL EDITORWINDOW "Couldn't connect to a maildrop"]
(RESETSAVE NIL (LIST (FUNCTION GV.KILLSOCKET)
SENDINGSOCKET))
(AND PWINDOW (printout PWINDOW (QUOTE ...)))
(COND
((AND ABORTWINDOW (WINDOWPROP ABORTWINDOW (QUOTE ABORT)))
(ERROR!)))
(SELECTQ (SETQ RECIPIENTSCHECK (\GV.SENDRECIPIENTS SENDINGSOCKET RECIPIENTS EDITORWINDOW))
(NIL (* MS didn't like the recipients list -- this was
already reported by \GV.SENDRECIPIENTS *)
(RETURN NIL))
(? (* Something went wrong, try again)
(GO TRYAGAIN))
NIL) (* Everything is OK *)
(COND
((AND ABORTWINDOW (WINDOWPROP ABORTWINDOW (QUOTE ABORT)))
(ERROR!))) (* send code to start sending text *)
(GV.STARTITEM SENDINGSOCKET)
(COND
((NOT FORMATTING)
(GV.ADDTOITEM SENDINGSOCKET DATEFIELD)
(GV.ADDTOITEM SENDINGSOCKET SENDERFIELD))) (* send the message *)
(COND
((AND ABORTWINDOW (WINDOWPROP ABORTWINDOW (QUOTE ABORT)))
(ERROR!)))
(GV.ADDTOITEM SENDINGSOCKET MSG) (* tell the grapevine to send the message *)
(COND
(FORMATTING (COND
((AND ABORTWINDOW (WINDOWPROP ABORTWINDOW (QUOTE ABORT)))
(ERROR!)))
(GV.STARTITEM SENDINGSOCKET \I.TEDITFORMATTING)
(* Send formatting info)
(GV.ADDTOITEM SENDINGSOCKET FORMATTING)))
(COND
((NULL ABORTWINDOW))
((WINDOWPROP ABORTWINDOW (QUOTE ABORT))
(ERROR!))
(T (* Too late to abort now)
(DELETEMENU [SETQ ABORTMENU (CAR (WINDOWPROP ABORTWINDOW (QUOTE MENU]
NIL ABORTWINDOW)))
(COND
((EQ (SETQ SENDRESULT (GV.SEND SENDINGSOCKET))
T)
(RETURN T)))
TRYAGAIN
[COND
((IGREATERP (add FAILURECNT 1)
4)
(RETURN (\LAFITE.SEND.FAIL EDITORWINDOW "Several unsuccessful attempts"]
(AND PWINDOW (printout PWINDOW " problems, trying again."))
(GV.KILLSOCKET SENDINGSOCKET) (* Just in case it's still alive)
(COND
(ABORTMENU (* Restore the Abort menu that we took down)
(ADDMENU ABORTMENU ABORTWINDOW (QUOTE (0 . 0)))
(SETQ ABORTMENU)))
(GO STARTSEND])
(\GV.SENDRECIPIENTS
[LAMBDA (SOCKET RECIPIENTS EDITORWINDOW) (* DECLARATIONS: (RECORD (#OFVALIDRECIPIENTS .
INVALIDRECIPIENTS)) (RECORD INVALIDRECIPIENT (RECIPIENT# . RECIPIENTNAME)))
(* bvm: " 6-Nov-84 11:53")
(PROG (REASON VALIDITYRESULT INVALID)
[COND
((NLISTP RECIPIENTS)
(SETQ REASON "No recipients supplied"))
(T (for R in RECIPIENTS do (GV.ADDRECIPIENT SOCKET R))
(SETQ VALIDITYRESULT (GV.CHECKVALIDITY SOCKET))
(COND
((NLISTP VALIDITYRESULT)
(RETURN (QUOTE ?)))
((NULL (SETQ INVALID (fetch INVALIDRECIPIENTS of VALIDITYRESULT)))
(* everything went OK *)
(RETURN VALIDITYRESULT))
(T (* GV didn't like some recipients *)
(SETQ REASON (\LAFITE.INVALID.RECIPIENTS (for RECIPIENT in INVALID
collect (fetch (INVALIDRECIPIENT
RECIPIENTNAME)
of RECIPIENT]
FAILED
(RETURN (\LAFITE.SEND.FAIL EDITORWINDOW REASON])
)
(DEFINEQ
(\GV.SEND.PARSE
[LAMBDA (MSG EDITORWINDOW) (* bvm: "24-Feb-85 22:30")
(PROG (RECIPIENTS MSGFIELDS FROMFIELD SENDINGFORMAT HEADEREOF REPLYTO SUBJECT)
(OR (SETQ MSGFIELDS (\LAFITE.PREPARE.SEND MSG EDITORWINDOW))
(RETURN))
[COND
((EQ (CAAR MSGFIELDS)
(QUOTE EOF))
(SETQ HEADEREOF (CADR (pop MSGFIELDS]
(for PAIR in MSGFIELDS do (SELECTQ (CAR PAIR)
(Date (\SENDMESSAGEFAIL EDITORWINDOW
"User-supplied Date not allowed"))
[(To cc)
(SETQ RECIPIENTS (NCONC RECIPIENTS
(\GV.PARSERECIPIENTS
(CDR PAIR)
NIL T EDITORWINDOW]
(From (SETQ FROMFIELD (\GV.PARSERECIPIENTS (CDR PAIR)
NIL T
EDITORWINDOW)))
(Reply-to (SETQ REPLYTO (\GV.PARSERECIPIENTS
(CDR PAIR)
NIL T EDITORWINDOW)))
(Sender (\SENDMESSAGEFAIL EDITORWINDOW
"User-supplied Sender not allowed"))
(Format (SETQ SENDINGFORMAT (CADR PAIR)))
(Subject (SETQ SUBJECT (CADR PAIR)))
NIL))
(COND
((NULL RECIPIENTS)
(\SENDMESSAGEFAIL EDITORWINDOW "No recipients!")
(RETURN))
((FMEMB NIL RECIPIENTS) (* if there is a NIL in RECIPIENTS then
\GV.PARSERECIPIENTS couldn't parse something {it
already reported it} therefore just get out now *)
(RETURN NIL)))
[COND
((NULL SENDINGFORMAT)
(SETQ SENDINGFORMAT (OR (\LAFITE.CHOOSE.MSG.FORMAT MSG HEADEREOF EDITORWINDOW)
(RETURN]
[COND
([AND EDITORWINDOW (NULL REPLYTO)
(for GVNAME in RECIPIENTS thereis (EQ (NTHCHARCODE (CAR GVNAME)
-1)
(CHARCODE ↑]
(OR (\LAFITE.CHOOSE.REPLYTO MSG HEADEREOF FROMFIELD EDITORWINDOW)
(RETURN]
(AND FROMFIELD (SETQ FROMFIELD (\CHECKMESSAGEADDRESSES FROMFIELD EDITORWINDOW)))
(RETURN (create GVMAILPARSE
GVPSUBJECT ← SUBJECT
GVPFROM ← FROMFIELD
GVPFORMAT ← SENDINGFORMAT
GVPRECIPIENTS ← RECIPIENTS])
(\GV.PARSERECIPIENTS
[LAMBDA (FIELD REGISTRY INTERNALFLG EDITWINDOW) (* bvm: "12-Nov-84 17:51")
[SETQ FIELD (COND
((LISTP FIELD)
(for PIECE in FIELD join (\GV.PARSERECIPIENTS1 PIECE REGISTRY INTERNALFLG EDITWINDOW)))
(T (\GV.PARSERECIPIENTS1 FIELD REGISTRY INTERNALFLG EDITWINDOW]
(COND
(INTERNALFLG FIELD)
(T (LA.REMOVEDUPLICATES FIELD])
(\GV.PARSE.ARPA.ADDRESS
[LAMBDA (ADDRESS DOMAINTAIL INTERNALFLG) (* bvm: "12-Nov-84 17:52")
(COND
(INTERNALFLG (* if INTERNALFLG then build an arpanet address to send
to the GV -- otherwise build it for text in the messge
*)
(CONS (\GV.REPACKADDRESS ADDRESS)
ARPANETGATEWAY.REGISTRY))
(T (\GV.REPACKADDRESS (COND
((AND (SETQ DOMAINTAIL (FMEMB (QUOTE %.)
DOMAINTAIL))
(EQ (CADR DOMAINTAIL)
(QUOTE ARPA))
(NULL (CDDR DOMAINTAIL)))
(* is (FOO . ARPA) -- just get the FOO)
(LDIFF ADDRESS DOMAINTAIL))
(T ADDRESS])
(\GV.PARSERECIPIENTS1
[LAMBDA (FIELD REGISTRY INTERNALFLG EDITWINDOW) (* bvm: "12-Nov-84 17:52")
(* * INTERNALFLG = T means produce addresses to give Grapevine; NIL means give human-readable addresses)
(PROG (FIELDSTREAM ADDRESSES ADDR TOKEN)
(COND
((NULL FIELD)
(RETURN)))
(SETQ FIELDSTREAM (OPENSTRINGSTREAM FIELD))
[SETFILEINFO FIELDSTREAM (QUOTE ENDOFSTREAMOP)
(FUNCTION (LAMBDA (STREAM) (* Terminate anything in progress)
(CHARCODE ,] (* first just collect all the atoms using a special
readtable *)
(OR REGISTRY (SETQ REGISTRY DEFAULTREGISTRY))
(SETQ ADDRESSES (when (SETQ ADDR (until (EQ (SETQ TOKEN (READ FIELDSTREAM
ADDRESSPARSERRDTBL))
(QUOTE ,))
when (PROGN (* Lists are comments)
(NLISTP TOKEN))
collect TOKEN))
collect ADDR repeatuntil (EOFP FIELDSTREAM)))
(RETURN (for ADDRESS in ADDRESSES bind REALADDRESS VALIDRECIPIENT CLOSE OPEN
collect (* ADDRESS will only get rebound if there is an address
with <>'s in it *)
(SETQ VALIDRECIPIENT (\GV.PARSE.SINGLE.ADDRESS
(COND
([AND (SETQ OPEN (FMEMB (QUOTE <)
ADDRESS))
(SETQ CLOSE (FMEMB (QUOTE >)
(CDR OPEN]
(SETQ REALADDRESS (LDIFF (CDR OPEN)
CLOSE)))
(T ADDRESS))
REGISTRY INTERNALFLG EDITWINDOW))
(COND
((OR T INTERNALFLG (NULL REALADDRESS))
VALIDRECIPIENT)
(T (* Need to figure out how to make GETREGISTRY of this
work, and remove duplicates in MAKEANSWERFORM before we
can enable this)
(\GV.REPACKADDRESS (APPEND (LDIFF ADDRESS OPEN)
(LIST (QUOTE <)
VALIDRECIPIENT
(QUOTE >))
(CDR CLOSE])
(\GV.PARSE.SINGLE.ADDRESS
[LAMBDA (ADDRESS REGISTRY INTERNALFLG EDITWINDOW) (* bvm: "12-Nov-84 17:52")
(* * Parses a single ADDRESS, a list, and returns a proper address as a string, or if INTERNALFLG, in the form
Grapevine likes)
(PROG (DOMAINTAIL)
(RETURN (COND
((SETQ DOMAINTAIL (FMEMB (QUOTE @)
ADDRESS)) (* have an ARPA Internet address *)
(\GV.PARSE.ARPA.ADDRESS ADDRESS DOMAINTAIL INTERNALFLG))
((CDR ADDRESS) (* had some special characters)
(COND
[(AND (EQ (CADR ADDRESS)
(QUOTE %.))
(NULL (CDDDR ADDRESS)))
(COND
(INTERNALFLG (CONS (CAR ADDRESS)
(OR (CADDR ADDRESS)
REGISTRY)))
(T (\GV.REPACKADDRESS ADDRESS]
(T [COND
(EDITWINDOW (\SENDMESSAGEFAIL EDITWINDOW "Recipient not understood: "
(\GV.REPACKADDRESS ADDRESS]
NIL)))
(T (* Address without registry, supply default)
(COND
(INTERNALFLG (CONS (CAR ADDRESS)
REGISTRY))
(T (CONCAT (CAR ADDRESS)
"." REGISTRY])
(\GV.REPACKADDRESS
[LAMBDA (ADDRESS) (* bvm: "22-Dec-84 00:40")
(* * Takes a list produced by parsing a single recipient and turns it back into a string you could present to the
user)
(COND
[(CDR ADDRESS)
(for X in ADDRESS bind RESULT (BREAKCHARP ← T)
do (COND
([NULL (PROG1 BREAKCHARP (SETQ BREAKCHARP
(SELECTQ X
((%. : ; < > @ %[ %])
X)
NIL]
(SELECTQ BREAKCHARP
((NIL < %[) (* Like to have space before these breakchars)
(push RESULT " "))
NIL)))
(COND
((STRINGP X) (* Make sure we keep the quotes)
(push RESULT (QUOTE %")
X
(QUOTE %")))
(T (push RESULT X)))
finally (RETURN (CONCATLIST (REVERSE RESULT]
(T (CAR ADDRESS])
(\GV.COLLECTADDRESSES
[LAMBDA (FIELDS) (* M.Yonke " 3-JUN-83 17:12")
(* * FIELDS is a list of atoms and strings -- this function groups them into addresses and returns a list of
addresses -- each one a list of fields * *)
(PROG (ADDRESS REST) (* addresses are separated by commas *)
[SETQ ADDRESS (LDIFF FIELDS (SETQ REST (MEMB (QUOTE ,)
FIELDS]
(* get rid of the comma *)
(SETQ REST (CDR REST))
(RETURN (COND
((AND ADDRESS REST) (* just keep going *)
(CONS ADDRESS (\GV.COLLECTADDRESSES REST)))
((AND (NOT ADDRESS)
REST) (* there was a ", ," in the address or the list started
with a comma *)
(\GV.COLLECTADDRESSES REST))
((AND ADDRESS (NOT REST)) (* at the end *)
(LIST ADDRESS))
(T NIL])
(\CHECKMESSAGEADDRESSES
[LAMBDA (ADDRESSES EDITORWINDOW) (* bvm: " 1-Jun-84 13:01")
(* Check that each of ADDRESSES is a valid mail
address.)
[for ADDR in ADDRESSES do (COND
((NLISTP (GV.EXPAND ADDR))
(\SENDMESSAGEFAIL EDITORWINDOW "From field not valid address: "
(CONCAT (CAR ADDR)
"."
(CDR ADDR]
ADDRESSES])
(\LAFITE.CHOOSE.REPLYTO
[LAMBDA (TEXTSTREAM HEADEREOF FROMFIELD EDITORWINDOW) (* bvm: "24-Feb-85 18:41")
(* * Invoked when sending to a distribution list. Ask user for Reply-to: field, and if one is chosen, enter it into
message)
(COND
((NULL EDITORWINDOW)
T)
(T
(SELECTQ
(\SENDMESSAGE.MENUPROMPT EDITORWINDOW (.LAFITEMENU. LAFITEREPLYTOMENU
LAFITEREPLYTOMENUITEMS
"Include a Reply-to field?")
"Message is addressed to a distribution list")
(NO T)
(SELF
(TEDIT.INSERT
TEXTSTREAM
(CONCATLIST (CONS "Reply-to: "
(NCONC1 [COND
[FROMFIELD (* Message explicitly from someone other than logged-in
user, so set accordingly)
(CDR (for GVNAME in FROMFIELD
join (CONS ", " (COND
((EQ (CDR GVNAME)
ARPANETGATEWAY.REGISTRY)
(LIST (CAR GVNAME)))
(T (LIST (CAR GVNAME)
"."
(CDR GVNAME]
(T (LIST (FULLUSERNAME]
LAFITEEOL)))
HEADEREOF)
T)
(OTHER (TEDIT.INSERT TEXTSTREAM "Reply-to: >>Address<<
" HEADEREOF)
(\LAFITE.FIND.TEMPLATE TEXTSTREAM) (* Select template for user, then return NIL to cause
reediting)
NIL)
(ABORT NIL)
NIL])
)
(DEFINEQ
(GV.MAKEANSWERFORM
[LAMBDA (MSGDESCRIPTORS MAILFOLDER) (* bvm: "12-Nov-84 17:51")
(PROG ((MSGDESCRIPTOR (OR (CAR (LISTP MSGDESCRIPTORS))
MSGDESCRIPTORS))
SUBJECT FROM DATE SENDER REPLYTO TO CC ORIGINALREGISTRY OLDFROM OLDREPLYTO OLDTO OLDCC
NEWTO NEWCC OUTSTREAM SELECTPOSITION MSGFIELDS) (* get the fields from the file or data *)
[SETQ MSGFIELDS (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER)
(LAFITE.PARSE.HEADER (\LAFITE.OPEN.FOLDER MAILFOLDER
(QUOTE INPUT))
\LAPARSE.FULL
(fetch (LAFITEMSG START) of
MSGDESCRIPTOR)
(fetch (LAFITEMSG END) of MSGDESCRIPTOR]
(for PAIR in MSGFIELDS do (SELECTQ (CAR PAIR)
(Subject (SETQ SUBJECT (CADR PAIR)))
(Sender (SETQ SENDER (CADR PAIR)))
(From (SETQ FROM (CADR PAIR)))
(Date (SETQ DATE (CADR PAIR)))
(Reply-to (SETQ REPLYTO (CDR PAIR)))
(To (SETQ TO (CDR PAIR)))
(cc (SETQ CC (CDR PAIR)))
NIL)) (* first parse the strings into recipients *)
(COND
[SENDER (* Sender is a mail address, and has the official
registry)
(SETQ ORIGINALREGISTRY (GETREGISTRY SENDER))
(SETQ OLDFROM (AND FROM (\GV.PARSERECIPIENTS FROM ORIGINALREGISTRY]
[FROM (* Have to parse the From field before we can get its
registry)
(SETQ ORIGINALREGISTRY (GETREGISTRY (CAR (SETQ OLDFROM (\GV.PARSERECIPIENTS FROM]
(T (LAB.PROMPTPRINT MAILFOLDER "Can't reply--no FROM or SENDER field")))
(SETQ OLDREPLYTO (AND REPLYTO (\GV.PARSERECIPIENTS REPLYTO ORIGINALREGISTRY)))
(SETQ OLDTO (AND TO (\GV.PARSERECIPIENTS TO ORIGINALREGISTRY)))
(SETQ OLDCC (AND CC (\GV.PARSERECIPIENTS CC ORIGINALREGISTRY)))
(* * Now construct the TO and CC fields of the reply)
(SETQ NEWTO (OR OLDREPLYTO OLDFROM))
(SETQ NEWCC (LA.SETDIFFERENCE [COND
(OLDREPLYTO (LIST (FULLUSERNAME)))
(T (LA.REMOVEDUPLICATES (APPEND OLDTO OLDCC]
NEWTO)) (* now construct the message form *)
(SETQ OUTSTREAM (OPENTEXTSTREAM "" NIL NIL NIL (LIST (QUOTE FONT)
LAFITEEDITORFONT)))
(LINELENGTH MAX.SMALLP OUTSTREAM) (* Sigh, apparently text streams have linelength)
(printout OUTSTREAM "Subject: ")
(COND
((NOT (UCASE.STREQUAL (SUBSTRING SUBJECT 1 3)
"Re:"))
(printout OUTSTREAM "Re: ")))
(printout OUTSTREAM (OR SUBJECT UNSUPPLIEDFIELDSTR)
T)
(printout OUTSTREAM "In-reply-to: " FROM "'s message of " DATE T)
(printout OUTSTREAM "To: ")
(LA.PRINTADDRESSES NEWTO OUTSTREAM)
(COND
(NEWCC (printout OUTSTREAM "cc: ")
(LA.PRINTADDRESSES NEWCC OUTSTREAM)))
(printout OUTSTREAM T)
(SETQ SELECTPOSITION (ADD1 (GETFILEPTR OUTSTREAM)))
(printout OUTSTREAM MESSAGESTR T)
(TEDIT.SETSEL OUTSTREAM SELECTPOSITION (NCHARS MESSAGESTR)
(QUOTE RIGHT)
T)
(RETURN OUTSTREAM])
(GETREGISTRY
[LAMBDA (NAME) (* rrb "27-AUG-82 14:30")
(* returns the registry field of a name if it has one;
NIL otherwise.)
(* grapevine spec is any part after the last "."
is the registry.)
(PROG ((LOC (STRPOS "." NAME))
NXTLOC)
(COND
((NULL LOC) (* no registry.)
(RETURN NIL)))
LP (while (SETQ NXTLOC (STRPOS "." NAME (ADD1 LOC))) do (SETQ LOC NXTLOC))
(RETURN (SUBSTRING NAME (ADD1 LOC)
-1])
(LA.PRINTADDRESSES
[LAMBDA (ADDRESSLIST STREAM) (* bvm: "20-Dec-83 18:20")
(for ADDR in ADDRESSLIST bind NTHTIME when ADDR
do (COND
(NTHTIME (PRIN1 ", " STREAM))
(T (SETQ NTHTIME T)))
(PRIN1 ADDR STREAM))
(TERPRI STREAM])
)
(ADDTOVAR MAILSERVERTYPES )
(RPAQ? ARPANETGATEWAY.REGISTRY (QUOTE AG))
(RPAQ? LAFITEREPLYTOMENU )
(ADDTOVAR LISPSUPPORT (GV "LispSupport.pa"))
(ADDTOVAR LAFITESUPPORT (GV "LafiteSupport.pa"))
(ADDTOVAR TEDITSUPPORT (GV "TEditSupport.pa"))
(RPAQQ LAFITEREPLYTOMENUITEMS (("Send message as is" (QUOTE NO))
("Reply-to: me" (QUOTE SELF)
"Insert a Reply-to: field instructing responder to reply only to you")
("Reply-to: other" (QUOTE OTHER)
"Edit your own Reply-to: field into the message")
("Abort" (QUOTE ABORT)
"Don't send the message")))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \LAFITEUSERDATA MAILSERVERTYPES ARPANETGATEWAY.REGISTRY LAFITEREPLYTOMENUITEMS
LAFITEREPLYTOMENU)
)
(PUTPROPS MAINTAIN FILEDEF MAINTAIN)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(RECORD OPENEDMAILBOX (MAILBOX . PROPERTIES)
(PROPRECORD PROPERTIES (#OFMESSAGES)))
(PROPRECORD NEXTMESSAGE (ARCHIEVEDFLG DELETEDFLG LENGTH))
]
(* END EXPORTED DEFINITIONS)
[DECLARE: EVAL@COMPILE
(RECORD MAILPORT (HOST# . SOCKET#))
(RECORD GVMAILPARSE (GVPSUBJECT GVPFROM GVPFORMAT . GVPRECIPIENTS))
]
(RPAQQ MAILCLIENTCONSTANTCOMS ((* Mail retrieval opcodes *)
(CONSTANTS (\OP.ADDRECIPIENT 21)
(\OP.ADDTOITEM 24)
(\OP.CHECKVALIDITY 22)
(\OP.HUMANMESS 520)
(\OP.MSEXPAND 27)
(\OP.SEND 26)
(\OP.STARTITEM 23)
(\OP.STARTSEND 20))
(CONSTANTS (\MAILSOCKETTIMEOUT 36000000))
(* Mail sender opcodes *)
(CONSTANTS (\OP.OPENINBOX 0)
(\OP.NEXTMESSAGE 1)
(\OP.READTOC 2)
(\OP.READMESSAGE 3)
(\OP.WRITETOC 4)
(\OP.DELETEMESSAGE 5)
(\OP.FLUSH 6))
(* return codes from "start to send a message" *)
(CONSTANTS (\RC.SENDSTARTED 0)
(\RC.PASSWORDINVALID 1)
(\RC.SENDERNOTREGISTERED 2)
(\RC.RETURNTONOTREGISTERED 3)
(\RC.COMMUNICATIONFAILURE 4))
(* return codes from "open mail box" *)
(CONSTANTS (\RC.NAMEISGROUP 1)
(\RC.NAMEANDPASSWORDVALID 2)
(\RC.NAMENOTREGISTERED 3)
(\RC.COMMUNICATIONFAILURE 4)
(\RC.INVALIDPASSWORD 5))
(* Message Item types *)
(CONSTANTS (\I.POSTMARK 8)
(\I.SENDER 16)
(\I.RETURNTO 24)
(\I.RECIPIENTS 32)
(\I.TEXT 520)
(\I.OLDTEDITFORMATTING 560)
(\I.TEDITFORMATTING 561)
(\I.END 65535))
(CONSTANTS (\PT.LAURELCHECK 140)
(\PT.NOMAILBOX 139)
(\PT.NONEWMAIL 138)
(\PT.NEWMAIL 137))))
(* Mail retrieval opcodes *)
(DECLARE: EVAL@COMPILE
(RPAQQ \OP.ADDRECIPIENT 21)
(RPAQQ \OP.ADDTOITEM 24)
(RPAQQ \OP.CHECKVALIDITY 22)
(RPAQQ \OP.HUMANMESS 520)
(RPAQQ \OP.MSEXPAND 27)
(RPAQQ \OP.SEND 26)
(RPAQQ \OP.STARTITEM 23)
(RPAQQ \OP.STARTSEND 20)
(CONSTANTS (\OP.ADDRECIPIENT 21)
(\OP.ADDTOITEM 24)
(\OP.CHECKVALIDITY 22)
(\OP.HUMANMESS 520)
(\OP.MSEXPAND 27)
(\OP.SEND 26)
(\OP.STARTITEM 23)
(\OP.STARTSEND 20))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \MAILSOCKETTIMEOUT 36000000)
(CONSTANTS (\MAILSOCKETTIMEOUT 36000000))
)
(* Mail sender opcodes *)
(DECLARE: EVAL@COMPILE
(RPAQQ \OP.OPENINBOX 0)
(RPAQQ \OP.NEXTMESSAGE 1)
(RPAQQ \OP.READTOC 2)
(RPAQQ \OP.READMESSAGE 3)
(RPAQQ \OP.WRITETOC 4)
(RPAQQ \OP.DELETEMESSAGE 5)
(RPAQQ \OP.FLUSH 6)
(CONSTANTS (\OP.OPENINBOX 0)
(\OP.NEXTMESSAGE 1)
(\OP.READTOC 2)
(\OP.READMESSAGE 3)
(\OP.WRITETOC 4)
(\OP.DELETEMESSAGE 5)
(\OP.FLUSH 6))
)
(* return codes from "start to send a message" *)
(DECLARE: EVAL@COMPILE
(RPAQQ \RC.SENDSTARTED 0)
(RPAQQ \RC.PASSWORDINVALID 1)
(RPAQQ \RC.SENDERNOTREGISTERED 2)
(RPAQQ \RC.RETURNTONOTREGISTERED 3)
(RPAQQ \RC.COMMUNICATIONFAILURE 4)
(CONSTANTS (\RC.SENDSTARTED 0)
(\RC.PASSWORDINVALID 1)
(\RC.SENDERNOTREGISTERED 2)
(\RC.RETURNTONOTREGISTERED 3)
(\RC.COMMUNICATIONFAILURE 4))
)
(* return codes from "open mail box" *)
(DECLARE: EVAL@COMPILE
(RPAQQ \RC.NAMEISGROUP 1)
(RPAQQ \RC.NAMEANDPASSWORDVALID 2)
(RPAQQ \RC.NAMENOTREGISTERED 3)
(RPAQQ \RC.COMMUNICATIONFAILURE 4)
(RPAQQ \RC.INVALIDPASSWORD 5)
(CONSTANTS (\RC.NAMEISGROUP 1)
(\RC.NAMEANDPASSWORDVALID 2)
(\RC.NAMENOTREGISTERED 3)
(\RC.COMMUNICATIONFAILURE 4)
(\RC.INVALIDPASSWORD 5))
)
(* Message Item types *)
(DECLARE: EVAL@COMPILE
(RPAQQ \I.POSTMARK 8)
(RPAQQ \I.SENDER 16)
(RPAQQ \I.RETURNTO 24)
(RPAQQ \I.RECIPIENTS 32)
(RPAQQ \I.TEXT 520)
(RPAQQ \I.OLDTEDITFORMATTING 560)
(RPAQQ \I.TEDITFORMATTING 561)
(RPAQQ \I.END 65535)
(CONSTANTS (\I.POSTMARK 8)
(\I.SENDER 16)
(\I.RETURNTO 24)
(\I.RECIPIENTS 32)
(\I.TEXT 520)
(\I.OLDTEDITFORMATTING 560)
(\I.TEDITFORMATTING 561)
(\I.END 65535))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \PT.LAURELCHECK 140)
(RPAQQ \PT.NOMAILBOX 139)
(RPAQQ \PT.NONEWMAIL 138)
(RPAQQ \PT.NEWMAIL 137)
(CONSTANTS (\PT.LAURELCHECK 140)
(\PT.NOMAILBOX 139)
(\PT.NONEWMAIL 138)
(\PT.NEWMAIL 137))
)
(FILESLOAD (LOADCOMP)
GRAPEVINE PUP BSP LAFITE LAFITEMAIL)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(FILESLOAD GRAPEVINE)
)
(PUTPROPS MAILCLIENT COPYRIGHT ("Xerox Corporation" 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3124 7183 (GV.STARTSEND 3134 . 4081) (GV.ADDRECIPIENT 4083 . 4273) (GV.CHECKVALIDITY
4275 . 4474) (GV.STARTITEM 4476 . 4798) (GV.ADDTOITEM 4800 . 6660) (GV.SEND 6662 . 6836) (MS.EXPAND
6838 . 7181)) (7213 10766 (MS.SENDOPERATION 7223 . 8055) (\FINDMAILSERVER 8057 . 8510) (
\MAILSERVERSOCKETS 8512 . 8992) (\RECEIVEACK 8994 . 9283) (\RESPTOCHECKVAL 9285 . 9795) (\RESPTOEXPAND
9797 . 10328) (\RESPTOSTARTSEND 10330 . 10764)) (11261 14994 (GV.PORTFROMNAME 11271 . 11464) (
GV.POLLNEWMAIL 11466 . 12618) (GV.OPENMAILBOX 12620 . 13464) (GV.NEXTMESSAGE 13466 . 14105) (
GV.RETRIEVEMESSAGE 14107 . 14628) (GV.CLOSEMAILBOX 14630 . 14992)) (15169 15781 (GV.READTOC 15179 .
15370) (GV.WRITETOC 15372 . 15577) (GV.DELETEMESSAGE 15579 . 15779)) (15813 20104 (
MS.RETRIEVEOPERATION 15823 . 16401) (\CONNECTTOMAILSERVER 16403 . 16877) (\OPENMAILSERVER 16879 .
17950) (\RESPTOOPENMAILBOX 17952 . 18430) (\RESPTONEXTMESSAGE 18432 . 18636) (\RESPTORETRIEVEMESSAGE
18638 . 18866) (\RECEIVEMESSAGEITEM 18868 . 19785) (\RECEIVELONGWORD 19787 . 20102)) (20360 23201 (
GV.INIT.MAIL.USER 20370 . 22199) (GETMAILSERVEROPS 22201 . 22846) (\GV.MAILSERVERTYPE 22848 . 23199))
(23202 31306 (\GV.SENDMESSAGE 23212 . 30056) (\GV.SENDRECIPIENTS 30058 . 31304)) (31307 42518 (
\GV.SEND.PARSE 31317 . 33699) (\GV.PARSERECIPIENTS 33701 . 34125) (\GV.PARSE.ARPA.ADDRESS 34127 .
34947) (\GV.PARSERECIPIENTS1 34949 . 37168) (\GV.PARSE.SINGLE.ADDRESS 37170 . 38458) (
\GV.REPACKADDRESS 38460 . 39417) (\GV.COLLECTADDRESSES 39419 . 40560) (\CHECKMESSAGEADDRESSES 40562 .
41080) (\LAFITE.CHOOSE.REPLYTO 41082 . 42516)) (42519 47246 (GV.MAKEANSWERFORM 42529 . 46144) (
GETREGISTRY 46146 . 46913) (LA.PRINTADDRESSES 46915 . 47244)))))
STOP