(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "12-Sep-88 12:59:41" {POOH/N}<POOH>LAFITE>SOURCES>NSMAIL;5 73295
changes to%: (FNS NS.OPENMAILBOX NS.RETRIEVEMESSAGE \NSMAIL.RETRIEVE \NSMAIL.SIGNAL.ERROR \NSMAIL.COURIER.OPEN \NSMAIL.ERRORHANDLER \NSMAIL.EOF.ON.RETRIEVE \NSMAIL.PRINT.HEADERFIELDS)
(VARS NSMAILCOMS)
previous date%: "31-Aug-88 19:17:22" {POOH/N}<POOH>VANMELLE>ERIS>LAFITE>SOURCES>NSMAIL;2)
(* "
Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT NSMAILCOMS)
(RPAQQ NSMAILCOMS ((COMS (* ; "Basic mail protocol") (COURIERPROGRAMS MAILTRANSPORT INBASKET) (FNS \NSMAIL.AUTHENTICATE \NSMAIL.LOGIN NS.FINDMAILBOXES) (ALISTS (LAFITEMODELST NS STAR))) (COMS (* ; "Retrieving mail") (FNS NS.POLLNEWMAIL NS.OPENMAILBOX \NSMAIL.CHECK NS.NEXTMESSAGE \NSMAIL.READ.ENVELOPES NS.RETRIEVEMESSAGE \NSMAIL.RETRIEVE \NSMAIL.EOF.ON.RETRIEVE \NSMAIL.READ.SERIALIZED.TREE \NSMAIL.CHECK.SERIALIZED.VERSION \NSMAIL.READ.SERIALIZED.CONTENT \NSMAIL.READ.STRING.AS.STREAM \NSMAIL.PRINT.HEADERFIELDS \NSMAIL.PRINT.NAMES) (* ; "Error handling") (FNS \NSMAIL.COURIER.OPEN \NSMAIL.ERRORHANDLER \NSMAIL.SIGNAL.ERROR) (* ; "Close/flush protocol") (FNS NS.CLOSEMAILBOX \NSMAIL.CHANGE.STATUS) (INITVARS (NSMAILDEBUGFLG) (NSMAIL.LEAVE.ATTACHMENTS)) (ADDVARS (\NSMAIL.GOOD.BODYTYPES 2 4))) (COMS (* ; "Handling attachments as a special kind of image object") (FNS \MAILOBJ.CREATE \MAILOBJ.TYPE.NAME \MAILOBJ.NS.TO.LISP.NAME \MAILOBJ.DISPLAY \MAILOBJ.GET \MAILOBJ.IMAGEBOX \MAILOBJ.PUT \MAILOBJ.INIT) (FNS \MAILOBJ.BUTTONEVENTFN \MAILOBJ.DO.COMMAND \MAILOBJ.HARDCOPY \MAILOBJ.FB \MAILOBJ.PUT.FILE \MAILOBJ.VIEW \MAILOBJ.COPY.BODY \MAILOBJ.EXPAND \MAILOBJ.COPY.CHILD \MAILOBJ.COPY.SEQUENCE \MAILOBJ.EXTRACT.TEXT \MAILOBJ.PARSE.ATTRIBUTES) (ADDVARS (FILING.TYPES (VIEWPOINT 4353) (RES 4428) (XEROX860 5120) (REFERENCE 4427))) (VARS MAILOBJ.REFERENCE.FIELD) (INITVARS (MAILOBJ.WINDOWOFFSET 16) (MAILOBJ.SKIPCHAR 0)) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MAILOBJ) (CONSTANTS \MAILOBJ.REFERENCE.LAST.FILED)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\MAILOBJ.INIT) (AND (EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSRANDOM))))) (COMS (* ; "sending mail") (FNS \NSMAIL.SEND.PARSE \NSMAIL.PARSE \NSMAIL.PARSE1 NS.REMOVEDUPLICATES \NSMAIL.SEND \NSMAIL.SEND.MESSAGE.CONTENT COURIER.WRITE.STREAM.UNSPECIFIED \NSMAIL.SEND.STREAM.AS.STRING \NSMAIL.WRITE.ATTRIBUTE \NSMAIL.FINDSERVER \NSMAIL.CHECKSERVER) (INITVARS (\NSMAIL.SERVER.CACHE) (NSMAIL.NET.HINT)) (ADDVARS (\SYSTEMCACHEVARS \NSMAIL.SERVER.CACHE)) (FNS \NSMAIL.MESSAGE.P \NSMAIL.MESSAGE.FROM.SELF.P \NSMAIL.MAKEANSWERFORM)) (COMS (* ; "Utility for handling mail attributes") (PROP COURIERDEF ENVELOPE.ITEM) (FNS \NS.READ.ENVELOPE.ITEM \NS.WRITE.ENVELOPE.ITEM) (VARS \NSMAIL.ENVELOPE.ITEM.TYPES) (DECLARE%: EVAL@COMPILE DOCOPY (VARS \NSMAIL.ATTRIBUTES))) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS NSMAILBOX NSMAILSTATE NSMAILPARSE) (CONSTANTS \NSMAIL.SOCKET \SERIALIZED.FILE.VERSION \NSMAIL.CTSTANDARD.MESSAGE \NSMAIL.TEXT.BODYTYPE \NSMAIL.EMPTY.BODYTYPE \NSMAIL.MAX.NOTE.LENGTH MAX.BULK.SEGMENT.LENGTH \NULL.CACHE.VERIFIER) (MACROS \NSMAIL.ATTRIBUTE.TYPE \NSMAIL.WRITE.ATTRIBUTE \NSMAIL.WRITE.ATTRIBUTE.MACRO) (PROP INFO \NSMAIL.ATTRIBUTE.TYPE) (GLOBALVARS NSMAIL.NET.HINT \NSMAIL.ENVELOPE.ITEM.TYPES \NSMAIL.ATTRIBUTES \NSMAIL.SERVER.CACHE NSMAILDEBUGFLG NSWIZARDFLG NSMAIL.LEAVE.ATTACHMENTS \NSMAIL.GOOD.BODYTYPES MAILOBJ.WINDOWOFFSET MAILOBJ.SKIPCHAR \MAILOBJ.IMAGEFNS MAILOBJ.REFERENCE.FIELD \NSFILING.ATTRIBUTES DEFAULTICONFONT NSPRINT.WATCHERFLG) (P (CL:PROCLAIM (QUOTE (CL:SPECIAL *RETRIEVAL-ERROR*)))) (FILES (SOURCE) LAFITEDECLS) (FILES (LOADCOMP) CLEARINGHOUSE) (LOCALVARS . T))))
(* ; "Basic mail protocol")
(COURIERPROGRAM MAILTRANSPORT (17 4)
TYPES
((CREDENTIALS (AUTHENTICATION . CREDENTIALS)) (VERIFIER (AUTHENTICATION . VERIFIER)) (ENVELOPE.ITEM.TYPE LONGCARDINAL) (ENVELOPE (SEQUENCE ENVELOPE.ITEM)) (INVALID.NAME (RECORD (REASON INVALID.NAME.REASON) (NAME RNAME))) (INVALID.NAME.LIST (SEQUENCE INVALID.NAME)) (INVALID.NAME.REASON (ENUMERATION (NoSuchRecipient 0) (CantValidateNow 1) (IllegalName 2) (Refused 3) (NoAccessToDl 4) (Timeout 5) (NoDlsAllowed 6) (MessageTooLong 7))) (NAME (CLEARINGHOUSE . NAME)) (NAME.LIST (SEQUENCE NAME)) (RNAME NAME) (RNAME.LIST (SEQUENCE RNAME)) (WILLINGNESS CARDINAL) (CONTENTS.TYPE LONGCARDINAL) (MESSAGEID (ARRAY 5 UNSPECIFIED)) (POSTMARK (RECORD (POSTED.AT NAME) (TIME TIME))) (PROBLEM (RECORD (UNDELIVERABLES INVALID.NAME.LIST) (RETURNED.ENVELOPE ENVELOPE))) (CONNECTION.PROBLEM (FILING . CONNECTION.PROBLEM)) (SERVICE.PROBLEM (ENUMERATION (CannotAuthenticate 0) (ServiceFull 1) (ServiceUnavailable 2) (MediumFull 3))) (TRANSFER.PROBLEM (ENUMERATION (Aborted 0) (NoRendezvous 1) (WrongDirection 4))))
PROCEDURES
((SERVER.POLL 0 (CREDENTIALS VERIFIER) RETURNS (WILLINGNESS (CLEARINGHOUSE . NETWORK.ADDRESS.LIST) VERIFIER NAME)) (POST 1 (CREDENTIALS VERIFIER RNAME.LIST BOOLEAN BOOLEAN CONTENTS.TYPE ENVELOPE BULK.DATA.SOURCE) RETURNS (INVALID.NAME.LIST MESSAGEID) REPORTS (AUTHENTICATION.ERROR CONNECTION.ERROR INVALID.RECIPIENTS SERVICE.ERROR TRANSFER.ERROR UNDEFINED.ERROR)))
ERRORS
((AUTHENTICATION.ERROR 1 ((AUTHENTICATION . PROBLEM))) (CONNECTION.ERROR 2 (CONNECTION.PROBLEM)) (INVALID.RECIPIENTS 3 (INVALID.NAME.LIST)) (SERVICE.ERROR 4 (SERVICE.PROBLEM)) (TRANSFER.ERROR 5 (TRANSFER.PROBLEM)) (UNDEFINED.ERROR 6 (CARDINAL)))
)
(COURIERPROGRAM INBASKET (18 1)
INHERITS
(MAILTRANSPORT)
TYPES
((CREDENTIALS (AUTHENTICATION . CREDENTIALS)) (VERIFIER (AUTHENTICATION . VERIFIER)) (SESSION (RECORD (HANDLE (ARRAY 2 UNSPECIFIED)) (VERIFIER VERIFIER))) (ENVELOPE.ITEM.TYPE LONGCARDINAL) (ENVELOPE (SEQUENCE ENVELOPE.ITEM)) (INVALID.NAME (RECORD (REASON INVALID.NAME.REASON) (NAME RNAME))) (INVALID.NAME.LIST (SEQUENCE INVALID.NAME)) (INVALID.NAME.REASON (ENUMERATION (NoSuchRecipient 0) (CantValidateNow 1) (IllegalName 2) (Refused 3) (NoAccessToDl 4) (Timeout 5) (NoDlsAllowed 6) (MessageTooLong 7))) (NAME (CLEARINGHOUSE . NAME)) (NAME.LIST (SEQUENCE NAME)) (RNAME NAME) (RNAME.LIST (SEQUENCE RNAME)) (CONTENTS.TYPE LONGCARDINAL) (INDEX CARDINAL) (INBASKET.STATE (RECORD (LASTINDEX INDEX) (NEWCOUNT CARDINAL) (ISPRIMARY BOOLEAN) (ISPRIMARYUP BOOLEAN))) (RANGE (RECORD (FIRST INDEX) (LAST INDEX))) (MAIL.ATTRIBUTE.TYPE LONGCARDINAL) (MAIL.ATTRIBUTE (RECORD (TYPE MAIL.ATTRIBUTE.TYPE) (VALUE (SEQUENCE UNSPECIFIED)))) (SELECTIONS (RECORD (TRANSPORT.ENVELOPE BOOLEAN) (INBASKET.ENVELOPE BOOLEAN) (MAIL.ATTRIBUTES (SEQUENCE MAIL.ATTRIBUTE.TYPE)))) (CACHE.VERIFIER (ARRAY 4 UNSPECIFIED)) (MESSAGE.DESCRIPTION (RECORD (MESSAGE.INDEX INDEX) (TRANSPORT.ENVELOPE ENVELOPE) (INBASKET.ENVELOPE ENVELOPE) (CONTENT.ATTRIBUTES ENVELOPE))) (CACHE.STATUS UNSPECIFIED) (STATUS (ENUMERATION (NEW 0) (KNOWN 1) (RECEIVED 2))) (ACCESS.PROBLEM (ENUMERATION (AccessRightsInsufficient 0) (AccessRightsIndeterminate 1) (InbasketInUse 2) (NoSuchRecipients 3) (RecipientNameIndeterminate 4))) (CONNECTION.PROBLEM (FILING . CONNECTION.PROBLEM)) (SERVICE.PROBLEM (ENUMERATION (CannotAuthenticate 0) (ServiceFull 1) (ServiceUnavailable 2) (MediumFull 3))) (TRANSFER.PROBLEM (ENUMERATION (Aborted 0) (NoRendezvous 1) (WrongDirection 4))) (SESSION.PROBLEM (ENUMERATION (TokenInvalid 0) (SessionInUse 1))) (CALL.PROBLEM (ENUMERATION (USE.COURIER 0))))
PROCEDURES
((LOGON 5 (CREDENTIALS VERIFIER NAME CACHE.VERIFIER BOOLEAN) RETURNS (SESSION CACHE.STATUS) REPORTS (ACCESS.ERROR AUTHENTICATION.ERROR SERVICE.ERROR UNDEFINED.ERROR)) (LOGOFF 4 (SESSION) RETURNS (CACHE.VERIFIER) REPORTS (AUTHENTICATION.ERROR SESSION.ERROR UNDEFINED.ERROR)) (MAILPOLL 7 (CREDENTIALS VERIFIER NAME) RETURNS (INBASKET.STATE) REPORTS (ACCESS.ERROR AUTHENTICATION.ERROR SERVICE.ERROR UNDEFINED.ERROR)) (MAILCHECK 6 (SESSION) RETURNS (INBASKET.STATE CARDINAL) REPORTS (ACCESS.ERROR AUTHENTICATION.ERROR SERVICE.ERROR UNDEFINED.ERROR)) (CHANGE.STATUS 0 (SESSION RANGE STATUS) RETURNS NIL REPORTS (AUTHENTICATION.ERROR INVALID.INDEX SESSION.ERROR UNDEFINED.ERROR)) (DELETE 1 (SESSION RANGE) RETURNS NIL REPORTS (AUTHENTICATION.ERROR INVALID.INDEX SESSION.ERROR UNDEFINED.ERROR)) (LIST 2 (SESSION RANGE SELECTIONS BULK.DATA.SINK) RETURNS NIL REPORTS (AUTHENTICATION.ERROR CONNECTION.ERROR INVALID.INDEX SESSION.ERROR TRANSFER.ERROR UNDEFINED.ERROR)) (LOCATE 3 (SESSION STATUS) RETURNS (INDEX) REPORTS (AUTHENTICATION.ERROR SESSION.ERROR UNDEFINED.ERROR)) (RETRIEVE 8 (SESSION INDEX CONTENTS.TYPE BULK.DATA.SINK) RETURNS (ENVELOPE ENVELOPE) REPORTS (AUTHENTICATION.ERROR CONNECTION.ERROR CONTENTS.TYPE.MISMATCH INVALID.INDEX SESSION.ERROR TRANSFER.ERROR UNDEFINED.ERROR)))
ERRORS
((ACCESS.ERROR 0 (ACCESS.PROBLEM)) (AUTHENTICATION.ERROR 1 ((AUTHENTICATION . PROBLEM))) (CONNECTION.ERROR 2 (CONNECTION.PROBLEM)) (CONTENTS.TYPE.MISMATCH 3 (CONTENTS.TYPE)) (SESSION.ERROR 5 (SESSION.PROBLEM)) (INVALID.INDEX 4 (INDEX)) (SERVICE.ERROR 6 (SERVICE.PROBLEM)) (TRANSFER.ERROR 7 (TRANSFER.PROBLEM)) (UNDEFINED.ERROR 8 (CALL.PROBLEM)))
)
(DEFINEQ
(\NSMAIL.AUTHENTICATE
(LAMBDA NIL (* ; "Edited 6-Jun-88 19:45 by bvm") (LET ((INFO (\INTERNAL/GETPASSWORD (QUOTE |NS::|))) NSUSERNAME FULLNAME MSERVERS AUTHENTICATED? CREDENTIALS MSG) (SETQ NSUSERNAME (PARSE.NSNAME (CAR INFO))) (COND ((NEQ (SETQ AUTHENTICATED? (COND ((NULL (SETQ FULLNAME (CH.LOOKUP.OBJECT NSUSERNAME))) (QUOTE NONE)) (T (NS.AUTHENTICATE (SETQ CREDENTIALS (NS.MAKE.SIMPLE.CREDENTIALS (CONS FULLNAME (CDR INFO)))))))) T) (printout PROMPTWINDOW T "Cannot authenticate user " (NSNAME.TO.STRING (OR FULLNAME NSUSERNAME) T) " because: " (SELECTQ (SETQ \LAFITE.AUTHENTICATION.FAILURE AUTHENTICATED?) (CredentialsInvalid "Login incorrect") (KeysUnavailable (CONCAT "Authentication server unavailable for domain " (fetch NSDOMAIN of FULLNAME))) (NONE "No such user") AUTHENTICATED?) ".") NIL) ((NULL (SETQ MSERVERS (NS.FINDMAILBOXES FULLNAME))) (printout PROMPTWINDOW T "There are no mail servers for user " (NSNAME.TO.STRING FULLNAME T)) NIL) (T (create LAFITEMODEDATA FULLUSERNAME ← (NSNAME.TO.STRING FULLNAME T) UNPACKEDUSERNAME ← FULLNAME CREDENTIALS ← CREDENTIALS SHORTUSERNAME ← (CONCAT (fetch NSOBJECT of FULLNAME) (QUOTE %:) (COND ((NOT (STRING-EQUAL (fetch NSDOMAIN of FULLNAME) CH.DEFAULT.DOMAIN)) (fetch NSDOMAIN of FULLNAME)) (T ""))) MAILSERVERS ← (for MAILSERVER in MSERVERS collect (* ; "MAILSERVER = (name . addresses)") (create MAILSERVER MAILPORT ← (CADR MAILSERVER) MAILSERVERNAME ← (CAR MAILSERVER) MAILSERVEROPS ← (CONSTANT (LIST (FUNCTION NS.POLLNEWMAIL) (FUNCTION NS.OPENMAILBOX) (FUNCTION NS.NEXTMESSAGE) (FUNCTION NS.RETRIEVEMESSAGE) (FUNCTION NS.CLOSEMAILBOX))))))))))
)
(\NSMAIL.LOGIN
(LAMBDA NIL (* ; "Edited 7-Jun-88 19:37 by bvm") (if (LAFITE.PROMPT.FOR.LOGIN (QUOTE |NS::|)) then (* ; "Got the login, now authenticate") (\LAFITE.GET.USER.DATA (QUOTE NS) NIL T) (\LAFITE.WAKE.WATCHER)))
)
(NS.FINDMAILBOXES
(LAMBDA (USERNAME) (* ; "Edited 18-Jul-88 12:55 by bvm") (LET ((MAILBOXENTRY (CH.RETRIEVE.ITEM (PARSE.NSNAME USERNAME) (CH.PROPERTY (QUOTE MAILBOXES)) (QUOTE MAILBOX.VALUES)))) (AND MAILBOXENTRY (for MB in (COURIER.FETCH (CLEARINGHOUSE . MAILBOX.VALUES) MAIL.SERVICE of (CADR MAILBOXENTRY)) when (SETQ MB (COND ((LOOKUP.NS.SERVER MB NIL T)) (T (PRINTOUT PROMPTWINDOW T "Cannot find address for mail server " MB) NIL))) collect MB))))
)
)
(ADDTOVAR LAFITEMODELST (NS 1 \NSMAIL.SEND.PARSE \NSMAIL.SEND \NSMAIL.MAKEANSWERFORM \NSMAIL.AUTHENTICATE \NSMAIL.MESSAGE.P \NSMAIL.MESSAGE.FROM.SELF.P \NSMAIL.LOGIN) (STAR . NS))
(* ; "Retrieving mail")
(DEFINEQ
(NS.POLLNEWMAIL
(LAMBDA (ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER) (* bvm%: "22-May-85 11:40") (PROG (RESULT N) (RETURN (COND ((SETQ RESULT (\NSMAIL.CHECK ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER)) (AND (NEQ (SETQ N (fetch STATEFIRSTNEW of (fetch MAILSTATE of MAILSERVER))) 0) (IGEQ (COURIER.FETCH (INBASKET . INBASKET.STATE) LASTINDEX of RESULT) N))) (T (QUOTE ?))))))
)
(NS.OPENMAILBOX
(LAMBDA (ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER) (* ; "Edited 9-Sep-88 12:07 by bvm") (LET ((STREAM (\NSMAIL.COURIER.OPEN ADDRESS)) (NSMAILSTATE (fetch MAILSTATE of MAILSERVER)) INBASKETSTATE FIRSTINDEX LASTINDEX N) (COND ((NULL STREAM) NIL) ((OR (NULL (SETQ INBASKETSTATE (\NSMAIL.CHECK ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER STREAM NIL T))) (EQ (CAR INBASKETSTATE) (QUOTE ERROR))) (CLOSEF STREAM) (* ; "Return error msg") (CONS NIL (CDR INBASKETSTATE))) ((EQ (SETQ N (COND (NIL (* ; "This is apparently not yet implemented -- always zero") (COURIER.FETCH (INBASKET . INBASKET.STATE) NEWCOUNT of INBASKETSTATE)) ((EQ (SETQ FIRSTINDEX (fetch STATEFIRSTNEW of NSMAILSTATE)) 0) (* ; "No NEW messages at all") 0) (T (ADD1 (IDIFFERENCE (SETQ LASTINDEX (COURIER.FETCH (INBASKET . INBASKET.STATE) LASTINDEX of INBASKETSTATE)) FIRSTINDEX))))) 0) (CLOSEF STREAM) (QUOTE EMPTY)) (T (* ; "Return (MAILBOX . properties)") (CONS (create NSMAILBOX NSMAILSTREAM ← STREAM NSMAILLASTINDEX ← LASTINDEX NSMAILSTATE ← NSMAILSTATE) (LIST (QUOTE %#OFMESSAGES) N))))))
)
(\NSMAIL.CHECK
(LAMBDA (ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER STREAM STATE RETURNERRORS) (* ; "Edited 27-Jul-88 12:41 by bvm") (* ;;; "Performs a mail check for user REGISTEREDNAME at ADDRESS, returning INBASKETSTATE if successful, NIL if not. Updates the MAILSTATE of MAILSERVER as appropriate to reflect current SESSION and STATEFIRSTNEW (first new message)") (RESETLST (PROG ((JUSTCHECKING (NULL STREAM)) SESSION POLLRESULT LASTINDEX FIRSTNEW OLDLAST CONTINUANCE) (COND ((AND (NULL STATE) (NULL (SETQ STATE (fetch MAILSTATE of MAILSERVER)))) (replace MAILSTATE of MAILSERVER with (SETQ STATE (create NSMAILSTATE STATENAME ← (PARSE.NSNAME REGISTEREDNAME) STATEADDRESS ← ADDRESS STATECREDENTIALS ← CREDENTIALS))))) (SETQ SESSION (fetch STATESESSION of STATE)) (SETQ FIRSTNEW (fetch STATEFIRSTNEW of STATE)) (SETQ OLDLAST (fetch STATEOLDLAST of STATE)) RETRY (COND ((NULL SESSION) (if (AND (NOT NSMAIL.LEAVE.ATTACHMENTS) JUSTCHECKING) then (* ; "Just polling, don't need session") (SETQ POLLRESULT (COURIER.EXPEDITED.CALL ADDRESS \NSMAIL.SOCKET (QUOTE INBASKET) (QUOTE MAILPOLL) (CAR CREDENTIALS) (CDR CREDENTIALS) (fetch STATENAME of STATE) (QUOTE RETURNERRORS))) (GO GOTRESULT)) (COND ((NULL STREAM) (* ; "Need a real Courier stream for some reason here") (COND ((SETQ STREAM (COURIER.OPEN ADDRESS NIL T (QUOTE NSMAIL))) (RESETSAVE NIL (LIST (QUOTE CLOSEF) STREAM))) (T (RETURN NIL))))) (COND ((EQ (CAR (SETQ SESSION (COND ((OR T STREAM) (* ; "Would be nice to do this expedited, but this ability was taken out in Services 8.1!") (COURIER.CALL STREAM (QUOTE INBASKET) (QUOTE LOGON) (CAR CREDENTIALS) (CDR CREDENTIALS) (fetch STATENAME of STATE) \NULL.CACHE.VERIFIER T (QUOTE RETURNERRORS))) (T (COURIER.EXPEDITED.CALL ADDRESS \NSMAIL.SOCKET (QUOTE INBASKET) (QUOTE LOGON) (CAR CREDENTIALS) (CDR CREDENTIALS) (fetch STATENAME of STATE) \NULL.CACHE.VERIFIER T (QUOTE RETURNERRORS)))))) (QUOTE ERROR)) (GO ERROR))) (replace STATESESSION of STATE with (SETQ SESSION (CAR SESSION))))) (SETQ POLLRESULT (COND ((NULL STREAM) (* ; "Just checking") (COURIER.EXPEDITED.CALL ADDRESS \NSMAIL.SOCKET (QUOTE INBASKET) (QUOTE MAILCHECK) SESSION (QUOTE RETURNERRORS))) (T (COURIER.CALL STREAM (QUOTE INBASKET) (QUOTE MAILCHECK) SESSION (QUOTE RETURNERRORS))))) GOTRESULT (COND ((NULL POLLRESULT) (* ; "Failed somehow") (RETURN NIL)) ((EQ (CAR (LISTP POLLRESULT)) (QUOTE ERROR)) (COND ((EQ (CADR POLLRESULT) (QUOTE SESSION.ERROR)) (* ; "Session timed out, start a new one") (replace STATESESSION of STATE with (SETQ SESSION NIL)) (replace STATEFIRSTNEW of STATE with (SETQ FIRSTNEW NIL)) (replace STATEOLDLAST of STATE with (SETQ OLDLAST NIL)) (GO RETRY)) (T (SETQ SESSION POLLRESULT) (GO ERROR))))) (if SESSION then (* ; "MAILCHECK returned 2 values: state and continuance") (SETQ CONTINUANCE (CADR POLLRESULT)) (SETQ POLLRESULT (CAR POLLRESULT))) (COND ((EQ (SETQ LASTINDEX (COURIER.FETCH (INBASKET . INBASKET.STATE) LASTINDEX of POLLRESULT)) 0) (* ; "Mailbox is empty") (replace STATEFIRSTNEW of STATE with 0)) ((NOT NSMAIL.LEAVE.ATTACHMENTS) (* ; "Retrieving all mail, so we don't care about NEW vs OLD") (replace STATEFIRSTNEW of STATE with 1) (replace STATEOLDLAST of STATE with LASTINDEX)) ((OR (NULL OLDLAST) (ILESSP OLDLAST LASTINDEX) (NOT JUSTCHECKING) (NULL FIRSTNEW)) (* ; "Need to accurately locate first NEW message") (replace STATEFIRSTNEW of STATE with (COND (STREAM (COURIER.CALL STREAM (QUOTE INBASKET) (QUOTE LOCATE) SESSION (QUOTE NEW) (QUOTE NOERROR))) (T (COURIER.EXPEDITED.CALL ADDRESS \NSMAIL.SOCKET (QUOTE INBASKET) (QUOTE LOCATE) SESSION (QUOTE NEW) (QUOTE RETURNERRORS))))) (replace STATEOLDLAST of STATE with LASTINDEX))) (replace (MAILSERVER CONTINUANCE) of MAILSERVER with (AND (FIXP CONTINUANCE) (ITIMES 1000 (IQUOTIENT (ITIMES CONTINUANCE 4) 5)))) (* ; "Tell poller to call again soon enough to keep session alive") (RETURN POLLRESULT) ERROR (if (NOT (EQUAL (CDR SESSION) (QUOTE (CONNECTION.PROBLEM NoResponse)))) then (* ; "Don't bother mentioning the error if it's just a timeout, since mailwatch will handle our NIL response fine.") (LET ((ERRMSG (CASE (CADR SESSION) ((REJECT SERVICE.ERROR) (* ; "Identify these by their lone arg") (CAADDR SESSION)) (T (COND (NSWIZARDFLG (HELP SESSION))) (SUBSTRING (CDR SESSION) 2 -2))))) (if RETURNERRORS then (RETURN (CONS (QUOTE ERROR) ERRMSG)) else (LET ((*PRINT-CASE* :UPCASE)) (* ; "Lousy atomic error names...") (CL:FORMAT PROMPTWINDOW "~%%From mail server ~A: ~A" (fetch MAILSERVERNAME of MAILSERVER) ERRMSG))))) (RETURN NIL))))
)
(NS.NEXTMESSAGE
(LAMBDA (MAILBOX) (* bvm%: "14-Nov-84 23:30") (PROG ((ENVELOPES (fetch NSMAILENVTAIL of MAILBOX))) (SELECTQ ENVELOPES (NIL (* ; "First time, read all envelopes") (COND ((OR (fetch NSMAILENVELOPES of MAILBOX) (NULL (SETQ ENVELOPES (\NSMAIL.READ.ENVELOPES MAILBOX)))) (RETURN))) (replace NSMAILENVELOPES of MAILBOX with ENVELOPES) (replace NSMAILENVTAIL of MAILBOX with ENVELOPES)) (T (* ; "Finished") (RETURN)) NIL) (RETURN (CAR ENVELOPES))))
)
(\NSMAIL.READ.ENVELOPES
(LAMBDA (MAILBOX) (* bvm%: "16-May-85 12:47") (PROG (ENVELOPES) (SETQ ENVELOPES (COURIER.CALL (fetch NSMAILSTREAM of MAILBOX) (QUOTE INBASKET) (QUOTE LIST) (fetch NSMAILSESSION of MAILBOX) (COURIER.CREATE (INBASKET . RANGE) FIRST ← (fetch NSMAILFIRSTINDEX of MAILBOX) LAST ← (fetch NSMAILLASTINDEX of MAILBOX)) (COURIER.CREATE (INBASKET . SELECTIONS) TRANSPORT.ENVELOPE ← T INBASKET.ENVELOPE ← T MAIL.ATTRIBUTES ← (LIST (\NSMAIL.ATTRIBUTE.TYPE BodyType))) (QUOTE (INBASKET . MESSAGE.DESCRIPTION)))) (RETURN (for E in ENVELOPES collect (CONS (COURIER.FETCH (INBASKET . MESSAGE.DESCRIPTION) MESSAGE.INDEX of E) (APPEND (COURIER.FETCH (INBASKET . MESSAGE.DESCRIPTION) CONTENT.ATTRIBUTES of E) (COURIER.FETCH (INBASKET . MESSAGE.DESCRIPTION) TRANSPORT.ENVELOPE of E) (COURIER.FETCH (INBASKET . MESSAGE.DESCRIPTION) INBASKET.ENVELOPE of E)))))))
)
(NS.RETRIEVEMESSAGE
(LAMBDA (MAILBOX MSGOUTFILE) (* ; "Edited 9-Sep-88 12:30 by bvm") (LET ((*RETRIEVAL-ERROR* NIL) (ENVELOPE (pop (fetch NSMAILENVTAIL of MAILBOX))) TYPE) (if (OR NSMAIL.LEAVE.ATTACHMENTS (MEMB (SETQ TYPE (CADR (ASSOC (QUOTE BodyType) ENVELOPE))) \NSMAIL.GOOD.BODYTYPES)) then (* ; "Retrieve ordinary text message, or retrieve the text part and leave attachment behind") (\NSMAIL.RETRIEVE MAILBOX ENVELOPE (FUNCTION (LAMBDA (MSGSTREAM) (* ;; "MSGSTREAM is a bulk data stream containing content of msg, as a 'serialized file'") (SETFILEINFO MSGSTREAM (QUOTE ENDOFSTREAMOP) (FUNCTION \NSMAIL.EOF.ON.RETRIEVE)) (\NSMAIL.CHECK.SERIALIZED.VERSION MSGSTREAM) (\NSMAIL.READ.SERIALIZED.TREE MSGSTREAM MSGOUTFILE (CDR ENVELOPE)))) (GETFILEPTR MSGOUTFILE) MSGOUTFILE) (COND (*RETRIEVAL-ERROR* (printout MSGOUTFILE T *RETRIEVAL-ERROR* T))) else (* ; "Not text or mail note, so retrieve the whole thing raw and make an %"attachment%"") (SETQ TYPE (\TYPE.FROM.FILETYPE TYPE)) (LET ((BUFFER (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))) BODY ATTACHPOINT ATTRIBUTE.END) (SETQ BODY (\NSMAIL.RETRIEVE MAILBOX ENVELOPE (FUNCTION (LAMBDA (BULKSTREAM) (* ; "Just eat it raw") (LET ((BODY (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH) NIL (QUOTE ((ENDOFSTREAMOP \NSMAIL.EOF.ON.RETRIEVE)))))) (COPYBYTES BULKSTREAM BODY) BODY))))) (SETFILEPTR BODY 0) (\NSMAIL.CHECK.SERIALIZED.VERSION BODY) (SETQ ATTACHPOINT (\NSMAIL.READ.SERIALIZED.TREE BODY BUFFER (CDR ENVELOPE) T)) (SETQ ATTRIBUTE.END (GETFILEPTR BODY)) (SETQ BUFFER (OPENTEXTSTREAM BUFFER NIL NIL NIL (LIST (QUOTE FONT) LAFITEDISPLAYFONT))) (TEDIT.INSERT.OBJECT (\MAILOBJ.CREATE BODY TYPE ATTRIBUTE.END) BUFFER (ADD1 ATTACHPOINT)) (COPYBYTES (OPENSTREAM (COERCETEXTOBJ BUFFER (QUOTE FILE)) (QUOTE INPUT)) MSGOUTFILE) (* ; "Would like this to be (COERCETEXTOBJ BUFFER (QUOTE FILE) MSGOUTFILE) but Tedit has a bug"))) (COND ((NEQ (CADR ENVELOPE) (QUOTE NO)) (* ; "Read okay, tell close mailbox to delete it. NO set when there is an attachment to leave behind") (RPLACA (CDR ENVELOPE) (QUOTE DELETE))))))
)
(\NSMAIL.RETRIEVE
(LAMBDA (MAILBOX ENVELOPE RETRIEVEFN START MSGOUTFILE) (* ; "Edited 9-Sep-88 12:33 by bvm") (* ;; "Perform an Inbasket.Retrieve on the specified message, using RETRIEVEFN to read the bulk data. If START is true, then the file pointer on MSGOUTFILE is returned to START if we have to retry") (bind RESULT while (EQ (CAR (LISTP (SETQ RESULT (COURIER.CALL (fetch NSMAILSTREAM of MAILBOX) (QUOTE INBASKET) (QUOTE RETRIEVE) (fetch NSMAILSESSION of MAILBOX) (CAR ENVELOPE) \NSMAIL.CTSTANDARD.MESSAGE RETRIEVEFN (QUOTE RETURNERRORS))))) (QUOTE ERROR)) do (* ; "Maybe lost the stream?") (\NSMAIL.SIGNAL.ERROR RESULT MAILBOX (QUOTE INBASKET) (QUOTE RETRIEVE)) (AND START (SETFILEPTR MSGOUTFILE START)) finally (RETURN RESULT)))
)
(\NSMAIL.EOF.ON.RETRIEVE
(LAMBDA (STREAM) (DECLARE (USEDFREE *RETRIEVAL-ERROR*)) (* ; "Edited 9-Sep-88 12:29 by bvm") (SETQ *RETRIEVAL-ERROR* "**Warning: errors in message format**") (COND (LAFITEDEBUGFLG (HELP "EOF during retrieve"))) (LET (POS) (COND ((SETQ POS (STKPOS (FUNCTION \NSMAIL.READ.SERIALIZED.TREE))) (RETFROM POS NIL T)) (T 0))))
)
(\NSMAIL.READ.SERIALIZED.TREE
(LAMBDA (MSGSTREAM MSGOUTFILE ENVELOPE ATTACHMENT) (* ; "Edited 9-Jun-88 17:23 by bvm") (* ;;; "Read a message, which is in the format of a NS Filing Serialized File. This is the recursive part, SerializedTree. Format is --- Sequence of Attribute; Content; children = Sequence of SerializedTree") (PROG (TYPE VALUE HEADERFIELDS LENGTH NOTEBODY HEADERS SENDER TYPEINFO DISCARDED COERCED FORMATSTREAM BODYSTREAM ATTACHPOINT) (for N from (\WIN MSGSTREAM) to 1 by -1 do (SETQ TYPE (COURIER.READ MSGSTREAM NIL (QUOTE LONGCARDINAL))) (COND ((NOT (find old TYPEINFO in \NSMAIL.ATTRIBUTES suchthat (EQ (CADR TYPEINFO) TYPE))) (* ; "We don't understand this attribute") (if (AND NSMAILDEBUGFLG (NOT ATTACHMENT)) then (push DISCARDED TYPE)) (COURIER.SKIP.SEQUENCE MSGSTREAM NIL (QUOTE UNSPECIFIED))) ((EQ (SETQ TYPE (CAR TYPEINFO)) (QUOTE Note)) (* ;; "This is a star mail note. Treat as body of message. If it isn't the last attribute, save it for the end") (COND ((NEQ N 1) (COND (NOTEBODY (TERPRI NOTEBODY)) (T (SETQ NOTEBODY (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))))) (\NSMAIL.READ.STRING.AS.STREAM MSGSTREAM NOTEBODY)) (T (SETQ ATTACHPOINT (\NSMAIL.PRINT.HEADERFIELDS MSGOUTFILE HEADERFIELDS ENVELOPE SENDER NOTEBODY ATTACHMENT DISCARDED)) (* ; "Print accumulated header fields") (TERPRI MSGOUTFILE) (\NSMAIL.READ.STRING.AS.STREAM MSGSTREAM MSGOUTFILE) (RETURN)))) ((OR (EQ TYPE (QUOTE LispFormatting)) (EQ TYPE (QUOTE OldLispFormatting))) (* ; "Note that this MUST be the last attribute") (COND ((EQ N 1) (* ; "Save the formatting so we can munge it") (SETQ FORMATSTREAM (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))) (\NSMAIL.READ.STRING.AS.STREAM MSGSTREAM FORMATSTREAM) (RETURN)) (T (PRINTOUT PROMPTWINDOW T "Bad formatted message") (\NSMAIL.READ.STRING.AS.STREAM MSGSTREAM (OPENSTREAM (QUOTE {NULL}) (QUOTE OUTPUT)))))) (T (SETQ VALUE (PROGN (\WIN MSGSTREAM) (COURIER.READ MSGSTREAM (QUOTE MAILTRANSPORT) (CADDR TYPEINFO)))) (COND ((SELECTQ TYPE ((BodyType BodySize) NIL) (Sender (SETQ SENDER VALUE)) (From (COND ((AND (NULL SENDER) (NULL (CDR VALUE))) (SETQ SENDER (CAR VALUE)))) T) T) (push HEADERFIELDS (CONS TYPE VALUE)))))) finally (* ; "Note was not the final attribute. Print headers accumulated, then the Note last") (SETQ ATTACHPOINT (\NSMAIL.PRINT.HEADERFIELDS MSGOUTFILE HEADERFIELDS ENVELOPE SENDER NOTEBODY ATTACHMENT DISCARDED))) (COND (FORMATSTREAM (* ; "This is a TEdit formatted message") (LET ((START (GETFILEPTR MSGOUTFILE))) (\NSMAIL.PRINT.HEADERFIELDS MSGOUTFILE HEADERFIELDS ENVELOPE SENDER NIL NIL DISCARDED) (TERPRI MSGOUTFILE) (* ; "We have now printed the header and a blank line. This is all the added text we have, not counted in the formatting") (SETQ START (- (GETFILEPTR MSGOUTFILE) START)) (if NOTEBODY then (COPYBYTES NOTEBODY MSGOUTFILE 0 -1)) (\NSMAIL.READ.SERIALIZED.CONTENT MSGSTREAM MSGOUTFILE) (* ; "One or the other of these clauses (never both) produced the body of the message, to which the formatting applies.") (LA.ADJUST.FORMATTING FORMATSTREAM MSGOUTFILE START))) (T (* ; "No formatting, possibly read body now") (COND (ATTACHMENT (* ; "We have read the header, body is attachment. Let caller know where the %"Attachment: %" line is.") (RETURN ATTACHPOINT))) (TERPRI MSGOUTFILE) (* ; "Set off header") (COND ((EQ (CAR ENVELOPE) (QUOTE NO)) (* ; "Can't read this attachment, leave in mailbox") (printout MSGOUTFILE T T "*** Attachment retained in mailbox for retrieval by other means ***" T) (COURIER.ABORT.BULKDATA))) (\NSMAIL.READ.SERIALIZED.CONTENT MSGSTREAM MSGOUTFILE))) (RPTQ (\WIN MSGSTREAM) (* ; "Read children") (\NSMAIL.READ.SERIALIZED.TREE MSGSTREAM MSGOUTFILE))))
)
(\NSMAIL.CHECK.SERIALIZED.VERSION
(LAMBDA (STREAM) (* ; "Edited 3-Jul-87 17:29 by bvm:") (OR (EQ (COURIER.READ STREAM NIL (QUOTE LONGCARDINAL)) \SERIALIZED.FILE.VERSION) (HELP "Wrong serialized file version")))
)
(\NSMAIL.READ.SERIALIZED.CONTENT
(LAMBDA (INSTREAM OUTSTREAM) (* bvm%: "16-May-85 14:29") (* ;;; "Interprets INSTREAM as SerializedTree.Content, i.e., as a Bulkdata.StreamOfUnspecified followed by the lastByteIsSignificant flag. Copies the raw data therein to OUTSTREAM") (bind LASTSEGMENT? BYTE WORDCOUNT do (SETQ LASTSEGMENT? (NEQ (\WIN INSTREAM) 0)) (COND ((NEQ (SETQ WORDCOUNT (UNFOLD (\WIN INSTREAM) BYTESPERWORD)) 0) (RPTQ (SUB1 WORDCOUNT) (\BOUT OUTSTREAM (\BIN INSTREAM))) (SETQ BYTE (\BIN INSTREAM)) (* ; "Final byte of this segment. Don't copy until we know whether it's significant") (COND ((OR (NULL LASTSEGMENT?) (NEQ (\WIN INSTREAM) 0)) (* ; "Not last segment, or the word after says the final byte was significant") (\BOUT OUTSTREAM BYTE)))) (T (* ; "Null body. Throw out the lastByteIsSignificant flag") (\WIN INSTREAM))) repeatuntil LASTSEGMENT?))
)
(\NSMAIL.READ.STRING.AS.STREAM
(LAMBDA (INSTREAM OUTSTREAM) (* bvm%: "30-Jul-84 16:13") (* ;; "Considers INSTREAM to be positioned at a sequence of unspecified, and reads it as if its datatype were string, and copies said bytes to OUTSTREAM") (PROG (LENGTH) (\WIN INSTREAM) (* ; "Skip sequence count") (COPYBYTES INSTREAM OUTSTREAM (SETQ LENGTH (\WIN INSTREAM))) (COND ((ODDP LENGTH) (\BIN INSTREAM)))))
)
(\NSMAIL.PRINT.HEADERFIELDS
(LAMBDA (MSGOUTFILE HEADERFIELDS ENVELOPE SENDER NOTEBODY ATTACHMENT DISCARDED) (* ; "Edited 7-Sep-88 11:24 by bvm") (* ;; "Compose message header from HEADERFIELDS and ENVELOPE, printing to MSGOUTFILE. SENDER is the %"Sender%" field of the message, if we encountered one, or sole element of the %"From%" field. NOTEBODY if non-NIL is a stream containing the text of a Note attribute. if ATTACHMENT is true, we add a line %"Attachment:%" to the message and return its file pointer in MSGOUTFILE for later insertion of an attachment object. DISCARDED is list of fields we didn't recognize.") (LET (TYPE BADNAMES REASON TMP VALUE ID) (SETQ HEADERFIELDS (REVERSE HEADERFIELDS)) (COND (ENVELOPE (if (SETQ VALUE (ASSOC (QUOTE TransportProblem) ENVELOPE)) then (* ; "Return of undeliverable mail") (SETQ HEADERFIELDS (DREMOVE VALUE HEADERFIELDS)) (SETQ VALUE (CADR VALUE)) (* ; "VALUE is (invalidNames envelope)") (PRINTOUT MSGOUTFILE "Date: " (GDATE (COURIER.FETCH (MAILTRANSPORT . POSTMARK) TIME of (CADR (ASSOC (QUOTE Postmark) ENVELOPE))) (DATEFORMAT TIME.ZONE)) T "From: " (NSNAME.TO.STRING (CADR (ASSOC (QUOTE Originator) ENVELOPE)) T) T "Subject: Undeliverable mail" T T) (SETQ BADNAMES (COURIER.FETCH (MAILTRANSPORT . PROBLEM) UNDELIVERABLES of VALUE)) (SETQ REASON (COURIER.FETCH (MAILTRANSPORT . INVALID.NAME) REASON of (CAR BADNAMES))) (PRINTOUT MSGOUTFILE "This message could not be delivered to ") (if (NULL (CDR BADNAMES)) then (PRINTOUT MSGOUTFILE (NSNAME.TO.STRING (COURIER.FETCH (MAILTRANSPORT . INVALID.NAME) NAME of (CAR BADNAMES)) T) " because: " REASON T) else (PRINTOUT MSGOUTFILE "the following recipients") (if (for PAIR in (CDR BADNAMES) always (EQ (COURIER.FETCH (MAILTRANSPORT . INVALID.NAME) REASON of PAIR) REASON)) then (* ; "Same reason for all") (PRINTOUT MSGOUTFILE " because: " REASON) (for PAIR in BADNAMES bind (SEPR ← ": ") do (PRINTOUT MSGOUTFILE SEPR (NSNAME.TO.STRING (COURIER.FETCH (MAILTRANSPORT . INVALID.NAME) NAME of PAIR) T)) (SETQ SEPR ", ") finally (TERPRI MSGOUTFILE)) else (PRINTOUT MSGOUTFILE ":" T) (for PAIR in BADNAMES do (PRINTOUT MSGOUTFILE (NSNAME.TO.STRING (COURIER.FETCH (MAILTRANSPORT . INVALID.NAME) NAME of PAIR) T) " because: " (COURIER.FETCH (MAILTRANSPORT . INVALID.NAME) REASON of PAIR) T)))) (PRINTOUT MSGOUTFILE T "- - - - - - - - -" T) (for PAIR in (CADR VALUE) do (* ; "Replace envelope of remaining message with returned envelope") (if (SETQ TMP (ASSOC (CAR PAIR) ENVELOPE)) then (RPLACD TMP (CDR PAIR)) else (push HEADERFIELDS PAIR)))) (* ;; "Prescan HEADERFIELDS to see if there is any additional info we should supply that wasn't in the message") (for PAIR in ENVELOPE do (SETQ VALUE (CADR PAIR)) (SELECTQ (SETQ TYPE (CAR PAIR)) ((PreviousRecipients) (push HEADERFIELDS (CONS TYPE VALUE))) (Postmark (COND ((NULL (ASSOC (QUOTE Date) HEADERFIELDS)) (push HEADERFIELDS (CONS (QUOTE Date) (COURIER.FETCH (MAILTRANSPORT . POSTMARK) TIME of VALUE)))))) (Originator (COND ((NOT (AND SENDER (EQUAL.CH.NAMES SENDER VALUE))) (* ; "The agent that sent the message is not the same as what the header gives as Sender/From.") (push HEADERFIELDS (CONS (if (ASSOC (QUOTE Sender) HEADERFIELDS) then (* ; "There's already a Sender field, so leave it as Originator") (QUOTE Originator) else (QUOTE Sender)) VALUE))))) (BodyType (COND ((AND (NOT ATTACHMENT) (NOT (MEMB VALUE \NSMAIL.GOOD.BODYTYPES))) (NCONC1 HEADERFIELDS (CONS (QUOTE Attachment) VALUE))))) (Message-ID (SETQ ID VALUE)) NIL)))) (for PAIR in HEADERFIELDS when (SETQ VALUE (CDR PAIR)) do (printout MSGOUTFILE (SETQ TYPE (CAR PAIR)) ": ") (SELECTQ TYPE (Date (printout MSGOUTFILE (GDATE VALUE (DATEFORMAT NO.SECONDS TIME.ZONE SPACES)))) ((From To cc Reply-to) (\NSMAIL.PRINT.NAMES VALUE MSGOUTFILE (SELECTQ TYPE ((From Reply-to) (* ; "These are always full-qualified") NIL) SENDER))) ((Sender Originator) (printout MSGOUTFILE (NSNAME.TO.STRING VALUE T))) (Attachment (printout MSGOUTFILE "%"Type " |.I1| VALUE " ID " |.P2| ID "%"") (RPLACA ENVELOPE (QUOTE NO))) (PRIN1 VALUE MSGOUTFILE)) (TERPRI MSGOUTFILE)) (if DISCARDED then (printout MSGOUTFILE "Discarded-Fields: ") (LA.PRINT.COMMA.LIST (REVERSE DISCARDED) MSGOUTFILE) (TERPRI MSGOUTFILE)) (PROG1 (COND (ATTACHMENT (* ; "Reserve a line where the attachment will be placed.") (TERPRI MSGOUTFILE) (PRINTOUT MSGOUTFILE "Attachment: ") (PROG1 (GETFILEPTR MSGOUTFILE) (TERPRI MSGOUTFILE)))) (COND (NOTEBODY (TERPRI MSGOUTFILE) (COPYBYTES NOTEBODY MSGOUTFILE 0 -1) (TERPRI MSGOUTFILE))))))
)
(\NSMAIL.PRINT.NAMES
(LAMBDA (NSNAMES OUTSTREAM DEFAULTNAME) (* bvm%: " 3-Jul-84 12:53") (for NAME in NSNAMES bind (FIRSTTIME ← T) do (COND (FIRSTTIME (SETQ FIRSTTIME NIL)) (T (printout OUTSTREAM ", "))) (PRIN1 (NSNAME.TO.STRING NAME T) OUTSTREAM)))
)
)
(* ; "Error handling")
(DEFINEQ
(\NSMAIL.COURIER.OPEN
(LAMBDA (ADDRESS) (* ; "Edited 9-Sep-88 12:06 by bvm") (COURIER.OPEN ADDRESS NIL T (QUOTE NSMAIL) NIL (CONSTANT (LIST (QUOTE ERRORHANDLER) (FUNCTION \NSMAIL.ERRORHANDLER)))))
)
(\NSMAIL.ERRORHANDLER
(LAMBDA (STREAM ERRCODE) (* ; "Edited 9-Sep-88 12:35 by bvm") (* ;; "Called when SPP error occurs on NS mail courier connection STREAM. Fakes an error return from the courier.call.") (LET (POS) (if (AND (EQ ERRCODE (QUOTE STREAM.LOST)) (SETQ POS (STKPOS (FUNCTION COURIER.CALL)))) then (BLOCK 500) (RETFROM POS (QUOTE (ERROR STREAM.LOST)) T) else (\SPP.DEFAULT.ERRORHANDLER STREAM ERRCODE))))
)
(\NSMAIL.SIGNAL.ERROR
(LAMBDA (ERROR MAILBOX PROGRAM PROCEDURE) (* ; "Edited 9-Sep-88 12:37 by bvm") (* ;; "Called when we get an error on an NS mail courier call. If stream lost, then tries to reestablish the connection, returning a new stream on success.") (if (EQ (CADR ERROR) (QUOTE STREAM.LOST)) then (PRINTOUT PROMPTWINDOW T "Lost NS mail connection, trying to reestablish...") (LET ((STREAM (\NSMAIL.COURIER.OPEN (create NSADDRESS using (SPP.DESTADDRESS (fetch NSMAILSTREAM of MAILBOX)) NSSOCKET ← 0)))) (if STREAM then (PRINTOUT PROMPTWINDOW "done.") (replace NSMAILSTREAM of MAILBOX with STREAM) else (PRINTOUT PROMPTWINDOW "failed.") (ERROR "NS mail connection lost, can't reestablish"))) else (COURIER.SIGNAL.ERROR PROGRAM PROCEDURE ERROR)))
)
)
(* ; "Close/flush protocol")
(DEFINEQ
(NS.CLOSEMAILBOX
(LAMBDA (MAILBOX FLUSH?) (* bvm%: "22-May-85 12:58") (PROG ((STATE (fetch NSMAILSTATE of MAILBOX)) RESULT) (COND (FLUSH? (* ; "Mark everything either deleted or seen") (for E in (fetch NSMAILENVELOPES of MAILBOX) bind START STATUS do (COND ((NEQ (CADR E) STATUS) (COND (START (\NSMAIL.CHANGE.STATUS MAILBOX START (SUB1 (CAR E)) STATUS))) (SETQ START (CAR E)) (SETQ STATUS (CADR E)))) finally (COND (START (\NSMAIL.CHANGE.STATUS MAILBOX START (fetch NSMAILLASTINDEX of MAILBOX) STATUS)))) (COND ((AND (LISTP (SETQ RESULT (COURIER.CALL (fetch NSMAILSTREAM of MAILBOX) (QUOTE INBASKET) (QUOTE LOGOFF) (fetch STATESESSION of STATE) (QUOTE RETURNERRORS)))) (NEQ (CAR RESULT) (QUOTE ERROR))) (SETQ RESULT T))) (replace STATESESSION of STATE with NIL) (* ;; "Once session is closed, can't say anything about first new message if there are any messages left, because someone in the meantime could delete them from another session") (replace STATEFIRSTNEW of STATE with NIL) (replace STATEOLDLAST of STATE with NIL) (* ; "But as long as we happen to have a Courier stream open to this host, let's establish a new session") (* (\NSMAIL.CHECK FOO (fetch STATENAME OF STATE) NIL NIL (fetch NSMAILSTREAM of MAILBOX) STATE)))) (CLOSEF (fetch NSMAILSTREAM of MAILBOX)) (RETURN RESULT)))
)
(\NSMAIL.CHANGE.STATUS
(LAMBDA (MAILBOX START END STATUS) (* bvm%: "14-Nov-84 23:28") (* ;;; "Change status of messages START thru END to be STATUS, which is either DELETE or KEEP. Returns number of messages kept") (PROG ((SESSION (fetch NSMAILSESSION of MAILBOX)) (STREAM (fetch NSMAILSTREAM of MAILBOX)) (RANGE (COURIER.CREATE (INBASKET . RANGE) FIRST ← START LAST ← END))) (RETURN (COND ((EQ STATUS (QUOTE DELETE)) (COURIER.CALL STREAM (QUOTE INBASKET) (QUOTE DELETE) SESSION RANGE) 0) (T (COURIER.CALL STREAM (QUOTE INBASKET) (QUOTE CHANGE.STATUS) SESSION RANGE (QUOTE KNOWN)) (ADD1 (IDIFFERENCE END START)))))))
)
)
(RPAQ? NSMAILDEBUGFLG)
(RPAQ? NSMAIL.LEAVE.ATTACHMENTS)
(ADDTOVAR \NSMAIL.GOOD.BODYTYPES 2 4)
(* ; "Handling attachments as a special kind of image object")
(DEFINEQ
(\MAILOBJ.CREATE
(LAMBDA (DATA TYPE ATTR.LENGTH NAME MORE.INFO) (* ; "Edited 29-Sep-87 17:52 by bvm:") (* ;; "Create a mail object encapsulating data (a core file in serialized file format). TYPE is the type of the serialized data.") (LET* ((TITLE (SELECTQ TYPE (REFERENCE (* ; "Reference to a file.") (if (NOT MORE.INFO) then (* ; "Try parsing the reference info--returns (REFERENCE info)") (LET* ((INFO (CADR (\MAILOBJ.PARSE.ATTRIBUTES DATA (LIST MAILOBJ.REFERENCE.FIELD)))) (TYPE (\TYPE.FROM.FILETYPE (CADR (ASSOC (QUOTE TYPE) INFO))))) (SETQ NAME (\MAILOBJ.NS.TO.LISP.NAME (CADR (ASSOC (QUOTE HOST) INFO)) (CADR (ASSOC (QUOTE DIRECTORY) INFO)) (CADR (ASSOC (QUOTE NAME) INFO)) (AND (NEQ (CADR (ASSOC (QUOTE FLAGS) INFO)) \MAILOBJ.REFERENCE.LAST.FILED) (CADR (ASSOC (QUOTE VERSION) INFO))) (EQ TYPE (QUOTE DIRECTORY)))) (SETQ MORE.INFO (BQUOTE (FILE.ID (\, (CADR (ASSOC (QUOTE FILE.ID) INFO))) TYPE (\, TYPE)))))) (CL:FORMAT NIL "Reference to ~A ~A" (\MAILOBJ.TYPE.NAME (LISTGET MORE.INFO (QUOTE TYPE))) NAME)) (if NAME then (CONCAT NAME " (" (\MAILOBJ.TYPE.NAME TYPE T) ")") else (\MAILOBJ.TYPE.NAME TYPE)))) (IMAGE (WINDOWPROP (TITLEDICONW NIL TITLE (AND (> (NCHARS TITLE) 20) (LET* ((FONT DEFAULTICONFONT) (SIZE (FONTPROP FONT (QUOTE SIZE)))) (* ; "Use a smaller font if available") (AND (> SIZE 8) (CAR (NLSETQ (FONTCOPY FONT (QUOTE SIZE) (- SIZE 2))))))) (QUOTE (0 . 0)) T NIL (QUOTE FILE)) (QUOTE ICONIMAGE)))) (* ; "Crude way of getting a bitmap with some text printed on it nicely") (IMAGEOBJCREATE (create MAILOBJ MAILOBJ.IMAGE ← IMAGE MAILOBJ.BOX ← (create IMAGEBOX XSIZE ← (BITMAPWIDTH IMAGE) YSIZE ← (BITMAPHEIGHT IMAGE) YDESC ← (LRSH (BITMAPHEIGHT IMAGE) 1) XKERN ← 0) MAILOBJ.TYPE ← TYPE MAILOBJ.DATA ← DATA MAILOBJ.ATTR.LENGTH ← ATTR.LENGTH MAILOBJ.NAME ← NAME MAILOBJ.INFO ← MORE.INFO) \MAILOBJ.IMAGEFNS)))
)
(\MAILOBJ.TYPE.NAME
(LAMBDA (TYPE SHORT) (* ; "Edited 29-Sep-87 14:21 by bvm:") (* ;; "Translate filing TYPE into a descriptive string, e.g., %"Interpress Document%". If SHORT is true, leave out %"Document%". If TYPE is numeric, it is rendered as %"Type nnn Document%".") (if (EQ TYPE (QUOTE DIRECTORY)) then (* ; "Viewpoint calls these %"folders%"") "Viewpoint Folder" else (CL:FORMAT NIL "~:[~:(~A~)~;Type ~D~]~@[ Document~]" (FIXP TYPE) TYPE (NOT SHORT))))
)
(\MAILOBJ.NS.TO.LISP.NAME
(LAMBDA (HOST DIRECTORY NAME VERSION DIRECTORYFLG) (* ; "Edited 29-Sep-87 17:54 by bvm:") (* ;; "Turn these pieces parsed out of a reference icon into a Lisp-style file name. Mainly this means turning the slashes into angles. This code is stolen from \NSFILING.FULLNAME, which is what we would use if it didn't require a filing session arg.") (LET ((PATHNAME (if DIRECTORYFLG then (CONCAT DIRECTORY "/" NAME (if (AND VERSION (NEQ VERSION 1)) then (CONCAT "!" VERSION) else "")) else DIRECTORY)) FILENAME DIRLST FULLNAME FUNNYCHAR DOTSEEN QUOTEDDIRS) (for I from 1 bind CH (START ← 1) while (SETQ CH (NTHCHARCODE PATHNAME I)) do (SELCHARQ CH (%' (* ; "quote mark, skip it and next char") (add I 1)) (/ (* ; "Directory marker") (push DIRLST (SUBSTRING PATHNAME START (SUB1 I))) (SETQ START (ADD1 I))) ((; %: < > } %]) (* ; "Funny characters that filing doesn't care about but we do -- need to quote these") (SETQ FUNNYCHAR T)) NIL) finally (push DIRLST (SUBSTRING PATHNAME START))) (* ;; "DIRLST is in reverse order now.") (for DIR in DIRLST do (push QUOTEDDIRS (COND (FUNNYCHAR (\NSFILING.ADDQUOTES DIR T)) (T DIR)) (QUOTE >))) (CONCATLIST (NCONC (LIST (QUOTE {) HOST "}<") QUOTEDDIRS (AND (NOT DIRECTORYFLG) (CONS (\NSFILING.ADDQUOTES NAME) (AND VERSION (LIST (if (STRPOS "." NAME) then ";" else ".;") VERSION))))))))
)
(\MAILOBJ.DISPLAY
(LAMBDA (OBJ STREAM) (* ; "Edited 29-Jun-87 17:34 by bvm:") (LET ((IMAGE (fetch MAILOBJ.IMAGE of (fetch OBJECTDATUM of OBJ)))) (* ; "Display the image, centered on the baseline") (BITBLT IMAGE NIL NIL STREAM (DSPXPOSITION NIL STREAM) (- (DSPYPOSITION NIL STREAM) (LRSH (BITMAPHEIGHT IMAGE) 1)))))
)
(\MAILOBJ.GET
(LAMBDA (STREAM TEXTSTREAM) (* ; "Edited 29-Sep-87 14:16 by bvm:") (DESTRUCTURING-BIND (LEN TYPE ATTR.LEN NAME . INFO) (READ STREAM FILERDTBL) (LET ((DATASTREAM (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH)))) (COPYBYTES STREAM DATASTREAM LEN) (\MAILOBJ.CREATE DATASTREAM TYPE ATTR.LEN NAME INFO))))
)
(\MAILOBJ.IMAGEBOX
(LAMBDA (OBJ) (* ; "Edited 29-Jun-87 16:57 by bvm:") (fetch MAILOBJ.BOX of (fetch OBJECTDATUM of OBJ)))
)
(\MAILOBJ.PUT
(LAMBDA (OBJ STREAM) (* ; "Edited 29-Sep-87 14:16 by bvm:") (LET* ((MAILOBJ (fetch OBJECTDATUM of OBJ)) (COREFILE (fetch MAILOBJ.DATA of MAILOBJ)) (END (GETEOFPTR COREFILE))) (LET ((*PRINT-BASE* 10) (*READTABLE FILERDTBL) (NAME (fetch MAILOBJ.NAME of MAILOBJ)) (INFO (fetch MAILOBJ.INFO of MAILOBJ))) (* ; "Make sure we can read it back.") (PRIN4 (LIST* END (fetch MAILOBJ.TYPE of MAILOBJ) (fetch MAILOBJ.ATTR.LENGTH of MAILOBJ) (AND (OR NAME INFO) (CONS NAME INFO))) STREAM)) (COPYBYTES COREFILE STREAM 0 END)))
)
(\MAILOBJ.INIT
(LAMBDA NIL (* ; "Edited 29-Jun-87 16:36 by bvm:") (SETQ \MAILOBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION \MAILOBJ.DISPLAY) (FUNCTION \MAILOBJ.IMAGEBOX) (FUNCTION \MAILOBJ.PUT) (FUNCTION \MAILOBJ.GET) (FUNCTION CL:IDENTITY) (FUNCTION \MAILOBJ.BUTTONEVENTFN))))
)
)
(DEFINEQ
(\MAILOBJ.BUTTONEVENTFN
(LAMBDA (OBJ WINDOWSTREAM SELECTION RELX RELY WINDOW TEXTSTREAM BUTTON) (* ; "Edited 13-Jun-88 19:10 by bvm") (if (.COPYKEYDOWNP.) then (* ; "There's more to copy selection than this") (AND NIL (LET ((NAME (fetch MAILOBJ.NAME of (IMAGEOBJPROP OBJ (QUOTE OBJECTDATUM))))) (AND NAME (BKSYSBUF NAME)))) elseif (IMAGEOBJPROP OBJ (QUOTE BUSY)) then (* ; "Busy") (PRINTOUT PROMPTWINDOW T "Attachment is busy") else (LET* ((MAILOBJ (IMAGEOBJPROP OBJ (QUOTE OBJECTDATUM))) (TYPE (fetch MAILOBJ.TYPE of MAILOBJ)) (REAL.TYPE (if (EQ TYPE (QUOTE REFERENCE)) then (LISTGET (fetch MAILOBJ.INFO of MAILOBJ) (QUOTE TYPE)) else TYPE)) (CMD (MENU (create MENU ITEMS ← (BQUOTE (("View as text" (QUOTE \MAILOBJ.VIEW) "View the attachment as raw text, using TEdit") ((\, (if (EQ TYPE (QUOTE REFERENCE)) then (* ; "Note that we are storing the reference itself, not the referenced file") "Store reference" else "Put to file")) (QUOTE \MAILOBJ.PUT.FILE) "Store the attachment in a file. This operation loses information unless the file is on an NS File Server.") (\,@ (AND (EQ REAL.TYPE (QUOTE INTERPRESS)) (QUOTE (("Send to Printer" (QUOTE \MAILOBJ.HARDCOPY) "Send the document to the printer of your choice."))))) (\,@ (AND (EQ TYPE (QUOTE DIRECTORY)) (QUOTE (("Expand folder" (QUOTE \MAILOBJ.EXPAND) "Extract the first-level subparts of the folder"))))) (\,@ (SELECTQ TYPE (REFERENCE (AND (GETD (QUOTE FILEBROWSER)) (EQ (NTHCHARCODE (fetch MAILOBJ.NAME of MAILOBJ) -1) (CHARCODE >)) (BQUOTE (("FileBrowse" (QUOTE \MAILOBJ.FB) "Invoke the File Browser on the referenced object"))))) NIL)))) CENTERFLG ← T)))) (if (NULL CMD) then (* ; "Nothing selected; allow TEdit to select") T else (* ; "Do the command in its own process so that the window can return to its more natural state (instead of severely clipped)") (ADD.PROCESS (LIST (FUNCTION \MAILOBJ.DO.COMMAND) (KWOTE CMD) (KWOTE OBJ) (KWOTE WINDOW) (KWOTE TEXTSTREAM)) (QUOTE NAME) (QUOTE MAILOBJ) (QUOTE RESTARTABLE) (QUOTE HARDRESET) (QUOTE BEFOREEXIT) (QUOTE DON'T)) (* ; "Return DON'T so that the window doesn't pop on top to select") (QUOTE DON'T)))))
)
(\MAILOBJ.DO.COMMAND
(LAMBDA (CMD OBJ WINDOW TEXTSTREAM) (* ; "Edited 3-Jul-87 17:51 by bvm:") (RESETLST (RESETSAVE (IMAGEOBJPROP OBJ (QUOTE BUSY) T) (LIST (QUOTE IMAGEOBJPROP) OBJ (QUOTE BUSY) NIL)) (CL:FUNCALL CMD OBJ WINDOW TEXTSTREAM)))
)
(\MAILOBJ.HARDCOPY
(LAMBDA (OBJ WINDOW) (* ; "Edited 11-Dec-87 16:01 by bvm:") (* ;; "Hardcopy the attachment in MAILOBJ. WINDOW is the window in which we are viewing it (not currently used).") (LET* ((*UPPER-CASE-FILE-NAMES* NIL) (PRINTER (GetPrinterName)) (MAILOBJ (IMAGEOBJPROP OBJ (QUOTE OBJECTDATUM))) (REFP (EQ (fetch MAILOBJ.TYPE of MAILOBJ) (QUOTE REFERENCE))) ATTRIBUTES PRINTRESULTS NAME DATA) (if (NULL PRINTER) then (* ; "abort") NIL elseif (NOT (STRPOS ":" PRINTER)) then (* ; "not ns") (PRINTOUT PROMPTWINDOW T PRINTER " is not an Interpress printer") else (SETQ PRINTER (GETNSPRINTER PRINTER)) (if REFP then (NSPRINT PRINTER (SETQ NAME (fetch MAILOBJ.NAME of MAILOBJ))) else (* ; "Have to do this by hand, since we don't have a nice standalone stream") (SETQ ATTRIBUTES (\MAILOBJ.PARSE.ATTRIBUTES (SETQ DATA (fetch MAILOBJ.DATA of MAILOBJ)) (CONSTANT (BQUOTE ((DOCUMENT.NAME (\,@ (CDR (ASSOC (QUOTE NAME) \NSFILING.ATTRIBUTES)))) (DOCUMENT.CREATION.DATE (\,@ (CDR (ASSOC (QUOTE CREATED.ON) \NSFILING.ATTRIBUTES))))))))) (SETQ NAME (LISTGET ATTRIBUTES (QUOTE DOCUMENT.NAME))) (* ; "Parse out the name and creation date, and use them for the document name/date") (SETQ PRINTRESULTS (\NSPRINT.INTERNAL PRINTER ATTRIBUTES (FUNCTION (LAMBDA (DATASTREAM) (\MAILOBJ.COPY.BODY DATA DATASTREAM (fetch MAILOBJ.ATTR.LENGTH of MAILOBJ)) NIL)))) (COND ((AND PRINTRESULTS NSPRINT.WATCHERFLG) (* ; "Set up a 'watchdog' process to keep the guy informed of the print job's status") (if (GETD (FUNCTION \NSPRINT.WATCH.JOB)) then (\NSPRINT.WATCH.JOB PRINTRESULTS PRINTER NAME) else (* ; "Old way for Lyric--add a distinct process") (ADD.PROCESS (LIST (FUNCTION \NSPRINT.WATCHDOG) (KWOTE PRINTRESULTS) (KWOTE PRINTER) (KWOTE NAME)) (QUOTE NAME) (PACK* (fetch NSOBJECT of (CAR PRINTER)) " WATCHER") (QUOTE AFTEREXIT) (QUOTE DELETE)))))) (PRINTOUT PROMPTWINDOW T NAME " sent to " (fetch NSOBJECT of (CAR PRINTER))))))
)
(\MAILOBJ.FB
(LAMBDA (OBJ WINDOW) (* ; "Edited 29-Sep-87 17:33 by bvm:") (* ;; "Invoke the File Browser on the referenced object") (FILEBROWSER (fetch MAILOBJ.NAME of (IMAGEOBJPROP OBJ (QUOTE OBJECTDATUM)))))
)
(\MAILOBJ.PUT.FILE
(LAMBDA (OBJ WINDOW) (* ; "Edited 14-Jun-88 11:22 by bvm") (* ;; "Store the attachment of MAILOBJ as file of user's choosing. Prompt for file name. If it's on an NS directory, we can deserialize and thus preserve the whole thing.") (LET* ((MAILOBJ (IMAGEOBJPROP OBJ (QUOTE OBJECTDATUM))) (DATA (fetch MAILOBJ.DATA of MAILOBJ)) (PW (CREATEW (create REGION LEFT ← LASTMOUSEX BOTTOM ← LASTMOUSEY WIDTH ← (WINDOWPROP WINDOW (QUOTE WIDTH)) HEIGHT ← (HEIGHTIFWINDOW (TIMES 4 (FONTPROP DEFAULTFONT (QUOTE HEIGHT))) NIL 8)) NIL 8)) FILE DEVICE) (if (NULL (SETQ FILE (TTYINPROMPTFORWORD "Put attachment to file: " NIL NIL PW NIL (QUOTE TTY) (CHARCODE (CR))))) then (PRINTOUT PW "...aborted") elseif (NULL (SETQ DEVICE (\GETDEVICEFROMNAME FILE T))) then (PRINTOUT PW T "No such server/device") else (ALLOW.BUTTON.EVENTS) (PRINTOUT PW " ... ") (if (SETQ FILE (if (EQ (fetch OPENFILE of DEVICE) (FUNCTION \NSFILING.OPENFILE)) then (* ; "NS device. Really need better test than this.") (SETFILEPTR DATA 0) (LET ((*UPPER-CASE-FILE-NAMES* NIL)) (DECLARE (CL:SPECIAL *UPPER-CASE-FILE-NAMES*)) (* ; "Get name pretty") (\NSFILING.DESERIALIZE FILE DATA DEVICE)) else (SETQ FILE (OPENSTREAM FILE (QUOTE OUTPUT) (QUOTE NEW) (BQUOTE ((TYPE (\, (fetch MAILOBJ.TYPE of MAILOBJ))) (SEQUENTIAL T))))) (PRINTOUT PW "(some attributes will be lost) ") (\MAILOBJ.COPY.BODY DATA FILE (fetch MAILOBJ.ATTR.LENGTH of MAILOBJ) PW) (CLOSEF FILE))) then (PRINTOUT PW T FILE " written.") else (PRINTOUT PW "failed")))))
)
(\MAILOBJ.VIEW
(LAMBDA (OBJ WINDOW) (* ; "Edited 3-Dec-87 16:36 by bvm:") (* ;; "View the text of the attachment. This is often enough to tell you whether you want to bother doing something more exciting with it.") (RESETLST (LET* ((MAILOBJ (IMAGEOBJPROP OBJ (QUOTE OBJECTDATUM))) (TYPE (fetch MAILOBJ.TYPE of MAILOBJ)) (REFP (EQ TYPE (QUOTE REFERENCE))) (WREG (WINDOWREGION WINDOW)) PROPS W SUBJECT START DATA) (if REFP then (SETQ SUBJECT (fetch MAILOBJ.NAME of MAILOBJ)) (SETQ TYPE (LISTGET (fetch MAILOBJ.INFO of MAILOBJ) (QUOTE TYPE))) (SETQ START NIL) else (SETQ DATA (fetch MAILOBJ.DATA of MAILOBJ)) (SETQ SUBJECT (CADR (\MAILOBJ.PARSE.ATTRIBUTES DATA (CONSTANT (LIST (ASSOC (QUOTE NAME) \NSFILING.ATTRIBUTES)))))) (SETQ START (fetch MAILOBJ.ATTR.LENGTH of MAILOBJ))) (SETQ W (CREATEW (create REGION using WREG LEFT ← (+ (fetch (REGION LEFT) of WREG) (if (> (+ (fetch (REGION LEFT) of WREG) (fetch (REGION WIDTH) of WREG) MAILOBJ.WINDOWOFFSET) SCREENWIDTH) then (- MAILOBJ.WINDOWOFFSET) else MAILOBJ.WINDOWOFFSET)) BOTTOM ← (- (fetch (REGION BOTTOM) of WREG) (if (< (- (fetch (REGION BOTTOM) of WREG) MAILOBJ.WINDOWOFFSET) 0) then (- MAILOBJ.WINDOWOFFSET) else MAILOBJ.WINDOWOFFSET))) (CONCAT "Attachment: " SUBJECT))) (* ; "Make window slightly overlapping display window") (if (NEQ TYPE (QUOTE TEDIT)) then (* ; "TEdit's not so good on binary files, so just pull out the text.") (LET ((COMPACTDATA (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH)))) (if REFP then (RESETSAVE NIL (LIST (QUOTE CLOSEF) (SETQ DATA (OPENSTREAM SUBJECT (QUOTE INPUT) NIL (QUOTE ((SEQUENTIAL T))))))) else (* ; "First extract possible text from unknown attributes.") (SETFILEPTR DATA 4) (* ; "Skip the version number (LONGCARDINAL). Next comes SEQUENCE Filing.Attribute") (to (\WIN DATA) bind X TYPE do (SETQ TYPE (COURIER.READ DATA NIL (QUOTE LONGCARDINAL))) (if (find X in \NSMAIL.ATTRIBUTES suchthat (EQ (CADR X) TYPE)) then (* ; "Something of known type--it's probably in the message header. Just skip it") (COURIER.SKIP.SEQUENCE DATA NIL (QUOTE UNSPECIFIED)) else (* ; "Unknown attribute--extract text from it in case it's interesting. Next word is a count of words") (\MAILOBJ.EXTRACT.TEXT DATA COMPACTDATA (UNFOLD (\WIN DATA) BYTESPERWORD))))) (\MAILOBJ.EXTRACT.TEXT DATA COMPACTDATA (- (\GETEOFPTR DATA) (GETFILEPTR DATA))) (SETQ DATA COMPACTDATA) (SETQ START NIL) (SETQ PROPS (LIST (QUOTE FONT) LAFITEDISPLAYFONT)))) (OPENTEXTSTREAM DATA W START (AND START (GETEOFPTR DATA)) (APPEND PROPS (QUOTE (PROMPTWINDOW DON'T)))))))
)
(\MAILOBJ.COPY.BODY
(LAMBDA (INSTREAM OUTSTREAM START PW) (* ; "Edited 6-Jul-87 12:47 by bvm:") (SETFILEPTR INSTREAM START) (\NSMAIL.READ.SERIALIZED.CONTENT INSTREAM OUTSTREAM) (if (NEQ (\WIN INSTREAM) 0) then (PRINTOUT (OR PW PROMPTWINDOW) T "Warning: Attachment had children, which were not processed.")))
)
(\MAILOBJ.EXPAND
(LAMBDA (OBJ WINDOW TEXTSTREAM) (* ; "Edited 6-Jul-87 15:14 by bvm:") (LET* ((MAILOBJ (IMAGEOBJPROP OBJ (QUOTE OBJECTDATUM))) (DATA (fetch MAILOBJ.DATA of MAILOBJ)) (START (fetch MAILOBJ.ATTR.LENGTH of MAILOBJ)) (IMAGEPOS (TEDIT.FIND.OBJECT TEXTSTREAM OBJ)) CHILDREN SUBDATA SUBSTART TYPE PARSE) (SETFILEPTR DATA START) (\NSMAIL.READ.SERIALIZED.CONTENT DATA (OPENSTREAM (QUOTE {NULL}) (QUOTE OUTPUT))) (* ; "Skip over the body of the folder (should be empty, actually)") (to (\WIN DATA) do (* ; "copy each child into its own image obj") (SETQ SUBDATA (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))) (COURIER.WRITE SUBDATA \SERIALIZED.FILE.VERSION NIL (QUOTE LONGCARDINAL)) (SETQ SUBSTART (\MAILOBJ.COPY.CHILD DATA SUBDATA)) (* ; "Copy recursive part") (SETQ PARSE (\MAILOBJ.PARSE.ATTRIBUTES SUBDATA (CONSTANT (LIST (ASSOC (QUOTE FILE.TYPE) \NSFILING.ATTRIBUTES) (ASSOC (QUOTE NAME) \NSFILING.ATTRIBUTES))))) (SETQ TYPE (LISTGET PARSE (QUOTE FILE.TYPE))) (push CHILDREN (\MAILOBJ.CREATE SUBDATA (AND TYPE (\TYPE.FROM.FILETYPE TYPE)) SUBSTART (LISTGET PARSE (QUOTE NAME)))) (* ; "Create object, parsing the type field out of the raw data")) (add IMAGEPOS 1) (for C in CHILDREN do (* ; "Insert the objects following obj in reverse order of creation, so they come out right in the end.") (TEDIT.INSERT.OBJECT C TEXTSTREAM IMAGEPOS))))
)
(\MAILOBJ.COPY.CHILD
(LAMBDA (INSTREAM OUTSTREAM) (* ; "Edited 6-Jul-87 14:41 by bvm:") (* ;; "This is the counterpart to \nsmail.read.serialized.tree, except that it copies the data as it parses it, rather than interpreting it. Returns file pointer of the start of the main child's data section.") (* ;; "We are parsing here the recursive part of Filing.SerializedFile: SerializedTree, which consists of: Sequence of Attribute; Content; children = Sequence of SerializedTree") (LET (ATTRLENGTH SUBSTART NCHILDREN LASTSEGMENT?) (\WOUT OUTSTREAM (SETQ ATTRLENGTH (\WIN INSTREAM))) (* ; "number of attributes") (to ATTRLENGTH do (RPTQ 4 (\BOUT OUTSTREAM (\BIN INSTREAM))) (* ; "Copy attribute type (longcardinal)") (\MAILOBJ.COPY.SEQUENCE INSTREAM OUTSTREAM) (* ; "Copy attribute value (sequence unspecified)")) (SETQ SUBSTART (GETFILEPTR OUTSTREAM)) (* ;; "Now copy the body, which is StreamOfUnspecified followed by lastByteIsSignficant boolean") (do (\WOUT OUTSTREAM (SETQ LASTSEGMENT? (\WIN INSTREAM))) (* ; "1 => this is last segment") (\MAILOBJ.COPY.SEQUENCE INSTREAM OUTSTREAM) (* ; "Copy the sequence") repeatuntil (NEQ LASTSEGMENT? 0) finally (\WOUT OUTSTREAM (\WIN INSTREAM)) (* ; "Copy lastByteIsSignficant boolean")) (\WOUT OUTSTREAM (SETQ NCHILDREN (\WIN INSTREAM))) (to NCHILDREN do (\MAILOBJ.COPY.CHILD INSTREAM OUTSTREAM)) SUBSTART))
)
(\MAILOBJ.COPY.SEQUENCE
(LAMBDA (INSTREAM OUTSTREAM) (* ; "Edited 6-Jul-87 14:37 by bvm:") (* ;; "Copy a Sequence of Unspecified from in to out.") (LET ((SEQLENGTH (\WIN INSTREAM))) (\WOUT OUTSTREAM SEQLENGTH) (* ; "Representation is sequence length (word) followed by that many words") (RPTQ (UNFOLD SEQLENGTH BYTESPERWORD) (\BOUT OUTSTREAM (\BIN INSTREAM)))))
)
(\MAILOBJ.EXTRACT.TEXT
(LAMBDA (DATA OUTSTREAM LEN) (* ; "Edited 29-Sep-87 14:59 by bvm:") (* ;; "Copy LEN bytes from the stream DATA to OUTSTREAM, where all the runs of non-printing characters are replaced by some small number of ugly characters that won't upset tedit.") (bind CH (SKIPPING ← -1) to LEN do (if (OR (>= (SETQ CH (\BIN DATA)) 127) (AND (< CH (CHARCODE SPACE)) (SELCHARQ CH ((TAB CR LF) NIL) T))) then (if (EVENP (add SKIPPING 1) 16) then (BOUT OUTSTREAM MAILOBJ.SKIPCHAR)) else (SETQ SKIPPING -1) (BOUT OUTSTREAM CH))) OUTSTREAM)
)
(\MAILOBJ.PARSE.ATTRIBUTES
(LAMBDA (DATA FIELDS) (* ; "Edited 6-Jul-87 15:12 by bvm:") (* ;; "Parse the SUBJECT field out of the serialized stream DATA. FIELDS is in the format of \nsfiling.attributes entries") (SETFILEPTR DATA 4) (* ; "Skip the version number (LONGCARDINAL). Next comes SEQUENCE Filing.Attribute") (to (\WIN DATA) bind (CNT ← (LENGTH FIELDS)) X TYPE do (SETQ TYPE (COURIER.READ DATA NIL (QUOTE LONGCARDINAL))) (if (find old X in FIELDS suchthat (EQ (CADR X) TYPE)) then (* ; "X = (type number interpretation)") (\WIN DATA) (push $$VAL (CAR X) (COURIER.READ DATA NIL (CADDR X))) (if (<= (SETQ CNT (SUB1 CNT)) 0) then (* ;; "Found them all") (RETURN $$VAL)) else (COURIER.SKIP.SEQUENCE DATA NIL (QUOTE UNSPECIFIED)))))
)
)
(ADDTOVAR FILING.TYPES (VIEWPOINT 4353) (RES 4428) (XEROX860 5120) (REFERENCE 4427))
(RPAQQ MAILOBJ.REFERENCE.FIELD (REFERENCE 4421 (NAMEDRECORD (FILE.ID (FILING . FILE.ID)) (SERVICE NSNAME) (NIL (ARRAY 6 UNSPECIFIED)) (HOST STRING) (DIRECTORY STRING) (NAME STRING) (TYPE (FILING . ATTRIBUTE.TYPE)) (NIL UNSPECIFIED) (NIL UNSPECIFIED) (VERSION CARDINAL) (FLAGS CARDINAL))))
(RPAQ? MAILOBJ.WINDOWOFFSET 16)
(RPAQ? MAILOBJ.SKIPCHAR 0)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RECORD MAILOBJ (MAILOBJ.IMAGE MAILOBJ.BOX MAILOBJ.TYPE MAILOBJ.DATA MAILOBJ.ATTR.LENGTH MAILOBJ.NAME . MAILOBJ.INFO)
)
)
(DECLARE%: EVAL@COMPILE
(RPAQQ \MAILOBJ.REFERENCE.LAST.FILED 8192)
(CONSTANTS \MAILOBJ.REFERENCE.LAST.FILED)
)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(\MAILOBJ.INIT)
(AND (EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSRANDOM))
)
(* ; "sending mail")
(DEFINEQ
(\NSMAIL.SEND.PARSE
(LAMBDA (MSG EDITORWINDOW) (* ; "Edited 5-May-88 13:05 by bvm") (PROG ((SENDER (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of *LAFITE-MODE-DATA*)) RECIPIENTS MSGFIELDS FORMATTEDP HEADEREOF INTERESTINGFIELDS 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) ((To cc From Reply-to) (push INTERESTINGFIELDS (RPLACD PAIR (\NSMAIL.PARSE (CDR PAIR) SENDER EDITORWINDOW))) (SELECTQ (CAR PAIR) ((To cc) (SETQ RECIPIENTS (COND (RECIPIENTS (NS.REMOVEDUPLICATES (APPEND (CDR PAIR) RECIPIENTS))) (T (CDR PAIR))))) (PROGN (* ; "Might want to check validity of From and Reply-to") NIL))) ((Subject In-Reply-to) (RPLACD PAIR (COND ((CDDR PAIR) (CONCATLIST (CDR PAIR))) (T (CADR PAIR)))) (* ; "Make one string") (push INTERESTINGFIELDS PAIR) (COND ((EQ (CAR PAIR) (QUOTE Subject)) (SETQ SUBJECT (CDR PAIR))))) (Date (\SENDMESSAGEFAIL EDITORWINDOW "User-supplied Date not allowed")) (Sender (\SENDMESSAGEFAIL EDITORWINDOW "User-supplied Sender not allowed")) (Format (SETQ FORMATTEDP (SELECTQ (CADR PAIR) (TEDIT T) NIL))) NIL)) (COND ((NULL RECIPIENTS) (\SENDMESSAGEFAIL EDITORWINDOW "No recipients!"))) (OR FORMATTEDP (SELECTQ (\LAFITE.CHOOSE.MSG.FORMAT MSG NIL EDITORWINDOW) (TEDIT (SETQ FORMATTEDP T)) (NIL (* ; "Aborted") (RETURN)) NIL)) (RETURN (create NSMAILPARSE NSPSUBJECT ← SUBJECT NSPRECIPIENTS ← RECIPIENTS NSPSTART ← HEADEREOF NSPFIELDS ← INTERESTINGFIELDS NSPFORMATTED ← FORMATTEDP))))
)
(\NSMAIL.PARSE
(LAMBDA (FIELD DEFAULTDOMAIN EDITWINDOW) (* bvm%: " 3-Jul-84 16:21") (NS.REMOVEDUPLICATES (COND ((LISTP FIELD) (for PIECE in FIELD join (\NSMAIL.PARSE1 PIECE DEFAULTDOMAIN EDITWINDOW))) (T (\NSMAIL.PARSE1 FIELD DEFAULTDOMAIN EDITWINDOW)))))
)
(\NSMAIL.PARSE1
(LAMBDA (FIELD DEFAULTDOMAIN EDITWINDOW) (* bvm%: " 3-Jul-84 16:26") (COND (FIELD (bind ADDR (START ← 1) COMMA when (PROGN (SETQ ADDR (SUBSTRING FIELD START (COND ((SETQ COMMA (STRPOS (QUOTE %,) FIELD START)) (SUB1 COMMA))))) (do (* ; "Strip leading blanks") (SELCHARQ (CHCON1 ADDR) ((SPACE TAB) (GNC ADDR)) (RETURN))) (do (* ; "Strip trailing blanks") (SELCHARQ (NTHCHARCODE ADDR -1) ((SPACE TAB) (GLC ADDR)) (RETURN))) (NEQ (NCHARS ADDR) 0)) collect (PARSE.NSNAME ADDR NIL DEFAULTDOMAIN) repeatwhile (COND (COMMA (SETQ START (ADD1 COMMA))))))))
)
(NS.REMOVEDUPLICATES
(LAMBDA (LST) (* ; "Edited 6-Jun-88 13:38 by bvm") (CL:REMOVE-DUPLICATES LST :TEST (FUNCTION EQUAL.CH.NAMES)))
)
(\NSMAIL.SEND
(LAMBDA (MSG PARSE EDITORWINDOW ABORTWINDOW) (* ; "Edited 18-Jul-88 12:36 by bvm") (* ;;; "MSG is the entire text of the message -- RECIPIENTS is a parsed list of recipients") (DECLARE (SPECVARS MSG START MSGFIELDS EDITORWINDOW ABORTWINDOW FORMATSTREAM)) (* ; "For \NSMAIL.SEND.MESSAGE.CONTENT") (RESETLST (PROG ((PWINDOW (AND EDITORWINDOW (GETPROMPTWINDOW EDITORWINDOW))) (RECIPIENTS (fetch NSPRECIPIENTS of PARSE)) (START (fetch NSPSTART of PARSE)) (MSGFIELDS (fetch NSPFIELDS of PARSE)) (CREDENTIALS (fetch (LAFITEMODEDATA CREDENTIALS) of *LAFITE-MODE-DATA*)) FORMATSTREAM COURIERSTREAM DATASTREAM RECIPIENTSCHECK SENDRESULT SENDERFIELD DATEFIELD TYPE MAILDROP RESULTS) (COND ((AND (fetch NSPFORMATTED of PARSE) (TEDIT.FORMATTEDFILEP MSG)) (* ; "Message is formatted, so get info. Have to exclude header, since it is not sent.") (SETQ MSG (COPYTEXTSTREAM MSG)) (TEDIT.DELETE MSG 1 START) (SETQ FORMATSTREAM (COERCETEXTOBJ MSG (QUOTE SPLIT))) (* ; "Get (body . formatting)") (SETQ MSG (OPENSTREAM (CAR FORMATSTREAM) (QUOTE INPUT))) (SETQ FORMATSTREAM (OPENSTREAM (CDR FORMATSTREAM) (QUOTE INPUT))) (COND ((> (+ (GETEOFPTR MSG) (GETEOFPTR FORMATSTREAM) START (TIMES (LENGTH RECIPIENTS) 42) (NCHARS (fetch (LAFITEMODEDATA FULLUSERNAME) of *LAFITE-MODE-DATA*)) LAFITESTAMPLENGTH (CONSTANT (NCHARS (CONCAT "Date: " (DATE (DATEFORMAT TIME.ZONE)) "Sender: ")))) 99999) (* ;; "Message too long. Test conservatively, assuming every recipient's name was defaulted in the actual text given") (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW "Message too long to send formatted. Either break it up or send it as plain text.")))) (SETQ START 0)) ((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 START)) (SETQ START 0))) (COND ((NULL (\LAFITE.GET.USER.DATA)) (* ; "\LAFITE.GET.USER.DATA didn't make it -- get out") (RETURN))) (COND (PWINDOW (CLEARW PWINDOW) (CL:FORMAT PWINDOW "Delivering ~:[~;formatted ~]to ~D recipient~:P" FORMATSTREAM (LENGTH RECIPIENTS)))) (COND ((NULL (SETQ MAILDROP (\NSMAIL.FINDSERVER))) (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW "Couldn't find a mail drop")))) (to 3 until (SETQ COURIERSTREAM (COURIER.OPEN MAILDROP NIL T (QUOTE NSMAILER))) do (* ; "loop 3 times trying to start this send") (DISMISS 1000)) (COND ((NULL COURIERSTREAM) (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW "Couldn't connect to a maildrop")))) (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE) COURIERSTREAM)) (AND PWINDOW (printout PWINDOW (QUOTE |...|))) (SETQ RESULTS (COURIER.CALL COURIERSTREAM (QUOTE MAILTRANSPORT) (QUOTE POST) (CAR CREDENTIALS) (CDR CREDENTIALS) RECIPIENTS NIL T \NSMAIL.CTSTANDARD.MESSAGE NIL (FUNCTION \NSMAIL.SEND.MESSAGE.CONTENT) (QUOTE RETURNERRORS))) (COND ((EQ (CAR (LISTP RESULTS)) (QUOTE ERROR)) (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW (SELECTQ (CADR RESULTS) (INVALID.RECIPIENTS (\LAFITE.INVALID.RECIPIENTS (CDDR RESULTS))) (MKSTRING (CDR RESULTS))))))) (AND NSMAILDEBUGFLG (printout PROMPTWINDOW T "Post results: " RESULTS)) (RETURN (LENGTH RECIPIENTS)))))
)
(\NSMAIL.SEND.MESSAGE.CONTENT
(LAMBDA (DATASTREAM) (* ; "Edited 5-May-88 13:06 by bvm") (DECLARE (USEDFREE MSG START MSGFIELDS EDITORWINDOW ABORTWINDOW FORMATSTREAM)) (* ; "From \NSMAIL.SEND") (* ;; "Transmits the bulkdata portion of the message") (PROG ((SENDER (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of *LAFITE-MODE-DATA*)) (BODYLENGTH (IDIFFERENCE (GETEOFPTR MSG) START)) NOTEP) (* ;; "Want to send a serialized file on DATASTREAM --- version plus SerializedTree. See \NSMAIL.READ.SERIALIZED.TREE") (COURIER.WRITE DATASTREAM \SERIALIZED.FILE.VERSION NIL (QUOTE LONGCARDINAL)) (* ; "Version") (* ;; "Now comes (SEQUENCE ATTRIBUTE); the attributes we want to send are those in MSGFIELDS plus Date, From, BodyType and Note") (\WOUT DATASTREAM (IPLUS (LENGTH MSGFIELDS) (COND (FORMATSTREAM (* ; "Also a LispFormatting item") 1) (T 0)) (COND ((SETQ NOTEP (ILESSP BODYLENGTH \NSMAIL.MAX.NOTE.LENGTH)) (* ; "Send body as Note attribute") (SETQ BODYLENGTH 0) 1) (T (* ; "Send as body") 0)) 4)) (* ; "Number of attributes") (\NSMAIL.WRITE.ATTRIBUTE DATASTREAM (QUOTE Date) (IDATE)) (COND ((ASSOC (QUOTE From) MSGFIELDS) (\NSMAIL.WRITE.ATTRIBUTE DATASTREAM (QUOTE Sender) SENDER)) (T (\NSMAIL.WRITE.ATTRIBUTE DATASTREAM (QUOTE From) (LIST SENDER)))) (for PAIR in MSGFIELDS do (\NSMAIL.WRITE.ATTRIBUTE DATASTREAM (CAR PAIR) (CDR PAIR))) (\NSMAIL.WRITE.ATTRIBUTE DATASTREAM (QUOTE BodyType) (COND (NOTEP \NSMAIL.EMPTY.BODYTYPE) (T \NSMAIL.TEXT.BODYTYPE))) (\NSMAIL.WRITE.ATTRIBUTE DATASTREAM (QUOTE BodySize) BODYLENGTH) (COND ((AND ABORTWINDOW (WINDOWPROP ABORTWINDOW (QUOTE ABORT))) (ERROR!))) (COND (NOTEP (\NSMAIL.SEND.STREAM.AS.STRING MSG DATASTREAM START (\NSMAIL.ATTRIBUTE.TYPE Note)))) (COND (FORMATSTREAM (\NSMAIL.SEND.STREAM.AS.STRING FORMATSTREAM DATASTREAM 0 (COND (NOTEP (* ; "When everyone is in possession of Lafite that reads new LispFormatting then get rid of this old one") (\NSMAIL.ATTRIBUTE.TYPE OldLispFormatting)) (T (\NSMAIL.ATTRIBUTE.TYPE LispFormatting)))))) (PROGN (* ; "Now the content of the serialized tree, first part of which is a Bulkdata.StreamOfUnspecified") (COND (NOTEP (* ; "Null content") (\WOUT DATASTREAM 1) (* ; "Last segment") (\WOUT DATASTREAM 0) (* ; "Empty sequence")) (T (COURIER.WRITE.STREAM.UNSPECIFIED DATASTREAM MSG START (GETEOFPTR MSG))))) (PROGN (* ; "Finally, the last of the serialized tree") (\WOUT DATASTREAM (LOGXOR (LOGAND BODYLENGTH 1) 1)) (* ; "Last byte significant (even number of bytes)") (\WOUT DATASTREAM 0) (* ; "No children")) (COND ((NULL ABORTWINDOW)) ((WINDOWPROP ABORTWINDOW (QUOTE ABORT)) (ERROR!)) (T (* ; "Too late to abort now") (DELETEMENU (CAR (WINDOWPROP ABORTWINDOW (QUOTE MENU))) NIL ABORTWINDOW))) (RETURN NIL)))
)
(COURIER.WRITE.STREAM.UNSPECIFIED
(LAMBDA (OUTSTREAM INSTREAM START END) (* bvm%: "16-May-85 14:24") (* ;;; "Copies INSTREAM from START to END onto OUTSTREAM in the form of Bulkdata.StreamOfUnspecified --- format is one or more concatenations of {lastSegmentP,SequenceUnspecified} --- returns T if even number of bytes written, NIL if odd") (LET (LENGTH) (COND (END (SETFILEPTR INSTREAM START) (SETQ LENGTH (IDIFFERENCE (COND ((EQ END -1) (GETEOFPTR INSTREAM)) (T END)) START))) (START (SETQ LENGTH START)) (T (SETQ LENGTH (IDIFFERENCE (GETEOFPTR INSTREAM) (GETFILEPTR INSTREAM))))) (while (GREATERP LENGTH MAX.BULK.SEGMENT.LENGTH) do (\WOUT OUTSTREAM 0) (* ; "Not last segment") (\WOUT OUTSTREAM (FOLDHI MAX.BULK.SEGMENT.LENGTH BYTESPERWORD)) (* ; "Word length of this segment") (COPYBYTES INSTREAM OUTSTREAM MAX.BULK.SEGMENT.LENGTH) (SETQ LENGTH (IDIFFERENCE LENGTH MAX.BULK.SEGMENT.LENGTH))) (\WOUT OUTSTREAM 1) (* ; "Last segment") (\WOUT OUTSTREAM (FOLDHI LENGTH BYTESPERWORD)) (* ; "Word length of this segment") (COPYBYTES INSTREAM OUTSTREAM LENGTH) (COND ((EVENP LENGTH) T) (T (* ; "Garbage last byte") (\BOUT OUTSTREAM 0) NIL))))
)
(\NSMAIL.SEND.STREAM.AS.STRING
(LAMBDA (INSTREAM OUTSTREAM START ATTRIBUTE) (* bvm%: "30-Jul-84 15:31") (* ;; "Writes the contents of INSTREAM, beginning at byte START, to OUTSTREAM in the form of a Filing Attribute whose type is ATTRIBUTE and whose value is a string") (PROG ((EOF (GETEOFPTR INSTREAM)) LENGTH) (COURIER.WRITE OUTSTREAM ATTRIBUTE NIL (QUOTE LONGCARDINAL)) (\WOUT OUTSTREAM (ADD1 (FOLDHI (SETQ LENGTH (IDIFFERENCE EOF START)) BYTESPERWORD))) (* ; "Sequence length") (\WOUT OUTSTREAM LENGTH) (* ; "String length") (COPYBYTES INSTREAM OUTSTREAM START EOF) (COND ((ODDP LENGTH) (\BOUT OUTSTREAM 0)))))
)
(\NSMAIL.WRITE.ATTRIBUTE
(LAMBDA (STREAM TYPE VALUE) (* bvm%: " 1-Jul-84 17:11") (PROG ((TYPEINFO (ASSOC TYPE \NSMAIL.ATTRIBUTES))) (if TYPEINFO then (COURIER.WRITE STREAM (CADR TYPEINFO) NIL (QUOTE LONGCARDINAL)) (* ; "Type code") (COURIER.WRITE.SEQUENCE.UNSPECIFIED STREAM VALUE (QUOTE MAILTRANSPORT) (CADDR TYPEINFO)) else (HELP "Unknown mail attribute" TYPE))))
)
(\NSMAIL.FINDSERVER
(LAMBDA NIL (* bvm%: "14-Nov-84 23:47") (PROG ((NULL.AUTHENTICATOR (CONSTANT (COURIER.CREATE (AUTHENTICATION . CREDENTIALS) TYPE ← (QUOTE SIMPLE) VALUE ← NIL))) INFO) (RETURN (COND ((AND \NSMAIL.SERVER.CACHE (find ADDR in \NSMAIL.SERVER.CACHE suchthat (\NSMAIL.CHECKSERVER (COURIER.EXPEDITED.CALL ADDR \NSMAIL.SOCKET (QUOTE MAILTRANSPORT) (QUOTE SERVER.POLL) NULL.AUTHENTICATOR (QUOTE (0)) (QUOTE RETURNERRORS)))))) ((SETQ INFO (COURIER.BROADCAST.CALL \NSMAIL.SOCKET (QUOTE MAILTRANSPORT) (QUOTE SERVER.POLL) (LIST NULL.AUTHENTICATOR (QUOTE (0))) (FUNCTION \NSMAIL.CHECKSERVER) NSMAIL.NET.HINT)) (push \NSMAIL.SERVER.CACHE INFO) INFO)))))
)
(\NSMAIL.CHECKSERVER
(LAMBDA (POLLRESULT) (* bvm%: " 1-Jul-84 15:15") (* ;; "Checks that the result of a SERVER.POLL is useful. Returns the server's address") (COND ((AND (FIXP (CAR POLLRESULT)) (ILESSP (CAR POLLRESULT) 10)) (CAR (CADR POLLRESULT)))))
)
)
(RPAQ? \NSMAIL.SERVER.CACHE)
(RPAQ? NSMAIL.NET.HINT)
(ADDTOVAR \SYSTEMCACHEVARS \NSMAIL.SERVER.CACHE)
(DEFINEQ
(\NSMAIL.MESSAGE.P
(LAMBDA (MSG) (* ; "Edited 6-May-88 13:58 by bvm") (AND (STRPOS ":" (fetch (LAFITEMSG FROM) of MSG)) (QUOTE ?)))
)
(\NSMAIL.MESSAGE.FROM.SELF.P
(LAMBDA (MSG) (* ; "Edited 6-May-88 14:37 by bvm") (* ;; "True if message is from current user. Easy in NS case because we always make the From field be exactly our full name") (STRING-EQUAL (fetch (LAFITEMSG FROM) of MSG) (fetch (LAFITEMODEDATA FULLUSERNAME) of *LAFITE-MODE-DATA*)))
)
(\NSMAIL.MAKEANSWERFORM
(LAMBDA (MSGDESCRIPTORS MAILFOLDER) (* ; "Edited 6-Jun-88 14:09 by bvm") (LET ((MSGFIELDS (\LAFITE.PARSE.MESSAGE MAILFOLDER (OR (CAR (LISTP MSGDESCRIPTORS)) MSGDESCRIPTORS))) SUBJECT FROM DATE SENDER REPLYTO TO CC ORIGINALREGISTRY OLDFROM NEWTO) (* ; "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") (COND (SENDER (* ; "Sender is a mail address, and has the official registry") (SETQ ORIGINALREGISTRY (PARSE.NSNAME SENDER)) (SETQ OLDFROM (AND FROM (\NSMAIL.PARSE FROM ORIGINALREGISTRY)))) (FROM (* ; "Have to parse the From field before we can get its registry") (SETQ ORIGINALREGISTRY (CAR (SETQ OLDFROM (\NSMAIL.PARSE FROM))))) (T (LAB.PROMPTPRINT MAILFOLDER T "Can't reply--no FROM or SENDER field"))) (SETQ NEWTO (OR (AND REPLYTO (SETQ REPLYTO (\NSMAIL.PARSE REPLYTO ORIGINALREGISTRY))) OLDFROM)) (LAFITE.FILL.IN.ANSWER.FORM SUBJECT FROM DATE NEWTO (CL:SET-DIFFERENCE (COND (REPLYTO (* ; "Only this address, so can only cc to self now") (LIST (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of *LAFITE-MODE-DATA*))) (T (* ; "Take everyone who got the original, removing duplicates, of course.") (NS.REMOVEDUPLICATES (APPEND (AND TO (\NSMAIL.PARSE TO ORIGINALREGISTRY)) (AND CC (\NSMAIL.PARSE CC ORIGINALREGISTRY)))))) NEWTO :TEST (FUNCTION EQUAL.CH.NAMES)) (FUNCTION \NSMAIL.PRINT.NAMES))))
)
)
(* ; "Utility for handling mail attributes")
(PUTPROPS ENVELOPE.ITEM COURIERDEF (\NS.READ.ENVELOPE.ITEM \NS.WRITE.ENVELOPE.ITEM))
(DEFINEQ
(\NS.READ.ENVELOPE.ITEM
(LAMBDA (STREAM PROGRAM TYPE) (* bvm%: " 8-Nov-84 13:47") (* ;; "Reads a mailing envelope attribute value pair from STREAM, returning a list of two elements, (TYPE VALUE); if the attribute is not a known attribute, TYPE is an integer and VALUE is a sequence of unspecified") (bind (TYPE ← (COURIER.READ STREAM NIL (QUOTE LONGCARDINAL))) VALUE for X in \NSMAIL.ENVELOPE.ITEM.TYPES when (EQ (CADR X) TYPE) do (RETURN (LIST (CAR X) (PROGN (\WIN STREAM) (* ; "Skip sequence count") (COURIER.READ STREAM PROGRAM (CADDR X))))) finally (* ; "TYPE not recognized") (RETURN (LIST TYPE (COURIER.READ.SEQUENCE STREAM NIL (QUOTE UNSPECIFIED))))))
)
(\NS.WRITE.ENVELOPE.ITEM
(LAMBDA (STREAM ITEM PROGRAM TYPE) (* bvm%: " 8-Nov-84 13:46") (* ;;; "Writes a filing attribute value pair to STREAM. ITEM is a list of two elements (TYPE VALUE)") (PROG ((TYPE (CAR ITEM)) (VALUE (CADR ITEM)) VALUETYPE) (COND ((NOT (FIXP TYPE)) (for X in \NSMAIL.ENVELOPE.ITEM.TYPES when (EQ (CAR X) TYPE) do (SETQ TYPE (CADR X)) (SETQ VALUETYPE (CADDR X)) (RETURN) finally (ERROR "Unknown Envelope Item Type" TYPE)))) (COURIER.WRITE STREAM TYPE NIL (QUOTE LONGCARDINAL)) (COND (VALUETYPE (COURIER.WRITE.SEQUENCE.UNSPECIFIED STREAM VALUE PROGRAM VALUETYPE)) (T (COURIER.WRITE.SEQUENCE STREAM VALUE PROGRAM (QUOTE UNSPECIFIED))))))
)
)
(RPAQQ \NSMAIL.ENVELOPE.ITEM.TYPES ((Postmark 0 POSTMARK) (Message-ID 1 MESSAGEID) (ContentsType 2 LONGCARDINAL) (CONTENTS.SIZE 3 LONGCARDINAL) (Originator 4 RNAME) (TransportProblem 6 PROBLEM) (RETURN.TO.NAME 7 RNAME) (Previous-Recipients 8 RNAME.LIST) (Status 1000 STATUS) (BodyType 17 LONGCARDINAL)))
(DECLARE%: EVAL@COMPILE DOCOPY
(RPAQQ \NSMAIL.ATTRIBUTES ((From 4672 NAME.LIST) (Date 4673 TIME) (Reply-to 4674 NAME.LIST) (To 4676 NAME.LIST) (cc 4677 NAME.LIST) (Subject 9 STRING) (Message-ID 4693 MESSAGEID) (Sender 4705 NAME) (BodySize 16 LONGCARDINAL) (BodyType 17 LONGCARDINAL) (Note 4687 STRING) (OldLispFormatting 4910 STRING) (LispFormatting 4911 STRING) (In-Reply-to 4690 STRING)))
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RECORD NSMAILBOX (NSMAILSTREAM NSMAILENVTAIL NSMAILENVELOPES NSMAILLASTINDEX . NSMAILSTATE) (ACCESSFNS NSMAILBOX ((NSMAILSESSION (fetch STATESESSION of (fetch NSMAILSTATE of DATUM))) (NSMAILFIRSTINDEX (fetch STATEFIRSTNEW of (fetch NSMAILSTATE of DATUM)))))
)
(RECORD NSMAILSTATE (STATESESSION STATEFIRSTNEW STATEOLDLAST STATENAME STATECREDENTIALS STATEADDRESS)
)
(RECORD NSMAILPARSE (NSPSUBJECT NSPRECIPIENTS NSPSTART NSPFORMATTED . NSPFIELDS))
)
(DECLARE%: EVAL@COMPILE
(RPAQQ \NSMAIL.SOCKET 26)
(RPAQQ \SERIALIZED.FILE.VERSION 2)
(RPAQQ \NSMAIL.CTSTANDARD.MESSAGE 0)
(RPAQQ \NSMAIL.TEXT.BODYTYPE 2)
(RPAQQ \NSMAIL.EMPTY.BODYTYPE 4)
(RPAQQ \NSMAIL.MAX.NOTE.LENGTH 8000)
(RPAQQ MAX.BULK.SEGMENT.LENGTH 32768)
(RPAQQ \NULL.CACHE.VERIFIER (0 0 0 0))
(CONSTANTS \NSMAIL.SOCKET \SERIALIZED.FILE.VERSION \NSMAIL.CTSTANDARD.MESSAGE \NSMAIL.TEXT.BODYTYPE \NSMAIL.EMPTY.BODYTYPE \NSMAIL.MAX.NOTE.LENGTH MAX.BULK.SEGMENT.LENGTH \NULL.CACHE.VERIFIER)
)
(DECLARE%: EVAL@COMPILE
(PUTPROPS \NSMAIL.ATTRIBUTE.TYPE MACRO (ARGS (COND ((CADR (ASSOC (CAR ARGS) \NSMAIL.ATTRIBUTES))) (T (ERROR "Unknown mail attribute" (CAR ARGS)) (QUOTE IGNOREMACRO)))))
(PUTPROPS \NSMAIL.WRITE.ATTRIBUTE MACRO (ARGS (LET ((INFO (CDR (ASSOC (CAR (CONSTANTEXPRESSIONP (CADR ARGS))) \NSMAIL.ATTRIBUTES)))) (COND (INFO (LIST (QUOTE \NSMAIL.WRITE.ATTRIBUTE.MACRO) (CAR ARGS) (CAR INFO) (CADDR ARGS) (KWOTE (CADR INFO)))) (T (QUOTE IGNOREMACRO))))))
(PUTPROPS \NSMAIL.WRITE.ATTRIBUTE.MACRO MACRO (OPENLAMBDA (STREAM TYPENO VALUE VALUETYPE) (COURIER.WRITE STREAM TYPENO NIL (QUOTE LONGCARDINAL)) (COURIER.WRITE.SEQUENCE.UNSPECIFIED STREAM VALUE (QUOTE MAILTRANSPORT) VALUETYPE)))
)
(PUTPROPS \NSMAIL.ATTRIBUTE.TYPE INFO NOEVAL)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS NSMAIL.NET.HINT \NSMAIL.ENVELOPE.ITEM.TYPES \NSMAIL.ATTRIBUTES \NSMAIL.SERVER.CACHE NSMAILDEBUGFLG NSWIZARDFLG NSMAIL.LEAVE.ATTACHMENTS \NSMAIL.GOOD.BODYTYPES MAILOBJ.WINDOWOFFSET MAILOBJ.SKIPCHAR \MAILOBJ.IMAGEFNS MAILOBJ.REFERENCE.FIELD \NSFILING.ATTRIBUTES DEFAULTICONFONT NSPRINT.WATCHERFLG)
)
(CL:PROCLAIM (QUOTE (CL:SPECIAL *RETRIEVAL-ERROR*)))
(FILESLOAD (SOURCE) LAFITEDECLS)
(FILESLOAD (LOADCOMP) CLEARINGHOUSE)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(PUTPROPS NSMAIL COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987 1988))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (9078 11387 (\NSMAIL.AUTHENTICATE 9088 . 10698) (\NSMAIL.LOGIN 10700 . 10926) (
NS.FINDMAILBOXES 10928 . 11385)) (11601 32018 (NS.POLLNEWMAIL 11611 . 11996) (NS.OPENMAILBOX 11998 .
13082) (\NSMAIL.CHECK 13084 . 17591) (NS.NEXTMESSAGE 17593 . 18056) (\NSMAIL.READ.ENVELOPES 18058 .
18928) (NS.RETRIEVEMESSAGE 18930 . 20990) (\NSMAIL.RETRIEVE 20992 . 21736) (\NSMAIL.EOF.ON.RETRIEVE
21738 . 22088) (\NSMAIL.READ.SERIALIZED.TREE 22090 . 25762) (\NSMAIL.CHECK.SERIALIZED.VERSION 25764 .
25981) (\NSMAIL.READ.SERIALIZED.CONTENT 25983 . 26856) (\NSMAIL.READ.STRING.AS.STREAM 26858 . 27267) (
\NSMAIL.PRINT.HEADERFIELDS 27269 . 31759) (\NSMAIL.PRINT.NAMES 31761 . 32016)) (32050 33451 (
\NSMAIL.COURIER.OPEN 32060 . 32263) (\NSMAIL.ERRORHANDLER 32265 . 32687) (\NSMAIL.SIGNAL.ERROR 32689
. 33449)) (33489 35420 (NS.CLOSEMAILBOX 33499 . 34793) (\NSMAIL.CHANGE.STATUS 34795 . 35418)) (35589
40839 (\MAILOBJ.CREATE 35599 . 37431) (\MAILOBJ.TYPE.NAME 37433 . 37900) (\MAILOBJ.NS.TO.LISP.NAME
37902 . 39253) (\MAILOBJ.DISPLAY 39255 . 39575) (\MAILOBJ.GET 39577 . 39895) (\MAILOBJ.IMAGEBOX 39897
. 40025) (\MAILOBJ.PUT 40027 . 40559) (\MAILOBJ.INIT 40561 . 40837)) (40840 54090 (
\MAILOBJ.BUTTONEVENTFN 40850 . 42969) (\MAILOBJ.DO.COMMAND 42971 . 43218) (\MAILOBJ.HARDCOPY 43220 .
45137) (\MAILOBJ.FB 45139 . 45353) (\MAILOBJ.PUT.FILE 45355 . 46864) (\MAILOBJ.VIEW 46866 . 49390) (
\MAILOBJ.COPY.BODY 49392 . 49706) (\MAILOBJ.EXPAND 49708 . 51061) (\MAILOBJ.COPY.CHILD 51063 . 52420)
(\MAILOBJ.COPY.SEQUENCE 52422 . 52790) (\MAILOBJ.EXTRACT.TEXT 52792 . 53343) (
\MAILOBJ.PARSE.ATTRIBUTES 53345 . 54088)) (54974 66496 (\NSMAIL.SEND.PARSE 54984 . 56548) (
\NSMAIL.PARSE 56550 . 56811) (\NSMAIL.PARSE1 56813 . 57381) (NS.REMOVEDUPLICATES 57383 . 57521) (
\NSMAIL.SEND 57523 . 60729) (\NSMAIL.SEND.MESSAGE.CONTENT 60731 . 63427) (
COURIER.WRITE.STREAM.UNSPECIFIED 63429 . 64573) (\NSMAIL.SEND.STREAM.AS.STRING 64575 . 65195) (
\NSMAIL.WRITE.ATTRIBUTE 65197 . 65568) (\NSMAIL.FINDSERVER 65570 . 66234) (\NSMAIL.CHECKSERVER 66236
. 66494)) (66602 68701 (\NSMAIL.MESSAGE.P 66612 . 66750) (\NSMAIL.MESSAGE.FROM.SELF.P 66752 . 67073)
(\NSMAIL.MAKEANSWERFORM 67075 . 68699)) (68841 70183 (\NS.READ.ENVELOPE.ITEM 68851 . 69516) (
\NS.WRITE.ENVELOPE.ITEM 69518 . 70181)))))
STOP