(FILECREATED " 2-Mar-86 17:08:15" {ERIS}<LAFITE>SOURCES>MAILCLIENT.;9 68165
changes to: (FNS \GV.PARSERECIPIENTS1)
previous date: "24-Feb-86 17:57:20" {ERIS}<LAFITE>SOURCES>MAILCLIENT.;8)
(* Copyright (c) 1983, 1984, 1985, 1986 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)
(INITVARS (\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.PARSE.FAILED
\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 (RECORDS NEXTMESSAGE MAILPORT
GVMAILPARSE)
(COMS * MAILCLIENTCONSTANTCOMS)
(FILES (SOURCE)
LAFITEDECLS)
(FILES (LOADCOMP)
GRAPEVINE PUP BSP))
(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:
"24-Jan-86 11:26")
(* * * 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:
"24-Jan-86 11:28")
(* * 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:
"24-Jan-86 11:29")
(* 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])
)
(RPAQ? \MAILIOTIMEOUT NIL)
(RPAQ? \MAILSERVERENQUIRYSOC 46)
(RPAQ? \MAILSERVERNAME (QUOTE (Maildrop . ms)))
(RPAQ? \MAILSERVERPOLLINGSOC 44)
(RPAQ? \MAILSERVERSOCKETCACHE )
(RPAQ? \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:
"24-Feb-86 17:11")
(SELECTQ (GV.POLLNEWMAIL GVPORT REGISTEREDNAME)
(NIL (QUOTE EMPTY))
(? NIL)
(LET (MAILBOX INBOXRESULT)
(COND
([AND (SETQ MAILBOX (\CONNECTTOMAILSERVER GVPORT))
(SETQ INBOXRESULT (CAR (NLSETQ (MS.RETRIEVEOPERATION \OP.OPENINBOX MAILBOX
(LIST (\CHECKNAME REGISTEREDNAME)
(\CHECKKEY PASSWORD))
(FUNCTION \RESPTOOPENMAILBOX]
(COND
((SMALLP INBOXRESULT)
(create OPENEDMAILBOX
MAILBOX ← MAILBOX
PROPERTIES ←(LIST (QUOTE #OFMESSAGES)
INBOXRESULT)))
(T (* Return failure
reason)
(create OPENEDMAILBOX
MAILBOX ← NIL
PROPERTIES ← 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) (* bvm:
" 4-Feb-86 12:25")
(LET [(MSGOUTSTREAM (GETSTREAM MSGOUTFILE (QUOTE OUTPUT]
(DECLARE (SPECVARS MSGOUTSTREAM))
(MS.RETRIEVEOPERATION \OP.READMESSAGE MAILBOX NIL (FUNCTION \RESPTORETRIEVEMESSAGE])
(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:
"24-Jan-86 11:31")
(* * 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:
"24-Feb-86 17:10")
(* * Open a BSP connection to mail server.
Its error handler defined as ERROR! so that BAD.STATE.FOR.BIN etc
suppressed)
(RESETVARS ((\RTP.DEFAULTTIMEOUT GV.MAILBOX.TIMEOUT))
(* * Crufty!!!! OPENBSPSTREAM should allow RFC timeout to be specified)
(RETURN (\OPENGVCONNECTION (CONS (CAR PORT)
\MAILSERVERRETRIEVALSOC)
NIL
(FUNCTION ERROR!])
(\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:
" 6-Oct-85 14:49")
(* * Ignores all items except of type text --
e.g. the message * *)
(DECLARE (USEDFREE MSGOUTSTREAM))
(PROG ((W (\WIN STREAM))
(LW (\RECEIVELONGWORD STREAM)))
RETRY
[SELECTC W
((APPEND (LIST \I.TEXT \I.TEDITFORMATTING)
(MKLIST \I.OLDTEDITFORMATTING))
(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: " 9-Dec-85 17:03")
(* * type is determined by the name currently * *)
(COND
((STRING-EQUAL (SUBSTRING MAILSERVERNAME -3)
".MS")
(QUOTE GV))
((STRING-EQUAL MAILSERVERNAME "MAXC")
(QUOTE MTP])
)
(DEFINEQ
(\GV.SENDMESSAGE
[LAMBDA (MSG PARSE EDITORWINDOW ABORTWINDOW) (* bvm: " 9-Dec-85 17:03")
(* * 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 (STRING-EQUAL (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-86 17:38")
(PROG ((REGISTRY (CDR (fetch (LAFITEUSERDATA UNPACKEDUSERNAME) of \LAFITEUSERDATA)))
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)
REGISTRY T EDITORWINDOW)
)))
(From (SETQ FROMFIELD (\GV.PARSERECIPIENTS
(CDR PAIR)
REGISTRY T EDITORWINDOW)))
(Reply-to (SETQ REPLYTO (\GV.PARSERECIPIENTS
(CDR PAIR)
REGISTRY 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 EDITWINDOW) (* bvm:
"24-Feb-86 17:45")
(COND
[INTERNALFLG (* if INTERNALFLG then
build an arpanet address
to send to the GV --
otherwise build it for
text in the messge *)
(LET (TAIL)
(while (SETQ TAIL (FMEMB (QUOTE %.)
(CDR DOMAINTAIL))) do (SETQ DOMAINTAIL TAIL))
(COND
((NEQ (CAR DOMAINTAIL)
(QUOTE %.)) (* Use default arpa
domain)
(CONS (\GV.REPACKADDRESS ADDRESS)
ARPANETGATEWAY.REGISTRY))
((CDDR DOMAINTAIL)
(\GV.PARSE.FAILED EDITWINDOW ADDRESS))
(T (* Use domain given in
address, e.g.
Fred@Xerox.COM =>
(Fred@Xerox . COM))
(CONS (\GV.REPACKADDRESS (LDIFF ADDRESS DOMAINTAIL))
(CADR DOMAINTAIL]
(T (\GV.REPACKADDRESS (COND
((AND NIL (SETQ DOMAINTAIL (FMEMB (QUOTE %.)
DOMAINTAIL))
(EQ (CADR DOMAINTAIL)
ARPANETGATEWAY.REGISTRY)
(NULL (CDDR DOMAINTAIL))) (* is (FOO . ARPA) --
just get the FOO)
(LDIFF ADDRESS DOMAINTAIL))
(T ADDRESS])
(\GV.PARSERECIPIENTS1
[LAMBDA (FIELD REGISTRY INTERNALFLG EDITWINDOW) (* bvm:
" 2-Mar-86 17:04")
(* * 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)
(SELECTQ (STREAMPROP STREAM (QUOTE EOFCOUNT))
(NIL (* First try
terminating with comma)
(STREAMPROP STREAM (QUOTE EOFCOUNT)
1)
(CHARCODE ,))
(1 (* Must be something
unbalanced. Try closing
a paren)
(STREAMPROP STREAM (QUOTE EOFCOUNT)
2)
(CHARCODE %)))
(2 (* Still unbalanced,
must have been a string)
(STREAMPROP STREAM (QUOTE EOFCOUNT)
3)
(CHARCODE %"))
(HELP] (* first just collect
all the atoms using a
special readtable *)
(OR REGISTRY (SETQ REGISTRY DEFAULTREGISTRY))
(SETQ ADDRESSES (when (SETQ ADDR (until (OR (EOFP FIELDSTREAM)
(EQ (SETQ TOKEN (READ FIELDSTREAM
ADDRESSPARSERRDTBL
))
(QUOTE ,)))
when (PROGN (* Lists are comments)
(NLISTP TOKEN)) collect TOKEN))
collect ADDR repeatuntil (EOFP FIELDSTREAM)))
[SELECTQ (STREAMPROP FIELDSTREAM (QUOTE EOFCOUNT))
((NIL 1)
(* Okay))
(COND
[EDITWINDOW (\SENDMESSAGEFAIL EDITWINDOW "Malformed address(es): "
(COND
((EQ (STREAMPROP FIELDSTREAM (QUOTE EOFCOUNT))
2)
"Unbalanced parentheses")
(T "Unbalanced quotes"]
(T (RETURN (CONS]
(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:
"24-Feb-86 17:45")
(* * Parses a single ADDRESS, a list, and returns a proper address as a
string, or if INTERNALFLG, in the form Grapevine likes)
(LET (DOMAINTAIL)
(COND
((SETQ DOMAINTAIL (FMEMB (QUOTE @)
ADDRESS)) (* have an ARPA
Internet address *)
(\GV.PARSE.ARPA.ADDRESS ADDRESS DOMAINTAIL INTERNALFLG EDITWINDOW))
[(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 (\GV.PARSE.FAILED EDITWINDOW ADDRESS]
(T (* Address without
registry, supply default)
(COND
(INTERNALFLG (CONS (CAR ADDRESS)
REGISTRY))
(T (CONCAT (CAR ADDRESS)
"." REGISTRY])
(\GV.PARSE.FAILED
[LAMBDA (EDITWINDOW ADDRESS) (* bvm:
"24-Feb-86 17:44")
[COND
(EDITWINDOW (\SENDMESSAGEFAIL EDITWINDOW "Recipient not understood: " (\GV.REPACKADDRESS
ADDRESS]
NIL])
(\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:
" 3-Feb-86 14:43")
(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 T "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 (STRING-EQUAL (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
[DECLARE: EVAL@COMPILE
(PROPRECORD NEXTMESSAGE (ARCHIEVEDFLG DELETEDFLG LENGTH))
(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 (QUOTE (560 561)))
(\I.TEDITFORMATTING 562)
(\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 561))
(RPAQQ \I.TEDITFORMATTING 562)
(RPAQQ \I.END 65535)
(CONSTANTS (\I.POSTMARK 8)
(\I.SENDER 16)
(\I.RETURNTO 24)
(\I.RECIPIENTS 32)
(\I.TEXT 520)
(\I.OLDTEDITFORMATTING (QUOTE (560 561)))
(\I.TEDITFORMATTING 562)
(\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 (SOURCE)
LAFITEDECLS)
(FILESLOAD (LOADCOMP)
GRAPEVINE PUP BSP)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(FILESLOAD GRAPEVINE)
)
(PUTPROPS MAILCLIENT COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (4715 9789 (GV.STARTSEND 4725 . 5672) (GV.ADDRECIPIENT 5674 . 5864) (GV.CHECKVALIDITY
5866 . 6065) (GV.STARTITEM 6067 . 6389) (GV.ADDTOITEM 6391 . 9266) (GV.SEND 9268 . 9442) (MS.EXPAND
9444 . 9787)) (9819 14103 (MS.SENDOPERATION 9829 . 11048) (\FINDMAILSERVER 11050 . 11503) (
\MAILSERVERSOCKETS 11505 . 11985) (\RECEIVEACK 11987 . 12276) (\RESPTOCHECKVAL 12278 . 13132) (
\RESPTOEXPAND 13134 . 13665) (\RESPTOSTARTSEND 13667 . 14101)) (14605 18777 (GV.PORTFROMNAME 14615 .
14808) (GV.POLLNEWMAIL 14810 . 15962) (GV.OPENMAILBOX 15964 . 17375) (GV.NEXTMESSAGE 17377 . 18016) (
GV.RETRIEVEMESSAGE 18018 . 18411) (GV.CLOSEMAILBOX 18413 . 18775)) (18977 19589 (GV.READTOC 18987 .
19178) (GV.WRITETOC 19180 . 19385) (GV.DELETEMESSAGE 19387 . 19587)) (19621 24408 (
MS.RETRIEVEOPERATION 19631 . 20275) (\CONNECTTOMAILSERVER 20277 . 21033) (\OPENMAILSERVER 21035 .
22106) (\RESPTOOPENMAILBOX 22108 . 22586) (\RESPTONEXTMESSAGE 22588 . 22792) (\RESPTORETRIEVEMESSAGE
22794 . 23022) (\RECEIVEMESSAGEITEM 23024 . 24089) (\RECEIVELONGWORD 24091 . 24406)) (24689 27534 (
GV.INIT.MAIL.USER 24699 . 26528) (GETMAILSERVEROPS 26530 . 27175) (\GV.MAILSERVERTYPE 27177 . 27532))
(27535 35602 (\GV.SENDMESSAGE 27545 . 34352) (\GV.SENDRECIPIENTS 34354 . 35600)) (35603 55242 (
\GV.SEND.PARSE 35613 . 39915) (\GV.PARSERECIPIENTS 39917 . 40341) (\GV.PARSE.ARPA.ADDRESS 40343 .
42859) (\GV.PARSERECIPIENTS1 42861 . 48993) (\GV.PARSE.SINGLE.ADDRESS 48995 . 50772) (\GV.PARSE.FAILED
50774 . 51182) (\GV.REPACKADDRESS 51184 . 52141) (\GV.COLLECTADDRESSES 52143 . 53284) (
\CHECKMESSAGEADDRESSES 53286 . 53804) (\LAFITE.CHOOSE.REPLYTO 53806 . 55240)) (55243 61077 (
GV.MAKEANSWERFORM 55253 . 59975) (GETREGISTRY 59977 . 60744) (LA.PRINTADDRESSES 60746 . 61075)))))
STOP