(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "31-Aug-88 19:14:45" {POOH/N}<POOH>VANMELLE>ERIS>LAFITE>SOURCES>MAILCLIENT;2 48250
changes to%: (FNS \LAFITE.CHOOSE.REPLYTO)
previous date%: "23-Aug-88 18:53:42" {ERIS}<LAFITE>SOURCES>MAILCLIENT.;32)
(* "
Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988 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 \RESPTOOPENMAILBOX \RESPTONEXTMESSAGE \RESPTORETRIEVEMESSAGE \RECEIVELONGWORD \CACHED.HOST.NAME) (INITVARS (GV.MAILBOX.TIMEOUT 12000) (*GV-SHOW-POSTMARK*) (\CACHED.HOST.NAMES)) (ADDVARS (\SYSTEMCACHEVARS \CACHED.HOST.NAMES)) (GLOBALVARS GV.MAILBOX.TIMEOUT \CACHED.HOST.NAMES)) (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.PARSERECIPIENTS1 \GV.FIND.NON.SPACE \GV.PARSE.SIMPLE.RECIPIENT \GV.EXTRACT.FIELD \GV.HANDLE.DL \GV.PARSE.FAILED \LAFITE.CHOOSE.REPLYTO) (FNS \GV.MESSAGE.P \GV.MESSAGE.FROM.SELF.P GV.MAKEANSWERFORM \GV.DIFFERENCE) (ADDVARS (MAILSERVERTYPES) (LAFITEDLDIRECTORIES) (LAFITE.PERSONAL.VARS LAFITE.GV.FROM.FIELD)) (INITVARS (ARPANETGATEWAY.REGISTRY (QUOTE AG)) (LAFITEREPLYTOMENU NIL) (LAFITEDL.EXT "DL") (LAFITE.GV.FROM.FIELD)) (ADDVARS (LISPSUPPORT (GV "LispSupport.pa")) (LAFITESUPPORT (GV "LafiteSupport.pa")) (TEDITSUPPORT (GV "TEditSupport.pa")) (LAFITEMENUVARS LAFITEREPLYTOMENU)) (VARS LAFITEREPLYTOMENUITEMS) (PROP FILEDEF MAINTAIN)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (RECORDS MAILPORT GVMAILPARSE) (COMS * MAILCLIENTCONSTANTCOMS) (P (CL:PROCLAIM (QUOTE (GLOBAL MAILSERVERTYPES ARPANETGATEWAY.REGISTRY LAFITEREPLYTOMENUITEMS LAFITEREPLYTOMENU))) (CL:PROCLAIM (QUOTE (CL:SPECIAL *MSGOUTSTREAM*)))) (FILES (SOURCE) LAFITEDECLS) (FILES (LOADCOMP) GRAPEVINE PUP BSP) (LOCALVARS . T)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (CL:PROCLAIM (QUOTE (GLOBAL LAFITE.GV.FROM.FIELD LAFITEDL.EXT LAFITEDLDIRECTORIES))) (CL:PROCLAIM (QUOTE (CL:SPECIAL *GV-SHOW-POSTMARK*)))) (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") (LET (SENDINGSOCKET STARTSENDRESULT) (COND ((NOT (SETQ SENDINGSOCKET (\FINDMAILSERVER))) (* ; "Can't find a maildrop at all") NIL) ((SETQ STARTSENDRESULT (MS.SENDOPERATION \OP.STARTSEND SENDINGSOCKET (LIST (\CHECKNAME SENDER) (\CHECKKEY KEY) (\CHECKNAME RETURN) (LIST \3BYTEKLUDGEKEY (COND (VALIDATEFLG 1) (T 0)))) (FUNCTION \RESPTOSTARTSEND))) SENDINGSOCKET) (T (* ; "print the reason for failure") (AND NIL (printout PROMPTWINDOW "Couldn't start sending the message - reason: " STARTSENDRESULT T)) 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 (> %#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 (- %#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) (* ; "Edited 3-Sep-87 18:09 by bvm:") (* ;;; "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)) (CL:FUNCALL 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") (LET (RESULT) (SETQ RESULT (MS.RETRIEVEOPERATION \OP.NEXTMESSAGE MAILBOX NIL (FUNCTION \RESPTONEXTMESSAGE))) (AND (fetch ANOTHERMESSAGE? of RESULT) (LIST (QUOTE DELETED) (fetch DELETED? of RESULT) (QUOTE ARCHIVED) (fetch ARCHIVED? of RESULT)))))
)
(GV.RETRIEVEMESSAGE
(LAMBDA (MAILBOX MSGOUTFILE) (* ; "Edited 6-May-88 16:32 by bvm") (LET ((*MSGOUTSTREAM* (GETSTREAM MSGOUTFILE (QUOTE OUTPUT)))) (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) (* ; "Edited 3-Sep-87 18:09 by bvm:") (* ;;; "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 (CL:FUNCALL 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!)))))
)
(\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) (* ; "Edited 3-Jun-88 18:32 by bvm") (until (\EOFP INSTREAM) bind TYPE BYTELEN GVHOST TIME SENDER ADDEDLENGTH do (* ;; "Read an item. Ignore the ones not of type text or tedit formatting") (SETQ TYPE (\WIN INSTREAM)) (* ; "Item type") (SETQ BYTELEN (\RECEIVELONGWORD INSTREAM)) (* ; "Number of bytes long it is") (SELECTC TYPE (\I.TEXT (* ; "The text body") (if SENDER then (* ; "Print a postmark first") (SETQ ADDEDLENGTH (GETFILEPTR *MSGOUTSTREAM*)) (PRINTOUT *MSGOUTSTREAM* "GV-Info: " SENDER " at " (GDATE (ALTO.TO.LISP.DATE TIME)) " from " (\CACHED.HOST.NAME GVHOST) T) (SETQ ADDEDLENGTH (- (GETFILEPTR *MSGOUTSTREAM*) ADDEDLENGTH)) (* ; "May have to account for this later") (SETQ SENDER NIL)) (to BYTELEN do (* ; "Use \OUTCHAR to account for eol conventions") (\OUTCHAR *MSGOUTSTREAM* (BIN INSTREAM)))) ((CONS \I.TEDITFORMATTING (MKLIST \I.OLDTEDITFORMATTING)) (* ; "Various TEdit formatting") (if ADDEDLENGTH then (* ; "We prepended some text, so have to munge the formatting instead of copying it straight") (LET ((BUFFER (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH)))) (COPYBYTES INSTREAM BUFFER BYTELEN) (LA.ADJUST.FORMATTING BUFFER *MSGOUTSTREAM* ADDEDLENGTH)) else (* ; "Just append to the text--the two together make a valid textstream") (COPYBYTES INSTREAM *MSGOUTSTREAM* BYTELEN))) (OR (AND *GV-SHOW-POSTMARK* (SELECTC TYPE (\I.POSTMARK (* ; "6 bytes: pupaddr, timelo, timehi") (SETQ GVHOST (\WIN INSTREAM)) (SETQ TIME (NCREATE (QUOTE FIXP))) (replace LOWORD of TIME with (\WIN INSTREAM)) (replace HIWORD of TIME with (\WIN INSTREAM)) T) (\I.SENDER (SETQ SENDER (\RECEIVESTRING INSTREAM (\WIN INSTREAM)))) NIL)) (to BYTELEN do (BIN INSTREAM)))) (COND ((ODDP BYTELEN) (* ; "Eat padding byte") (BIN INSTREAM))) finally (BSPGETMARK INSTREAM)))
)
(\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))))
)
(\CACHED.HOST.NAME
(LAMBDA (HOST#) (* ; "Edited 6-May-88 17:25 by bvm") (* ;; "Return a name for HOST#. Use cache to avoid recomputation") (OR (CDR (ASSOC HOST# \CACHED.HOST.NAMES)) (CDAR (push \CACHED.HOST.NAMES (CONS HOST# (ETHERHOSTNAME HOST# T))))))
)
)
(RPAQ? GV.MAILBOX.TIMEOUT 12000)
(RPAQ? *GV-SHOW-POSTMARK*)
(RPAQ? \CACHED.HOST.NAMES)
(ADDTOVAR \SYSTEMCACHEVARS \CACHED.HOST.NAMES)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS GV.MAILBOX.TIMEOUT \CACHED.HOST.NAMES)
)
(* ; "LAFITEMODE GV")
(ADDTOVAR LAFITEMODELST (GV 2 \GV.SEND.PARSE \GV.SENDMESSAGE GV.MAKEANSWERFORM GV.INIT.MAIL.USER \GV.MESSAGE.P \GV.MESSAGE.FROM.SELF.P) (GRAPEVINE . GV))
(DEFINEQ
(GV.INIT.MAIL.USER
(LAMBDA NIL (* ; "Edited 6-Jun-88 19:27 by bvm") (LET* ((GVUSERNAME (LAFITE.USER.NAME.FROM.LOGIN T)) (FULLNAME (CONCAT (CAR GVUSERNAME) "." (CDR GVUSERNAME))) PASS MAILSERVERS AUTHENTICATED?) (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?) ".") NIL) ((NULL (SETQ MAILSERVERS (CDR (GV.EXPAND GVUSERNAME)))) (printout PROMPTWINDOW T "There are no mail servers for user " FULLNAME) NIL) (T (create LAFITEMODEDATA FULLUSERNAME ← FULLNAME UNPACKEDUSERNAME ← GVUSERNAME CREDENTIALS ← PASS SHORTUSERNAME ← FULLNAME FROMFIELD ← (AND LAFITE.GV.FROM.FIELD (LET ((PARSE (\GV.PARSERECIPIENTS1 LAFITE.GV.FROM.FIELD NIL T))) (* ;; "If the user's variable parses correctly into the authenticated user, then take it") (if (AND PARSE (NULL (CDR PARSE)) (STRING-EQUAL (CAAR PARSE) (CAR GVUSERNAME)) (STRING-EQUAL (CDAR PARSE) (CDR GVUSERNAME))) then LAFITE.GV.FROM.FIELD else (CL:FORMAT PROMPTWINDOW "~%%Can't use GV From field %"~A%" because it does not parse to current user %"~A%"" LAFITE.GV.FROM.FIELD FULLNAME) NIL))) MAILSERVERS ← (for MAILSERVER in MAILSERVERS bind SERVEROPS SERVERPORT SERVERDEF when (COND ((NULL (SETQ SERVEROPS (GETMAILSERVEROPS MAILSERVER))) NIL) ((NULL (SETQ SERVERPORT (CL:FUNCALL (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))))))
)
(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) (* ; "Edited 18-Jul-88 12:35 by bvm") (* ;;; "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) (SENDER (fetch (LAFITEMODEDATA FULLUSERNAME) of *LAFITE-MODE-DATA*)) (UNPACKEDSENDER (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of *LAFITE-MODE-DATA*)) DATELEN SENDINGSOCKET RECIPIENTSCHECK SENDRESULT SENDERFIELD ABORTMENU) (COND ((NOT (TYPENAMEP MSG (QUOTE STREAM))) (RETURN (\ILLEGAL.ARG MSG)))) (SETQ FORMATTING (SELECTQ FORMATTING ((MULTIMEDIA TEDIT) (* ; "Send with TEdit formatting, assuming there is any") (AND (TEDIT.FORMATTEDFILEP MSG) T)) (TEXT NIL) (\ILLEGAL.ARG FORMATTING))) (COND (PWINDOW (CLEARW PWINDOW) (CL:FORMAT PWINDOW "Delivering ~:[~;formatted ~]to ~D recipient~:P" FORMATTING (LENGTH RECIPIENTS)))) (SETQ SENDERFIELD (COND (FROMFIELD (* ; "Test for valid From field. We waited til now to do this so we didn't hold up start of delivery.") (if (for ADDR in FROMFIELD bind REG unless (STRPOS "@" (CAR ADDR)) do (* ; "assume arpa addresses are valid") (if (NLISTP (GV.EXPAND (if (EQ (SETQ REG (CDR ADDR)) (QUOTE NOREGISTRY)) then (* ; "The address had no registry. We do it this odd way so that we can distinguish %"Fred%" from %"Fred.PA%" in the test below.") (CONS (CAR ADDR) (SETQ REG (CDR UNPACKEDSENDER))) else ADDR))) then (COND (PWINDOW (CLEARW PWINDOW) (CL:FORMAT PWINDOW "From field not valid address: ~A" (CONCAT (CAR ADDR) "." REG)))) (RETURN T))) then (RETURN NIL)) (if (AND (NULL (CDR FROMFIELD)) (STRING-EQUAL (CONCAT (CAAR FROMFIELD) "." (CDAR FROMFIELD)) SENDERFIELD)) then (* ; "From field is just a fancy way of writing the real from field, so adding a Sender field would be redundant") NIL else (CONCAT "Sender: " SENDER LAFITEEOL))) (T (CONCAT "From: " (OR (fetch (LAFITEMODEDATA FROMFIELD) of *LAFITE-MODE-DATA*) SENDER) LAFITEEOL)))) (COND (FORMATTING (TEDIT.INSERT MSG DATEFIELD 1 NIL T) (SETQ DATELEN (NCHARS DATEFIELD)) (CL:WHEN SENDERFIELD (TEDIT.INSERT MSG SENDERFIELD (ADD1 DATELEN) NIL T)) (* ; "Do tedit conversion now, before we have the bsp stream tied up") (SETQ MSG (PROG1 (COERCETEXTOBJ MSG (QUOTE SPLIT)) (TEDIT.DELETE MSG 1 (if SENDERFIELD then (+ DATELEN (NCHARS SENDERFIELD)) else DATELEN)))) (SETQ FORMATTING (CDR MSG)) (SETQ MSG (CAR MSG)) (if (NOT (NULL FORMATTING)) then (* ; "There really was formatting. I hope we filtered out unformatted msg earlier, but if not don't break now") (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 ((> (+ (GETFILEINFO MSG (QUOTE LENGTH)) (GETFILEINFO FORMATTING (QUOTE LENGTH))) (- 99999 24)) (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW "Message too long to send formatted. Either break it up or send it as plain text.")))))) ((AND (TEXTSTREAMP MSG) (TEDIT.FORMATTEDFILEP MSG)) (* ; "Message has formatting, but caller asked to send it as plain text. Carefully coerce it, since TEDIT ns chars and image objects don't pass thru COPYBYTES very well") (SETQ MSG (LAFITE.MAKE.PLAIN.TEXTSTREAM MSG)))) STARTSEND (as I to 3 until (SETQ SENDINGSOCKET (GV.STARTSEND UNPACKEDSENDER (fetch (LAFITEMODEDATA CREDENTIALS) of *LAFITE-MODE-DATA*) UNPACKEDSENDER 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) (AND SENDERFIELD (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 ((> (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) (* ; "Edited 5-May-88 13:06 by bvm") (PROG ((REGISTRY (CDR (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of *LAFITE-MODE-DATA*))) 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) (QUOTE NOREGISTRY) 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 NIL)) ((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)))) (RETURN (create GVMAILPARSE GVPSUBJECT ← SUBJECT GVPFROM ← FROMFIELD GVPFORMAT ← SENDINGFORMAT GVPRECIPIENTS ← RECIPIENTS))))
)
(\GV.PARSERECIPIENTS
(LAMBDA (FIELD REGISTRY INTERNALFLG EDITWINDOW) (* ; "Edited 9-Sep-87 16:27 by bvm:") (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 (CL:REMOVE-DUPLICATES FIELD :TEST (QUOTE STRING-EQUAL)))))
)
(\GV.PARSERECIPIENTS1
(LAMBDA (LINE REGISTRY INTERNALFLG EDITWINDOW RECURSIVE-P) (* ; "Edited 13-Jun-88 12:21 by bvm") (* ;;; "INTERNALFLG = T means produce addresses to give Grapevine; NIL means give human-readable addresses") (PROG ((I 0) NC NOPEN CH ADDRESSES ADDR FAILURE OPEN CLOSE DOT ATSIGN START COLON COMSTART COMMENTS PRETTY DLNAME) (COND ((NULL LINE) (RETURN NIL))) (SETQ NC (NCHARS LINE)) NEXTADDR (if (>= I NC) then (* ; "done") (if COLON then (* ; "Slight missing semi-colon") (SETQ FAILURE #\:) (GO FAIL)) (RETURN (REVERSE ADDRESSES))) (CASE (SETQ CH (CL:CHAR LINE I)) ((#\Space #\Tab #\Newline) (* ; "Ignore leading whitespace") (add I 1) (GO NEXTADDR))) (SETQ START I) (SETQ OPEN (SETQ CLOSE (SETQ DOT (SETQ ATSIGN (SETQ COMMENTS NIL))))) THISCHAR (CASE CH (#\" (GO INQUOTE)) (#\( (GO INCOMMENT)) (#\[ (GO INDOMAIN)) ((#\) #\]) (* ; "Unbalanced stuff") (SETQ FAILURE CH) (GO FAIL)) (#\< (* ; "Start of address spec") (if OPEN then (SETQ FAILURE #\<) (GO FAIL) else (SETQ OPEN I))) (#\> (* ; "End of address spec") (if OPEN then (SETQ CLOSE I) else (SETQ FAILURE #\>) (GO FAIL))) (#\. (if (NOT CLOSE) then (* ; "Note placement of periods. Ignore if outside <> address.") (SETQ DOT I))) (#\@ (if (NOT CLOSE) then (* ; "Note arpa address separator") (SETQ ATSIGN I) (SETQ DOT NIL))) (#\: (if (OR OPEN ATSIGN COLON) then (SETQ FAILURE "Invalid use of colon") (GO FAIL) else (if (EQ (\GV.FIND.NON.SPACE LINE (+ I 1) NC) #\;) then (* ; "DL in the form %"dlname:;%" -- get recipients from file") (SETQ ADDR (\GV.HANDLE.DL (SETQ DLNAME (\GV.EXTRACT.FIELD LINE START I)) INTERNALFLG EDITWINDOW)) (if (EQ (CAR ADDR) :ERROR) then (SETQ FAILURE (CADR ADDR)) (GO FAIL) else (SETQ ADDRESSES (NCONC ADDR ADDRESSES)) (SETQ DLNAME NIL)) else (* ; "Random phrase naming the group, followed by the addresses--just parse them as they come along, and note that we expect a semi-colon at some point.")) (SETQ COLON I) (add I 1) (GO NEXTADDR))) ((NIL #\, #\;) (* ; "end of address") (if (CASE CH (#\; (if (NOT COLON) then (SETQ FAILURE #\;) else (CASE (\GV.FIND.NON.SPACE LINE (+ I 1) NC) ((NIL #\,) (* ; "good--semi is at end of address. Consider it eaten") (SETQ COLON NIL)) (T (* ; "Stuff after the semicolon is bad syntax") (SETQ FAILURE "Semi-colon must be at end of group specification"))))) ((NIL) (* ; "end of everything, check that there's no outstanding colon") (if COLON then (SETQ FAILURE #\:)))) then (* ; "Problem with this semi-colon") (GO FAIL)) (if (NEQ START I) then (* ; "there is a name") (if (NOT OPEN) then (* ; "simple address") (SETQ ADDR (\GV.PARSE.SIMPLE.RECIPIENT LINE START I DOT ATSIGN COMMENTS REGISTRY INTERNALFLG)) (if (EQ (CAR ADDR) :ERROR) then (SETQ FAILURE (CADR ADDR)) (GO FAIL)) elseif (NOT CLOSE) then (SETQ FAILURE #\<) (GO FAIL) else (* ; "real address is inside the <>") (SETQ ADDR (\GV.PARSE.SIMPLE.RECIPIENT LINE (+ OPEN 1) CLOSE DOT ATSIGN COMMENTS REGISTRY INTERNALFLG)) (if (EQ (CAR ADDR) :ERROR) then (SETQ FAILURE (CADR ADDR)) (GO FAIL)) (CASE INTERNALFLG ((NIL :BOTH) (* ; "Want pretty address--stick the reparsed real address inside the template") (SETQ PRETTY (CL:FORMAT NIL "~@[~A ~]<~A>~@[ ~A~]" (\GV.EXTRACT.FIELD LINE START OPEN) (if INTERNALFLG then (CAR ADDR) else ADDR) (\GV.EXTRACT.FIELD LINE (+ CLOSE 1) I))) (SETQ ADDR (if INTERNALFLG then (* ; "Want (pretty . internal)") (CONS PRETTY (CDR ADDR)) else PRETTY))))) (push ADDRESSES ADDR)) (add I 1) (GO NEXTADDR))) NEXT-I (SETQ CH (AND (< (add I 1) NC) (CL:CHAR LINE I))) (GO THISCHAR) INQUOTE (* ;; "Parse a quoted string--skip to next quote") (while (< (add I 1) NC) do (CASE (CL:CHAR LINE I) (#\" (* ; "end of quoted text") (GO NEXT-I)) (#\\ (* ; "quotes next char") (add I 1)))) (* ;; "If we get here, we have an unbalanced quote") (SETQ FAILURE #\") (GO FAIL) INCOMMENT (* ;; "Parse a comment in parens. Parentheses may be nested. Add to set of comments") (SETQ COMSTART I) (SETQ NOPEN 1) (while (< (add I 1) NC) do (CASE (CL:CHAR LINE I) (#\) (if (EQ (SETQ NOPEN (- NOPEN 1)) 0) then (* ; "end of comment--parens are now matched") (if INTERNALFLG then (* ; "We will need to know how to strip comments") (push COMMENTS (LIST COMSTART (+ I 1)))) (GO NEXT-I))) (#\( (* ; "nested comment") (add NOPEN 1)) (#\\ (* ; "quotes next char") (add I 1)))) (* ;; "If we get here, we have an unbalanced paren") (SETQ FAILURE #\() (GO FAIL) INDOMAIN (* ;; "Parse a domain literal--string in square brackets. These may not be nested.") (while (< (add I 1) NC) do (CASE (CL:CHAR LINE I) (#\] (* ; "end of literal") (GO NEXT-I)) (#\[ (* ; "unmatched") (RETURN)) (#\\ (* ; "quotes next char") (add I 1)))) (* ;; "If we get here, we have an unbalanced bracket") (SETQ FAILURE #\[) (GO FAIL) FAIL (RETURN (COND (RECURSIVE-P (LIST :ERROR FAILURE)) ((NOT EDITWINDOW) (* ; "No interaction, just show failure by returning (NIL)") (LIST NIL)) ((CL:CHARACTERP FAILURE) (\SENDMESSAGEFAIL EDITWINDOW (CL:FORMAT NIL "Error~@[ in ~A~]: " DLNAME) (CASE FAILURE (#\" "Unmatched quotation mark") (#\: "Incorrect group syntax--colon without terminating semi-colon") (T (CL:FORMAT NIL "Unmatched %"~C%"" FAILURE))))) (DLNAME (\SENDMESSAGEFAIL EDITWINDOW (CONCAT "In " DLNAME ": ") FAILURE)) (T (\SENDMESSAGEFAIL EDITWINDOW FAILURE))))))
)
(\GV.FIND.NON.SPACE
(LAMBDA (STR START END) (* ; "Edited 10-Jun-88 17:11 by bvm") (* ;; "returns the next non-white-space char in str from position start to end.") (bind CH do (if (>= START END) then (RETURN NIL) else (CASE (SETQ CH (CL:CHAR STR START)) ((#\Space #\Tab #\Newline) (add START 1)) (T (RETURN CH))))))
)
(\GV.PARSE.SIMPLE.RECIPIENT
(LAMBDA (FIELD START END DOT ATSIGN COMMENTS REGISTRY INTERNALFLG) (* ; "Edited 10-Jun-88 17:11 by bvm") (* ;;; "Parses a single ADDRESS, a list, and returns a proper address as a string, or if INTERNALFLG, in the form Grapevine likes") (COND ((EQ INTERNALFLG :BOTH) (LET ((INTERNAL (\GV.PARSE.SIMPLE.RECIPIENT FIELD START END DOT ATSIGN COMMENTS REGISTRY T))) (AND INTERNAL (CONS (\GV.PARSE.SIMPLE.RECIPIENT FIELD START END DOT ATSIGN COMMENTS REGISTRY NIL) INTERNAL)))) (INTERNALFLG (LET (TMP) (if (NULL DOT) then (SETQ TMP (\GV.EXTRACT.FIELD FIELD START END COMMENTS)) (if (NULL ATSIGN) then (* ; "use default registry") (if REGISTRY then (CONS TMP REGISTRY) else (LIST :ERROR (CONCAT "No registry given for addressee " TMP))) elseif (OR (EQ (CL:CHAR TMP 0) #\@) (EQ (CL:CHAR TMP (- (NCHARS TMP) 1)) #\@)) then (* ; "@ but null name or domain?") (\GV.PARSE.FAILED TMP) else (* ; "Assume name is otherwise good, use default arpa registry") (CONS TMP ARPANETGATEWAY.REGISTRY)) else (* ; "Take the domain/registry that's there") (SETQ TMP (CONS (\GV.EXTRACT.FIELD FIELD START DOT COMMENTS) (\GV.EXTRACT.FIELD FIELD (+ DOT 1) END COMMENTS))) (if (NULL (CDR TMP)) then (* ; "no domain?") (\GV.PARSE.FAILED (CONCAT (CAR TMP) ".")) else (RPLACD TMP (MKATOM (U-CASE (CDR TMP)))) (* ; "Grapevine registry must be atom, sigh.") TMP)))) ((OR ATSIGN DOT) (* ; "have an ARPA Internet address, or Grapevine address with registry--nothing to add to make user-sensible address") (if (NULL (\GV.FIND.NON.SPACE FIELD (OR ATSIGN DOT) END)) then (* ; "no domain") (\GV.PARSE.FAILED (\GV.EXTRACT.FIELD FIELD START END)) else (\GV.EXTRACT.FIELD FIELD START END))) (REGISTRY (* ; "Address without registry, supply default") (CONCAT (\GV.EXTRACT.FIELD FIELD START END) "." REGISTRY)) (T (* ; "Not even a default registry? Punt") (\GV.EXTRACT.FIELD FIELD START END))))
)
(\GV.EXTRACT.FIELD
(LAMBDA (STR START END COMMENTS) (* ; "Edited 10-Jun-88 17:11 by bvm") (if COMMENTS then (LET (TMP PIECES) (SETQ PIECES (for PAIR in (if (CDR COMMENTS) then (REVERSE COMMENTS) else COMMENTS) when (AND (<= START (CAR PAIR)) (< (CAR PAIR) END) (PROG1 (SETQ TMP (\GV.EXTRACT.FIELD STR START (CAR PAIR))) (SETQ START (CADR PAIR)))) join (LIST " " TMP))) (if (SETQ TMP (\GV.EXTRACT.FIELD STR START END)) then (SETQ PIECES (NCONC PIECES (LIST " " TMP)))) (CONCATLIST (CDR PIECES))) else (* ; "trim white space from edges") (while (AND (< START END) (CASE (CL:CHAR STR START) ((#\Space #\Tab #\Newline) T))) do (add START 1)) (while (AND (< START END) (CASE (CL:CHAR STR (- END 1)) ((#\Space #\Tab #\Newline) T))) do (add END -1)) (AND (< START END) (CL:SUBSEQ STR START END))))
)
(\GV.HANDLE.DL
(LAMBDA (DL INTERNALFLG EDITWINDOW) (* ; "Edited 13-Jun-88 14:17 by bvm") (CASE INTERNALFLG ((NIL :BOTH) (* ; "Don't want the actual addresses, just something to stick in a header. We assume user of :BOTH is answer, or something that is mainly concerned with textual presentation to user.") (LET ((STR (CONCAT DL ":;"))) (LIST (if INTERNALFLG then (* ; "(pretty . internal)") (LIST* STR STR NIL) else STR)))) (T (LET ((FILENAME (PACKFILENAME.STRING (QUOTE BODY) (if (EQL (CL:CHAR DL 0) #\") then (* ; "quoted file name, take off the quotes first") (CL:SUBSEQ DL 1 (- (CL:LENGTH DL) 1)) else DL) (QUOTE EXTENSION) LAFITEDL.EXT)) STREAM) (if (NULL (SETQ FILENAME (if (OR (UNPACKFILENAME.STRING FILENAME (QUOTE HOST)) (UNPACKFILENAME.STRING FILENAME (QUOTE DIRECTORY))) then (INFILEP FILENAME) else (* ; "Search default directories") (FINDFILE FILENAME T (CONS LAFITEDEFAULTHOST&DIR LAFITEDLDIRECTORIES))))) then (LIST :ERROR "Can't find file by this name") elseif (NULL (SETQ STREAM (CAR (NLSETQ (OPENTEXTSTREAM (MKATOM FILENAME)))))) then (LIST :ERROR (CONCAT "Can't open " DL)) else (RESETLST (RESETSAVE NIL (LIST (QUOTE CLOSEF) STREAM)) (* ; "I hope this closes the file. We used OPENTEXTSTREAM instead of OPEN so that file can contain tedit formatting.") (bind LINE SOME RESULT while (SETQ LINE (CL:READ-LINE STREAM NIL NIL)) when (SETQ SOME (\GV.PARSERECIPIENTS1 LINE NIL INTERNALFLG EDITWINDOW T)) do (* ; "Note that we parse with respect to NO registry--require that the file contain all complete addresses") (if (EQ (CAR SOME) :ERROR) then (RETURN SOME) else (SETQ RESULT (NCONC SOME RESULT))) finally (* ; "Whole file parsed ok, so return the result") (RETURN RESULT))))))))
)
(\GV.PARSE.FAILED
(LAMBDA (ADDRESS) (* ; "Edited 13-Oct-87 14:17 by bvm:") (LIST :ERROR (CONCAT "Bad addressee " ADDRESS)))
)
(\LAFITE.CHOOSE.REPLYTO
(LAMBDA (TEXTSTREAM HEADEREOF FROMFIELD EDITORWINDOW) (* ; "Edited 30-Aug-88 14:39 by bvm") (* ;;; "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 (OR LAFITEREPLYTOMENU (SETQ LAFITEREPLYTOMENU (\LAFITE.CREATE.MENU LAFITEREPLYTOMENUITEMS "Include a Reply-to field?" T))) "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.MESSAGE.P
(LAMBDA (MSG) (* ; "Edited 6-May-88 13:58 by bvm") (* ;; "Test whether the specified message is a GV message. We test for sender having gv format. This may fail for msgs with malformed from, but that's too bad.") (LET* ((SENDER (fetch (LAFITEMSG FROM) of MSG)) (DOT (STRPOS "." SENDER))) (if (NULL DOT) then (* ; "No registry") NIL elseif (NULL (STRPOS ":" SENDER)) then (* ; "Registry and no colon, so believe it. This is based on the assumption that all grapevine users are internal Xerox with only NS as competition.") T else (* ; "Subject it to the rigorous parser.") (NOT (FMEMB NIL (\GV.PARSERECIPIENTS1 SENDER))))))
)
(\GV.MESSAGE.FROM.SELF.P
(LAMBDA (MSG) (* ; "Edited 6-May-88 14:36 by bvm") (* ;; "True if message is from current user") (LET ((SENDER (fetch (LAFITEMSG FROM) of MSG)) (ME (fetch (LAFITEMODEDATA FULLUSERNAME) of *LAFITE-MODE-DATA*)) HIT) (AND (SETQ HIT (STRPOS ME SENDER NIL NIL NIL NIL UPPERCASEARRAY)) (if (EQ (SETQ HIT (SUB1 HIT)) 0) then (* ; "Matched at start--is the length right?") (EQ (NCHARS ME) (NCHARS SENDER)) elseif (EQ (CL:CHAR SENDER (SUB1 HIT)) #\<) then (* ; "Also recognize %"name <realname>%"") (AND (< (add HIT (NCHARS ME)) (NCHARS SENDER)) (EQ (CL:CHAR SENDER HIT) #\>))))))
)
(GV.MAKEANSWERFORM
(LAMBDA (MSGDESCRIPTORS MAILFOLDER) (* ; "Edited 10-Jun-88 17:27 by bvm") (LET ((MSGFIELDS (\LAFITE.PARSE.MESSAGE MAILFOLDER (OR (CAR (LISTP MSGDESCRIPTORS)) MSGDESCRIPTORS))) SUBJECT FROM DATE SENDER REPLYTO TO CC ORIGINALREGISTRY OLDFROM NEWTO NEWCC) (* ; "get the fields from the file") (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. Need to find the sender's registry in order to get the registry defaults correct for its recipients.") (COND (SENDER (* ; "Sender is a mail address, and has the official registry") (SETQ OLDFROM (\GV.PARSERECIPIENTS SENDER NIL :BOTH)) (* ; "Elements are of the form (prettyname gvname . registry)") (if FROM then (* ; "Now that we have a source of official registry (we hope), parse the From field with reference to it.") (SETQ OLDFROM (\GV.PARSERECIPIENTS FROM (PROGN (* ; "Return first element that has a registry") (CL:SOME (QUOTE CDDR) OLDFROM)) :BOTH)))) (FROM (* ; "Have to parse the From field before we can get its registry") (SETQ OLDFROM (\GV.PARSERECIPIENTS FROM NIL :BOTH)))) (if (NULL OLDFROM) then (LAB.PROMPTPRINT MAILFOLDER T "Warning: message has no FROM field") else (SETQ ORIGINALREGISTRY (CL:SOME (QUOTE CDDR) OLDFROM)) (* ; "Choose first element that has a registry")) (AND TO (SETQ TO (\GV.PARSERECIPIENTS TO ORIGINALREGISTRY :BOTH))) (AND CC (SETQ CC (\GV.PARSERECIPIENTS CC ORIGINALREGISTRY :BOTH))) (SETQ NEWTO (OR (AND REPLYTO (SETQ REPLYTO (\GV.PARSERECIPIENTS REPLYTO ORIGINALREGISTRY :BOTH))) OLDFROM)) (SETQ NEWCC (\GV.DIFFERENCE (COND (REPLYTO (* ; "Reply goes only to this address, so the only cc is to self") (LIST (CONS (fetch (LAFITEMODEDATA FULLUSERNAME) of *LAFITE-MODE-DATA*) (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of *LAFITE-MODE-DATA*)))) (T (* ; "By default CC everyone who received the original message and to whom we are not directly replying already") (APPEND TO (\GV.DIFFERENCE CC TO)))) NEWTO)) (LAFITE.FILL.IN.ANSWER.FORM SUBJECT (if (AND (OR (NULL REPLYTO) (EQUAL REPLYTO OLDFROM)) (NULL (CDR NEWCC)) (OR (NULL NEWCC) (LET ((CC1 (CDAR NEWCC)) (CC2 (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of *LAFITE-MODE-DATA*))) (AND (STRING-EQUAL (CAR CC1) (CAR CC2)) (STRING-EQUAL (CDR CC1) (CDR CC2)))))) then (* ; "Replying only to sender (and maybe self), so just say %"your%" instead of %"Joe Bob Smith <JBSmith.pa>'s%"") NIL else FROM) DATE NEWTO NEWCC (FUNCTION (LAMBDA (NAMES STREAM) (* ;; "Print all the pretty names") (LA.PRINT.COMMA.LIST (MAPCAR NAMES (FUNCTION CAR)) STREAM))))))
)
(\GV.DIFFERENCE
(LAMBDA (A B) (* ; "Edited 6-Jun-88 13:49 by bvm") (* ;; "Return all the names in A that aren't in B. Names are of the form (prettyname gvname . registry). We can't eliminate all gvname duplicates, since sometimes the prettyname contains more information (yecch).") (for TRIPLE in A collect TRIPLE unless (for OTHER in B bind (GVNAME ← (CADR TRIPLE)) thereis (AND (STRING-EQUAL (CADR OTHER) GVNAME) (OR (PROGN (* ; "Identical pretty names") (STRING-EQUAL (CAR OTHER) (CAR TRIPLE))) (PROGN (* ; "Identical gv names, and TRIPLE has no interesting additional info, like a people name") (AND (STRING-EQUAL (CDDR OTHER) (CDDR TRIPLE)) (STRING-EQUAL (CAR TRIPLE) (CONCAT (CADR TRIPLE) "." (CDDR TRIPLE))))))))))
)
)
(ADDTOVAR MAILSERVERTYPES)
(ADDTOVAR LAFITEDLDIRECTORIES)
(ADDTOVAR LAFITE.PERSONAL.VARS LAFITE.GV.FROM.FIELD)
(RPAQ? ARPANETGATEWAY.REGISTRY (QUOTE AG))
(RPAQ? LAFITEREPLYTOMENU NIL)
(RPAQ? LAFITEDL.EXT "DL")
(RPAQ? LAFITE.GV.FROM.FIELD)
(ADDTOVAR LISPSUPPORT (GV "LispSupport.pa"))
(ADDTOVAR LAFITESUPPORT (GV "LafiteSupport.pa"))
(ADDTOVAR TEDITSUPPORT (GV "TEditSupport.pa"))
(ADDTOVAR LAFITEMENUVARS LAFITEREPLYTOMENU)
(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")))
(PUTPROPS MAINTAIN FILEDEF MAINTAIN)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RECORD MAILPORT (HOST# . SOCKET#))
(RECORD GVMAILPARSE (GVPSUBJECT GVPFROM GVPFORMAT . GVPRECIPIENTS))
)
(RPAQQ MAILCLIENTCONSTANTCOMS ((COMS (* ; "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))) (COMS (* ; "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))) (COMS (* ; "return codes from 'start to send a message'") (CONSTANTS (\RC.SENDSTARTED 0) (\RC.PASSWORDINVALID 1) (\RC.SENDERNOTREGISTERED 2) (\RC.RETURNTONOTREGISTERED 3) (\RC.COMMUNICATIONFAILURE 4))) (COMS (* ; "return codes from 'open mail box'") (CONSTANTS (\RC.NAMEISGROUP 1) (\RC.NAMEANDPASSWORDVALID 2) (\RC.NAMENOTREGISTERED 3) (\RC.COMMUNICATIONFAILURE 4) (\RC.INVALIDPASSWORD 5))) (COMS (* ; "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))
)
(CL:PROCLAIM (QUOTE (GLOBAL MAILSERVERTYPES ARPANETGATEWAY.REGISTRY LAFITEREPLYTOMENUITEMS LAFITEREPLYTOMENU)))
(CL:PROCLAIM (QUOTE (CL:SPECIAL *MSGOUTSTREAM*)))
(FILESLOAD (SOURCE) LAFITEDECLS)
(FILESLOAD (LOADCOMP) GRAPEVINE PUP BSP)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(CL:PROCLAIM (QUOTE (GLOBAL LAFITE.GV.FROM.FIELD LAFITEDL.EXT LAFITEDLDIRECTORIES)))
(CL:PROCLAIM (QUOTE (CL:SPECIAL *GV-SHOW-POSTMARK*)))
(FILESLOAD GRAPEVINE)
)
(PUTPROPS MAILCLIENT COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986 1987 1988))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (3213 6055 (GV.STARTSEND 3223 . 3901) (GV.ADDRECIPIENT 3903 . 4046) (GV.CHECKVALIDITY
4048 . 4194) (GV.STARTITEM 4196 . 4397) (GV.ADDTOITEM 4399 . 5657) (GV.SEND 5659 . 5781) (MS.EXPAND
5783 . 6053)) (6089 8568 (MS.SENDOPERATION 6099 . 6694) (\FINDMAILSERVER 6696 . 7049) (
\MAILSERVERSOCKETS 7051 . 7419) (\RECEIVEACK 7421 . 7576) (\RESPTOCHECKVAL 7578 . 7883) (\RESPTOEXPAND
7885 . 8213) (\RESPTOSTARTSEND 8215 . 8566)) (9038 11569 (GV.PORTFROMNAME 9048 . 9195) (
GV.POLLNEWMAIL 9197 . 10009) (GV.OPENMAILBOX 10011 . 10663) (GV.NEXTMESSAGE 10665 . 11043) (
GV.RETRIEVEMESSAGE 11045 . 11286) (GV.CLOSEMAILBOX 11288 . 11567)) (11734 12192 (GV.READTOC 11744 .
11883) (GV.WRITETOC 11885 . 12040) (GV.DELETEMESSAGE 12042 . 12190)) (12228 15865 (
MS.RETRIEVEOPERATION 12238 . 12698) (\CONNECTTOMAILSERVER 12700 . 13120) (\RESPTOOPENMAILBOX 13122 .
13441) (\RESPTONEXTMESSAGE 13443 . 13595) (\RESPTORETRIEVEMESSAGE 13597 . 15404) (\RECEIVELONGWORD
15406 . 15600) (\CACHED.HOST.NAME 15602 . 15863)) (16278 18689 (GV.INIT.MAIL.USER 16288 . 17986) (
GETMAILSERVEROPS 17988 . 18433) (\GV.MAILSERVERTYPE 18435 . 18687)) (18690 25151 (\GV.SENDMESSAGE
18700 . 24314) (\GV.SENDRECIPIENTS 24316 . 25149)) (25152 38391 (\GV.SEND.PARSE 25162 . 26837) (
\GV.PARSERECIPIENTS 26839 . 27228) (\GV.PARSERECIPIENTS1 27230 . 32452) (\GV.FIND.NON.SPACE 32454 .
32775) (\GV.PARSE.SIMPLE.RECIPIENT 32777 . 34658) (\GV.EXTRACT.FIELD 34660 . 35456) (\GV.HANDLE.DL
35458 . 37162) (\GV.PARSE.FAILED 37164 . 37293) (\LAFITE.CHOOSE.REPLYTO 37295 . 38389)) (38392 43156 (
\GV.MESSAGE.P 38402 . 39049) (\GV.MESSAGE.FROM.SELF.P 39051 . 39654) (GV.MAKEANSWERFORM 39656 . 42422)
(\GV.DIFFERENCE 42424 . 43154)))))
STOP