;;; Lisp Machine mail reader -*- Mode:LISP; Package:ZWEI -*- ;;; Mailing commands and routines, definition are in DEFS ;;; ** (c) Copyright 1980 Massachusetts Institute of Technology ** ;;; Send a message (DEFINE-ZMAIL-GLOBAL *LAST-MAIL-TYPE-ITEM* NIL) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER COM-ZMAIL-MAIL (STRING) (FORMAT STRING "Send a message: L: normal; M: ~A; R: menu." (NAME-FROM-MENU-VALUE *MAIL-MIDDLE-MODE* *ZMAIL-MAIL-MENU-ALIST*))) (ASSOCIATE-OPTION-WITH-COMMAND-DOCUMENTATION *MAIL-MIDDLE-MODE* COM-ZMAIL-MAIL) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-MAIL "Send a message. Left gives normal mail. Middle is normally Bug, but controlled by *MAIL-MIDDLE-MODE*. Right gives a menu of Bug, Forward, Redistribute or Local." (NO-MAIL-FILE-OK) (SET-ZMAIL-USER) (LET ((TYPE (CHOOSE-MAIL-MODE))) (SELECTQ TYPE (:LOCAL (COM-ZMAIL-LOCAL-MAIL-INTERNAL)) (:REDISTRIBUTE (COM-ZMAIL-REDISTRIBUTE-MSG)) (OTHERWISE (COM-ZMAIL-MAIL-INTERNAL TYPE))))) (DEFUN CHOOSE-MAIL-MODE (&OPTIONAL (TYPE ':MAIL)) (AND (MEMQ *ZMAIL-COMMAND-BUTTON* '(:MIDDLE :RIGHT)) (MULTIPLE-VALUE (TYPE *LAST-MAIL-TYPE-ITEM*) (ZMAIL-MENU-CHOOSE NIL *ZMAIL-MAIL-MENU-ALIST* *LAST-MAIL-TYPE-ITEM* NIL *MAIL-MIDDLE-MODE*)))) (DEFVAR *SENDING-BUG-REPORT* NIL) (DEFUN COM-ZMAIL-MAIL-INTERNAL (MODE &AUX POINT WHO WHAT (STARTING-WINDOW ':HEADER) (*SENDING-BUG-REPORT* NIL)) (SELECTQ MODE (:FORWARD (OR *MSG* (BARF "There is no current message"))) (:BUG (SETQ *SENDING-BUG-REPORT* T) (MULTIPLE-VALUE (WHO WHAT) (PARSE-BUG-ARG (GET-BUG-ARG))))) (INITIALIZE-FOR-MAIL) (SETQ POINT (WINDOW-POINT *HEADER-WINDOW*)) (INSERT-MOVING POINT "To: ") (INSERT POINT #\CR) (SELECTQ MODE (:MAIL) (:FORWARD (SETF (DRAFT-MSG-MSGS-BEING-FORWARDED *DRAFT-MSG*) (NCONS *MSG*)) (AND *FORWARDED-ADD-SUBJECT* (LET* ((STREAM (INTERVAL-STREAM-INTO-BP POINT)) (STATUS (ASSURE-MSG-PARSED *MSG*)) (FROM (CAR (GET STATUS ':FROM))) (SUBJECT (GET STATUS ':SUBJECT))) (FORMAT STREAM "~%Subject: [~A: ~A]~%" (STRING-FROM-HEADER FROM ':LONG) (OR SUBJECT "Forwarded")))) (INSERT-MSGS-INTO-WINDOW *REPLY-WINDOW* NIL *MSG*) (OR (AND (STRING-EQUAL *FORWARDED-MESSAGE-BEGIN* "") (STRING-EQUAL *FORWARDED-MESSAGE-END* "")) (LET* ((BP (WINDOW-POINT *REPLY-WINDOW*)) (STREAM (INTERVAL-STREAM-INTO-BP (INTERVAL-FIRST-BP *REPLY-INTERVAL*)))) (FORMAT STREAM *FORWARDED-MESSAGE-BEGIN* 1) (FUNCALL STREAM ':FRESH-LINE) (FUNCALL STREAM ':SET-BP BP) (FORMAT STREAM *FORWARDED-MESSAGE-END* 1) (FUNCALL STREAM ':FRESH-LINE) (MOVE-BP BP (FUNCALL STREAM ':READ-BP))))) (:BUG (INSERT-MOVING POINT WHO) (INSERT-MOVING (WINDOW-POINT *REPLY-WINDOW*) WHAT) (SETQ STARTING-WINDOW ':REPLY))) (ZMAIL-MAIL ':MAIL STARTING-WINDOW)) (DEFVAR *ZMAIL-BUG-LIST* '("LISPM" "ZWEI" "NWS" "ZMAIL" "LMMAN" "HARDWARE" ("Other" :VALUE :OTHER :FONT FONTS:HL12I))) (DEFUN ADD-BUG-RECIPIENT (NAME) (SETQ NAME (STRING NAME)) (OR (MEMBER NAME *ZMAIL-BUG-LIST*) (PUSH NAME *ZMAIL-BUG-LIST*))) (DEFMACRO (:BUG-REPORTS SI:DEFSYSTEM-MACRO) (&OPTIONAL ADDRESS) (ADD-BUG-RECIPIENT (OR ADDRESS (SI:SYSTEM-NAME SI:*SYSTEM-BEING-DEFINED*))) NIL) (DEFINE-ZMAIL-GLOBAL *LAST-BUG-TYPE* NIL) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION GET-BUG-ARG *BUG-DOCUMENTATION*) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER GET-BUG-ARG (STRING) (FORMAT STRING "Send a bug report:~@[ L: BUG-~A; ~] R: menu." *LAST-BUG-TYPE*)) (DEFUN GET-BUG-ARG (&AUX WHO) (OR (EQ *ZMAIL-COMMAND-BUTTON* ':KBD) (MULTIPLE-VALUE (WHO *LAST-BUG-TYPE*) (ZMAIL-MENU-CHOOSE NIL *ZMAIL-BUG-LIST* *LAST-BUG-TYPE*))) (PROG1 (COND ((EQ *ZMAIL-COMMAND-BUTTON* ':KBD) (SETQ WHO (TYPEIN-LINE-READLINE "Send a message to BUG-~@[ (default ~A)~]" *LAST-BUG-TYPE*)) (IF (EQUAL WHO "") (SETQ WHO (OR *LAST-BUG-TYPE* (SETQ *LAST-BUG-TYPE* (CAR *ZMAIL-BUG-LIST*)))) (SETQ *LAST-BUG-TYPE* WHO))) ((STRINGP WHO) WHO) ((EQ WHO ':OTHER) (SETQ WHO (CALL-POP-UP-MINI-BUFFER-EDITOR ':MOUSE #'TYPEIN-LINE-READLINE "Send a message to BUG-")) (AND (EQUAL WHO "") (BARF)) (PUSH WHO *ZMAIL-BUG-LIST*) (SETQ *LAST-BUG-TYPE* WHO) WHO)) (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'GET-BUG-ARG))) (DEFUN MAKE-DRAFT-MSG (&REST MSGS-BEING-REPLIED-TO &AUX DRAFT-MSG) (SETQ DRAFT-MSG (MAKE-DRAFT-MSG-INTERNAL NODE-TICK *TICK* SUMMARY-STRING "Empty" SUMMARY-STRING-TICK *TICK* MSGS-BEING-REPLIED-TO (COPYLIST MSGS-BEING-REPLIED-TO) LAST-WINDOW-CONFIGURATION ':MAIL)) (LET* ((LINE (CREATE-LINE 'ART-STRING 0 DRAFT-MSG)) (START-BP (CREATE-BP LINE 0 ':NORMAL)) (END-BP (CREATE-BP LINE 0 ':MOVES))) (SETF (INTERVAL-FIRST-BP DRAFT-MSG) START-BP) (SETF (INTERVAL-LAST-BP DRAFT-MSG) END-BP) (INSERT END-BP #\CR) (LET ((HEADER-INTERVAL (MAKE-ZMAIL-INTERVAL INTERVAL-FIRST-BP (COPY-BP START-BP ':NORMAL) INTERVAL-LAST-BP (COPY-BP START-BP ':MOVES) NODE-TICK (TICK) BUFFER-NAME "Headers")) (REPLY-INTERVAL (MAKE-ZMAIL-INTERVAL INTERVAL-FIRST-BP (COPY-BP END-BP ':NORMAL) INTERVAL-LAST-BP (COPY-BP END-BP ':MOVES) NODE-TICK *TICK* BUFFER-NAME "Mail"))) (SETF (LINE-NODE (BP-LINE START-BP)) HEADER-INTERVAL) (SETF (LINE-NODE (BP-LINE END-BP)) REPLY-INTERVAL) (SETF (DRAFT-MSG-HEADER-INTERVAL DRAFT-MSG) HEADER-INTERVAL) (SETF (DRAFT-MSG-REPLY-INTERVAL DRAFT-MSG) REPLY-INTERVAL) (SETF (NODE-SUPERIOR HEADER-INTERVAL) DRAFT-MSG) (SETF (NODE-SUPERIOR REPLY-INTERVAL) DRAFT-MSG) (SETF (NODE-INFERIORS DRAFT-MSG) (LIST HEADER-INTERVAL REPLY-INTERVAL)))) DRAFT-MSG) (DEFUN VALIDATE-DRAFT-MSG-SUMMARY-STRING (DRAFT-MSG &AUX TEM HEADERS RECIPIENTS SUBJECT SUMMARY-STRING) (IF ( (NODE-TICK DRAFT-MSG) (DRAFT-MSG-SUMMARY-STRING-TICK DRAFT-MSG)) (DRAFT-MSG-SUMMARY-STRING DRAFT-MSG) (SETQ TEM (PARSE-HEADERS-INTERVAL (DRAFT-MSG-HEADER-INTERVAL DRAFT-MSG)) HEADERS (LOCF TEM)) (AND (SETQ RECIPIENTS (GET HEADERS ':TO)) (SETQ SUMMARY-STRING (STRING-APPEND "To: " (SUMMARIZE-RECIPIENTS RECIPIENTS 20.)))) (AND (OR (NULL RECIPIENTS) (< (STRING-LENGTH SUMMARY-STRING) 20.)) (SETQ RECIPIENTS (GET HEADERS ':CC)) (SETQ SUMMARY-STRING (STRING-APPEND (IF SUMMARY-STRING (STRING-APPEND SUMMARY-STRING "; CC: ") "CC: ") (SUMMARIZE-RECIPIENTS RECIPIENTS 20.)))) (AND (> (STRING-LENGTH SUMMARY-STRING) 30.) (SETQ SUMMARY-STRING (SUBSTRING SUMMARY-STRING 0 30.))) (AND (COND ((SETQ SUBJECT (GET HEADERS ':SUBJECT)) (AND (LISTP SUBJECT) (SETQ SUBJECT (CAR SUBJECT))) (SETQ SUBJECT (STRING-APPEND "Re: " SUBJECT)) T) ((NOT (EQUAL (SETQ SUBJECT (FIRST-TEXT-LINE (DRAFT-MSG-REPLY-INTERVAL DRAFT-MSG))) "")))) (SETQ SUMMARY-STRING (IF SUMMARY-STRING (STRING-APPEND SUMMARY-STRING "; " SUBJECT) SUBJECT))) (COND (SUMMARY-STRING (AND (DRAFT-MSG-MSGS-BEING-REPLIED-TO DRAFT-MSG) (SETQ SUMMARY-STRING (STRING-APPEND "Reply: " SUMMARY-STRING))) (OR (DRAFT-MSG-SENT-P DRAFT-MSG) (SETQ SUMMARY-STRING (STRING-APPEND SUMMARY-STRING "; (Not sent)")))) (T (SETQ SUMMARY-STRING "Empty"))) (SETF (DRAFT-MSG-SUMMARY-STRING DRAFT-MSG) SUMMARY-STRING) (SETF (DRAFT-MSG-SUMMARY-STRING-TICK DRAFT-MSG) (TICK)) SUMMARY-STRING)) ;;; Send some more (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER COM-ZMAIL-CONTINUE (STRING) (APPEND-TO-ARRAY STRING "Resume sending message:") (AND *DRAFT-LIST* (LET* ((LEFT-DRAFT-MSG (CAR *DRAFT-LIST*)) (MIDDLE-DRAFT-MSG (LOOP FOR DM IN *DRAFT-LIST* UNLESS (DRAFT-MSG-SENT-P DM) RETURN DM)) (SAME-P (EQ LEFT-DRAFT-MSG MIDDLE-DRAFT-MSG))) (APPEND-TO-ARRAY STRING (IF SAME-P " L,M: " " L: ")) (LET ((SUMMARY (VALIDATE-DRAFT-MSG-SUMMARY-STRING LEFT-DRAFT-MSG))) (APPEND-TO-ARRAY STRING SUMMARY 0 (MIN (COND (SAME-P 56.) ((NULL MIDDLE-DRAFT-MSG) 58.) (T 27.)) (STRING-LENGTH SUMMARY)))) (AND MIDDLE-DRAFT-MSG (NOT SAME-P) (LET ((SUMMARY (VALIDATE-DRAFT-MSG-SUMMARY-STRING MIDDLE-DRAFT-MSG))) (APPEND-TO-ARRAY STRING "; M: ") (APPEND-TO-ARRAY STRING SUMMARY 0 (MIN 27. (STRING-LENGTH SUMMARY))))) (ARRAY-PUSH-EXTEND STRING #/;))) (APPEND-TO-ARRAY STRING " R: menu.")) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-CONTINUE "Resume sending message. Left continues the last message. Middle continues the last unsent message. Right for menu of drafts or from a message or file." (NO-MAIL-FILE-OK) (LET ((DRAFT-MSG (GET-DRAFT-MSG-FOR-CONTINUE))) (COND ((NULL DRAFT-MSG) (ABORT-CURRENT-COMMAND)) ((EQ DRAFT-MSG ':RESTORE-DRAFT) (SETQ DRAFT-MSG (MAKE-DRAFT-MSG-FROM-RESTORED-DRAFT))) ((MEMQ DRAFT-MSG '(:FROM-THIS-MSG :FROM-SOME-MSG)) (SETQ DRAFT-MSG (IF (EQ DRAFT-MSG ':FROM-THIS-MSG) (OR *MSG* (BARF "There is no current message")) (CHOOSE-MSG-FROM-SUMMARY "a draft message"))) (SETQ DRAFT-MSG (MAKE-DRAFT-MSG-FROM-MSG DRAFT-MSG)))) (CONTINUE-DRAFT-MSG DRAFT-MSG))) (DEFUN GET-DRAFT-MSG-FOR-CONTINUE () (SELECTQ *ZMAIL-COMMAND-BUTTON* ((:LEFT :KBD) (OR (CAR *DRAFT-LIST*) (BARF "There are no messages to continue sending"))) (:MIDDLE (OR (LOOP FOR DM IN *DRAFT-LIST* UNLESS (DRAFT-MSG-SENT-P DM) RETURN DM) (BARF "There are no unsent messages to continue sending"))) (:RIGHT (TV:MENU-CHOOSE (NCONC (MAPCAR #'(LAMBDA (DRAFT-MSG) (CONS (VALIDATE-DRAFT-MSG-SUMMARY-STRING DRAFT-MSG) DRAFT-MSG)) *DRAFT-LIST*) '(("Restore draft file" :VALUE :RESTORE-DRAFT :FONT FONTS:HL12I :DOCUMENTATION "Continue sending a message draft that was saved in a file.") ("Restore draft message" :BUTTONS (:FROM-THIS-MSG NIL :FROM-SOME-MSG) :FONT FONTS:HL12I :DOCUMENTATION "Continue sending message draft saved as message: L: this message; R: specify from summary." ))) NIL (RECTANGLE-NEAR-COMMAND-MENU TV:MOUSE-SHEET))))) (DEFUN CONTINUE-DRAFT-MSG (DRAFT-MSG) (INITIALIZE-FOR-MAIL DRAFT-MSG NIL) (ZMAIL-MAIL (DRAFT-MSG-LAST-WINDOW-CONFIGURATION DRAFT-MSG) (OR (CAAR (DRAFT-MSG-WINDOW-POINTS DRAFT-MSG)) ':REPLY))) (DEFVAR *INSIDE-MAIL* NIL) (DEFUN ZMAIL-MAIL (CONFIGURATION STARTING-WINDOW &AUX (OLD-CONFIGURATION *WINDOW-CONFIGURATION*) (*INSIDE-MAIL* T) *END-SENDS-MESSAGE-P*) (SETQ *COMTAB* *REPLY-COMTAB*) (UNWIND-PROTECT (PROGN (LOCK-BACKGROUND-PROCESS) (PREPARE-WINDOW-FOR-REDISPLAY *MSG-WINDOW*) (SET-MAIL-WINDOW-CONFIGURATION CONFIGURATION STARTING-WINDOW NIL) (*CATCH 'SEND-IT (LET () (BIND (LOCATE-IN-INSTANCE SELF '*MODE-LINE-LIST*) `("ZMail " "Mail " "(" *MODE-NAME-LIST* (*MODE-QUANTITY-NAME* " <" *MODE-QUANTITY-NAME* ">") ") " *ZMAIL-INTERVAL-NAME* (*MACRO-LEVEL* " Macro-level: " *MACRO-LEVEL*) ,(FORMAT NIL " ~:@C " #\END) (*END-SENDS-MESSAGE-P* "mails" :ELSE "adds more text") ,(FORMAT NIL ", ~:@C aborts" #\ABORT))) (BIND (LOCF (TV:BLINKER-DESELECTED-VISIBILITY (WINDOW-POINT-BLINKER *MSG-WINDOW*))) ':ON) (FUNCALL (WINDOW-SHEET *MSG-WINDOW*) ':SET-WHO-LINE-OVERRIDE-DOCUMENTATION-STRING NIL) (FUNCALL-SELF ':EDIT)))) (RESEPARATE-HEADER-AND-TEXT) (SAVE-DRAFT-MSG-WINDOW-STATE *DRAFT-MSG*) (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'COM-ZMAIL-CONTINUE) (IF (NEQ OLD-CONFIGURATION *WINDOW-CONFIGURATION*) (FUNCALL-SELF ':SET-WINDOW-CONFIGURATION OLD-CONFIGURATION) (MUST-REDISPLAY *MSG-WINDOW* DIS-ALL) (FUNCALL-SELF ':SELECT NIL)) (ZMAIL-SELECT-MSG *MSG* T NIL) (PROCESS-UNLOCK *ZMAIL-BACKGROUND-PROCESS-LOCK*)) DIS-NONE) (DEFUN SAVE-DRAFT-MSG-WINDOW-STATE (DRAFT-MSG) (SETF (DRAFT-MSG-LAST-WINDOW-CONFIGURATION DRAFT-MSG) *WINDOW-CONFIGURATION*) (SETF (DRAFT-MSG-WINDOW-POINTS DRAFT-MSG) (LOOP FOR WINDOW IN *WINDOW-LIST* WHEN (WINDOW-EXPOSED-P WINDOW) COLLECT (LIST WINDOW (COPY-BP (WINDOW-POINT WINDOW) ':NORMAL) (COPY-BP (WINDOW-START-BP WINDOW) ':NORMAL))))) (DEFVAR *MSGS-BEING-REPLIED-TO-INTERVAL*) ;;; INSERT-DEFAULTS means put in the Default CC list and Default Fcc list (DEFUN INITIALIZE-FOR-MAIL (&OPTIONAL (DRAFT-MSG (MAKE-DRAFT-MSG)) (INSERT-DEFAULTS T)) (SETQ *HEADER-INTERVAL* (DRAFT-MSG-HEADER-INTERVAL DRAFT-MSG)) (SET-WINDOW-INTERVAL *HEADER-WINDOW* *HEADER-INTERVAL*) (MUST-REDISPLAY *HEADER-WINDOW* DIS-ALL) (SETQ *REPLY-INTERVAL* (DRAFT-MSG-REPLY-INTERVAL DRAFT-MSG)) (SET-WINDOW-INTERVAL *REPLY-WINDOW* *REPLY-INTERVAL*) (MUST-REDISPLAY *REPLY-WINDOW* DIS-ALL) (AND INSERT-DEFAULTS (OR *DEFAULT-CC-LIST* *DEFAULT-FCC-LIST*) (LET* ((LIST `(:CC ,*DEFAULT-CC-LIST* :FCC ,*DEFAULT-FCC-LIST*)) (PLIST (LOCF LIST)) (STREAM (INTERVAL-STREAM-INTO-BP (INTERVAL-LAST-BP *HEADER-INTERVAL*)))) (OUTPUT-HEADER STREAM PLIST '(:CC :FCC) NIL NIL))) (SETF (DRAFT-MSG-MSGS-BEING-REPLIED-TO DRAFT-MSG) (DEL-IF #'(LAMBDA (MSG) (EQ (MSG-PARSED-P MSG) ':KILLED)) (DRAFT-MSG-MSGS-BEING-REPLIED-TO DRAFT-MSG))) (SETF (DRAFT-MSG-MSGS-BEING-FORWARDED DRAFT-MSG) (DEL-IF #'(LAMBDA (MSG) (EQ (MSG-PARSED-P MSG) ':KILLED)) (DRAFT-MSG-MSGS-BEING-FORWARDED DRAFT-MSG))) (LET ((MSGS (DRAFT-MSG-MSGS-BEING-REPLIED-TO DRAFT-MSG))) (COND ((NULL MSGS) (SETQ *MSGS-BEING-REPLIED-TO-INTERVAL* NIL)) ((NULL (CDR MSGS)) (SETQ *MSGS-BEING-REPLIED-TO-INTERVAL* (MSG-INTERVAL (CAR MSGS)))) (T (SETQ *MSGS-BEING-REPLIED-TO-INTERVAL* (CREATE-INTERVAL)) (DO ((BP (INTERVAL-LAST-BP *MSGS-BEING-REPLIED-TO-INTERVAL*)) (MSGS MSGS (CDR MSGS)) (FIRST-P T NIL)) ((NULL MSGS)) (OR FIRST-P (INSERT BP #\CR)) (INSERT-INTERVAL BP (MSG-INTERVAL (CAR MSGS))))))) (LOOP FOR ZOT IN (DRAFT-MSG-WINDOW-POINTS DRAFT-MSG) AS WINDOW = (POP ZOT) DO (MOVE-BP (WINDOW-POINT WINDOW) (POP ZOT)) (RECENTER-WINDOW WINDOW ':START (POP ZOT))) (SETQ *DRAFT-LIST* (CONS DRAFT-MSG (DELQ DRAFT-MSG *DRAFT-LIST*))) (SETQ *DRAFT-MSG* DRAFT-MSG)) ;;; Set the windows displayed while sending mail. CONFIGURATION is ;;; either a WINDOW-CONFIGURATION keyword or :MAIL for the default one ;;; window mail configuration. STARTING-WINDOW is either a window or a ;;; keyword :HEADER OR :REPLY. SWITCHING-P means we are already inside ;;; mail and should swap out the old value of point. (DEFUN SET-MAIL-WINDOW-CONFIGURATION (CONFIGURATION &OPTIONAL STARTING-WINDOW (SWITCHING-P T)) (COND ((NULL CONFIGURATION) (SETQ CONFIGURATION *WINDOW-CONFIGURATION*)) ((EQ CONFIGURATION ':MAIL) (SETQ CONFIGURATION *DEFAULT-MAIL-WINDOW-CONFIGURATION*))) ;; Swap out msg window (AND SWITCHING-P (MEMQ *WINDOW-CONFIGURATION* *MSG-WINDOW-CONFIGURATIONS*) (LET* ((MSG-POINT (WINDOW-POINT *MSG-WINDOW*)) (WINDOW-TO-MOVE (IF (BP-< MSG-POINT (INTERVAL-FIRST-BP *REPLY-INTERVAL*)) *HEADER-WINDOW* *REPLY-WINDOW*))) (RESEPARATE-HEADER-AND-TEXT) (MOVE-BP (WINDOW-POINT WINDOW-TO-MOVE) MSG-POINT) (MUST-REDISPLAY WINDOW-TO-MOVE DIS-BPS))) (COND ((EQ CONFIGURATION ':REPLY) (SET-MSG-INTERVAL (OR *MSGS-BEING-REPLIED-TO-INTERVAL* (MSG-INTERVAL *MSG*)))) ((MEMQ CONFIGURATION *MSG-WINDOW-CONFIGURATIONS*) (IF (NEQ STARTING-WINDOW *MSG-WINDOW*) (SET-MSG-INTERVAL *DRAFT-MSG*) ;Not called from continue, can move point. (SETF (INTERVAL-FIRST-BP *MSG-INTERVAL*) (INTERVAL-FIRST-BP *DRAFT-MSG*)) (SETF (INTERVAL-LAST-BP *MSG-INTERVAL*) (INTERVAL-LAST-BP *DRAFT-MSG*))))) ;; Swap in msg window (LET ((WINDOW (AND STARTING-WINDOW (SYMBOLP STARTING-WINDOW) (SELECTQ STARTING-WINDOW (:HEADER *HEADER-WINDOW*) (:REPLY *REPLY-WINDOW*))))) (COND ((MEMQ CONFIGURATION *MSG-WINDOW-CONFIGURATIONS*) (SETQ *ZMAIL-INTERVAL-NAME* "Message" STARTING-WINDOW *MSG-WINDOW*) (COND (WINDOW (MOVE-BP (WINDOW-POINT *MSG-WINDOW*) (WINDOW-POINT WINDOW)) (MUST-REDISPLAY *MSG-WINDOW* DIS-BPS)))) (WINDOW (SETQ STARTING-WINDOW WINDOW)))) (COND ((NEQ CONFIGURATION *WINDOW-CONFIGURATION*) (FUNCALL-SELF ':SET-WINDOW-CONFIGURATION CONFIGURATION STARTING-WINDOW)) ((NULL STARTING-WINDOW)) ((NEQ STARTING-WINDOW *WINDOW*) (MAKE-WINDOW-CURRENT STARTING-WINDOW)) (T (SELECT-WINDOW STARTING-WINDOW))) (SETQ *END-SENDS-MESSAGE-P* (NEQ *WINDOW* *HEADER-WINDOW*))) (DEFUN RESEPARATE-HEADER-AND-TEXT () (AND (MEMQ *WINDOW-CONFIGURATION* *MSG-WINDOW-CONFIGURATIONS*) (DO ((LINE (BP-LINE (INTERVAL-FIRST-BP *DRAFT-MSG*)) (LINE-NEXT LINE)) (END-LINE (BP-LINE (INTERVAL-LAST-BP *DRAFT-MSG*)))) (NIL) (COND ((OR (EQ LINE END-LINE) (LINE-BLANK-P LINE)) (MOVE-BP (INTERVAL-LAST-BP *HEADER-INTERVAL*) LINE 0) (MOVE-BP (INTERVAL-FIRST-BP *REPLY-INTERVAL*) (OR (LINE-NEXT LINE) END-LINE) 0) (RETURN)))))) ;;; Mail from inside mail (DEFCOM COM-ZMAIL-RECURSIVE-MAIL "Start composing another message" () (LET ((OLD-DRAFT-MSG *DRAFT-MSG*)) (SAVE-DRAFT-MSG-WINDOW-STATE OLD-DRAFT-MSG) ;Save point (INITIALIZE-FOR-MAIL) ;Start a new message (SET-MAIL-WINDOW-CONFIGURATION NIL ':HEADER) (INSERT-MOVING (POINT) "To: ") (*CATCH 'SEND-IT (FUNCALL-SELF ':EDIT)) ;Edit it (RESEPARATE-HEADER-AND-TEXT) (INITIALIZE-FOR-MAIL OLD-DRAFT-MSG) ;Restore old one (MAKE-WINDOW-CURRENT (CAAR (DRAFT-MSG-WINDOW-POINTS OLD-DRAFT-MSG)))) DIS-NONE) ;;; Forwarding version (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-FORWARD "Forward current message" () (COM-ZMAIL-MAIL-INTERNAL ':FORWARD)) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-BUG "Send a bug report" (NO-MAIL-FILE-OK) (COM-ZMAIL-MAIL-INTERNAL ':BUG)) ;;; Abort it (DEFCOM COM-ABORT-SEND "Abort sending of this message" () (TYPEIN-LINE "Aborting, use the /"Continue/" command to continue.") (*THROW 'SEND-IT NIL)) ;;; Send it off (DEFVAR *END-SENDS-MESSAGE-P* T) (DEFCOM COM-MAIL-END "Send message unless in header area" () (IF *END-SENDS-MESSAGE-P* (COM-SEND-MESSAGE) (COM-ADD-MORE-TEXT))) (DEFCOM COM-SEND-MESSAGE "Finish the current message" () (RESEPARATE-HEADER-AND-TEXT) (LET* ((*REFERENCE-TYPE-HEADERS* NIL) ;Use text that is there (LIST (GET-SEND-HEADERS *HEADER-INTERVAL*)) (PLIST (LOCF LIST))) (SEND-IT PLIST) (*THROW 'SEND-IT T))) (DEFUN GET-SEND-HEADERS (BP1 &OPTIONAL BP2 IN-ORDER-P &AUX LIST (PLIST (LOCF LIST)) TEM) (SETQ LIST (PARSE-HEADERS-INTERVAL BP1 BP2 IN-ORDER-P)) (COND ((SETQ TEM (GET PLIST 'LOSING-HEADERS)) (BARF "Can't grok headers: ~A" TEM)) ((NULL (GET PLIST ':TO)) (BARF "There are no /"To/" recipients"))) (DO ((ABBREVS '((:F) (:S)) (CDR ABBREVS)) (EXPANSIONS '(:FROM :SUBJECT) (CDR EXPANSIONS)) (TEM)) ((NULL ABBREVS)) (COND ((SETQ TEM (GETL PLIST (CAR ABBREVS))) (SETF (CAR TEM) (CAR EXPANSIONS)) (AND (MEMQ (CAR EXPANSIONS) *ADDRESS-TYPE-HEADERS*) (SETF (CADR TEM) (PARSE-ADDRESSES (CADR TEM))))))) (COND ((NOT (OR (GET PLIST ':SUBJECT) (NULL *REQUIRE-SUBJECTS*) (AND (EQ *REQUIRE-SUBJECTS* ':BUG) (NOT *SENDING-BUG-REPORT*)) (TYPEOUT-BEEP-YES-OR-NO-P "There is no subject yet, ok to go ahead anyway? "))) (PREPARE-WINDOW-FOR-REDISPLAY *WINDOW*) (LET ((DEGREE (COM-ADD-SUBJECT-FIELD))) (MUST-REDISPLAY *WINDOW* DEGREE)) (ABORT-CURRENT-COMMAND))) LIST) ;;; Top-level handling of sending a message. Expands abbreviations and does Fcc: itself (DEFUN SEND-IT (PLIST) (LET ((FCC (GET PLIST ':FCC))) (AND FCC (LOOP FOR PATHNAME IN (GET-FCC-PATHNAMES FCC) WITH MSG = (CONSTRUCT-FCC-MSG PLIST *REPLY-INTERVAL*) COLLECT (STRING PATHNAME) INTO NAMES DO (FUNCALL (GET-MAIL-FILE-FROM-PATHNAME PATHNAME T) ':ADD-MSG MSG) FINALLY (PUTPROP PLIST NAMES ':FCC)))) (FUNCALL *MAIL-SENDING-MODE* PLIST *REPLY-INTERVAL* *DEFAULT-SEND-TEMPLATE*) (SETF (DRAFT-MSG-SENT-P *DRAFT-MSG*) T) (SETF (DRAFT-MSG-SUMMARY-STRING-TICK *DRAFT-MSG*) -1) (DOLIST (MSG (DRAFT-MSG-MSGS-BEING-REPLIED-TO *DRAFT-MSG*)) ;Mark if it was a reply (MSG-PUT MSG T 'ANSWERED)) (DOLIST (MSG (DRAFT-MSG-MSGS-BEING-FORWARDED *DRAFT-MSG*)) (MSG-PUT MSG T 'FORWARDED)) (TYPEIN-LINE "Message sent")) ;Erase any aborting message ;;; This is the interface from ZMACS C-X M and (MAIL). (DEFUN SEND-MESSAGE (HEADER-BP1 HEADER-BP2 HEADER-IN-ORDER-P TEXT-BP1 &OPTIONAL TEXT-BP2 TEXT-IN-ORDER-P &AUX LIST (PLIST (LOCF LIST))) (SETQ LIST (GET-SEND-HEADERS HEADER-BP1 HEADER-BP2 HEADER-IN-ORDER-P)) (GET-INTERVAL TEXT-BP1 TEXT-BP2 TEXT-IN-ORDER-P) (FUNCALL *MAIL-SENDING-MODE* PLIST (CREATE-INTERVAL TEXT-BP1 TEXT-BP2) *DEFAULT-SEND-TEMPLATE*)) ;;; This is for failing QSEND and friends (DEFUN SEND-MESSAGE-STRING (TO MESSAGE &AUX LIST PLIST) (SETQ LIST `(:TO ((:NAME ,TO))) PLIST (LOCF LIST)) (FUNCALL *MAIL-SENDING-MODE* PLIST (CREATE-INTERVAL MESSAGE) *DEFAULT-SEND-TEMPLATE*)) (DEFVAR *MAIL-QUEUE-FILE* "DSK: .MAIL.; MAIL >") (DEFUN FILE-SEND-IT (PLIST INTERVAL TEMPLATE &AUX FILE-NAME TEM USER) TEMPLATE ;COMSAT is in charge (LET ((ITS-PATHNAME (FS:USER-HOMEDIR))) (SETQ FILE-NAME (FS:PARSE-PATHNAME *MAIL-QUEUE-FILE* (IF (TYPEP ITS-PATHNAME 'FS:ITS-PATHNAME) (FUNCALL ITS-PATHNAME ':HOST) "AI")))) ;; Use the UNAME for ITS in the file (FUNCALL FILE-NAME ':HOMEDIR) (AND (OR (NULL (SETQ USER (CDR (ASSQ 'FS:ITS FS:USER-UNAMES)))) (STRING-EQUAL USER USER-ID)) (SETQ USER USER-ID)) (IF (NULL (SETQ TEM (GETL PLIST '(:FROM)))) (PUTPROP PLIST USER ':AUTHOR) (SETF (CAR TEM) ':AUTHOR) (SETF (CADR TEM) (LET ((FROM (CADR TEM))) ;; This is somewhat of a kludge, but COMSAT likes to put in the @MIT-AI itself. (STRING-INTERVAL (CAR (GET (LOCF (CAR FROM)) ':INTERVAL)) (CADR (GET (LOCF (CAR (LAST FROM))) ':INTERVAL)))))) (OR (GET PLIST ':HEADER-FORCE) (EQ *DEFAULT-HEADER-FORCE* ':NONE) (PUTPROP PLIST *DEFAULT-HEADER-FORCE* ':HEADER-FORCE)) (PUTPROP PLIST 'ZMAIL ':FROM-PROGRAM) (PUTPROP PLIST USER ':FROM-UNAME) (PUTPROP PLIST USER ':FROM-XUNAME) (WITH-OPEN-FILE (STREAM FILE-NAME '(OUT)) (DO ((LIST (CAR PLIST) (CDDR LIST)) (TYPE) (ITEMS) (CC-P NIL NIL)) ((NULL LIST)) (SETQ TYPE (CAR LIST) ITEMS (CADR LIST)) (AND (EQ TYPE ':CC) (SETQ TYPE ':TO CC-P T)) (OR (LISTP ITEMS) (SETQ ITEMS (NCONS ITEMS))) (DO ((ITEMS ITEMS (CDR ITEMS)) (ITEM) (HOST) (OPEN-P NIL NIL)) ((NULL ITEMS)) (SETQ ITEM (CAR ITEMS)) (IF (NEQ TYPE ':TO) (FORMAT STREAM "~A:~A~%" TYPE ITEM) (LET ((PL (LOCF ITEM))) (PSETQ ITEM (GET PL ':NAME) HOST (GET PL ':HOST))) (AND (NOT (NULL (CDR HOST))) (SETQ ITEM (FORMAT NIL "~A~{@~A~^~}" ITEM (CDR HOST)))) (SETQ HOST (CAR HOST)) ;; There is no consistent way to send structured recipients. ;; Also, quoting doesn't work right. (LET ((LEN-1 (1- (STRING-LENGTH ITEM)))) (COND ((MINUSP LEN-1)) ((AND (= (AREF ITEM 0) #/() (= (AREF ITEM LEN-1) #/))) (SETQ ITEM (SUBSTRING ITEM 1 LEN-1) OPEN-P T)) ((AND (= (AREF ITEM 0) #/") (= (AREF ITEM LEN-1) #/")) (SETQ OPEN-P T)))) (FORMAT STREAM "~A:(~:[/"~A/"~;~A~]~@[ ~A~]~:[~; (R-OPTION CC)~])~%" TYPE OPEN-P ITEM HOST CC-P)))) (FUNCALL STREAM ':LINE-OUT "TEXT;-1") (STREAM-OUT-INTERVAL STREAM INTERVAL))) ;;; Redistribution (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-REDISTRIBUTE-MSG "Redistribute this message" () (REDISTRIBUTE-MSG *MSG* (GET-REDISTRIBUTE-RECIPIENTS)) DIS-NONE) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-REDISTRIBUTE-ALL "Redistribute these messages" () (LOOP WITH RECIPIENTS = (GET-REDISTRIBUTE-RECIPIENTS) FOR MSG BEING THE MSGS IN *MAIL-FILE* DO (REDISTRIBUTE-MSG MSG RECIPIENTS)) DIS-NONE) (DEFUN GET-REDISTRIBUTE-RECIPIENTS (&AUX RECIPIENTS) (SETQ RECIPIENTS (TYPEIN-LINE-READLINE "Redistribute to:")) (SETQ RECIPIENTS (PARSE-ADDRESSES RECIPIENTS)) (OR (LISTP RECIPIENTS) (BARF "Cannot parse recipients: ~A" RECIPIENTS)) RECIPIENTS) (DEFUN REDISTRIBUTE-MSG (MSG RECIPIENTS &AUX (SENDING-MODE *MAIL-SENDING-MODE*) (*INTERVAL* (MSG-INTERVAL MSG)) (START-BP (INTERVAL-FIRST-BP *INTERVAL*)) (END-BP (INTERVAL-LAST-BP *INTERVAL*)) HEADER-INTERVAL BODY-INTERVAL HEADERS-END-BP LIST (PLIST (LOCF LIST))) (SETQ HEADERS-END-BP (OR (GET (ASSURE-MSG-PARSED MSG) 'HEADERS-END-BP) (DO ((LINE (BP-LINE START-BP) (LINE-NEXT LINE)) (END-LINE (BP-LINE END-BP))) (NIL) (AND (OR (EQ LINE END-LINE) (LINE-BLANK-P LINE)) (RETURN (CREATE-BP LINE 0)))))) (DO ((LINE (BP-LINE HEADERS-END-BP) PREV) (PREV) (BEG-LINE (BP-LINE START-BP))) ((OR (EQ LINE BEG-LINE) (NOT (LINE-BLANK-P (SETQ PREV (LINE-PREVIOUS LINE))))) (SETQ HEADERS-END-BP (CREATE-BP LINE 0)))) (SETQ HEADER-INTERVAL (CREATE-INTERVAL (MSG-START-BP MSG) HEADERS-END-BP)) (DO ((LINE (BP-LINE HEADERS-END-BP) (LINE-NEXT LINE)) (END-LINE (BP-LINE END-BP))) ((OR (EQ LINE END-LINE) (NOT (LINE-BLANK-P LINE))) (SETQ HEADERS-END-BP (CREATE-BP LINE 0)))) (SETQ BODY-INTERVAL (CREATE-INTERVAL HEADERS-END-BP (MSG-END-BP MSG))) (SETQ LIST `(:REDISTRIBUTED-TO ,RECIPIENTS REDISTRIBUTED-HEADERS ,HEADER-INTERVAL)) (AND (EQ SENDING-MODE 'FILE-SEND-IT) (SETQ SENDING-MODE 'CHAOS-SEND-IT)) (FUNCALL SENDING-MODE PLIST BODY-INTERVAL '(REDISTRIBUTED-HEADERS :REDISTRIBUTED-TO :REDISTRIBUTED-BY :REDISTRIBUTED-DATE)) (MSG-PUT MSG T 'REDISTRIBUTED)) ;;; Send a reply (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER COM-ZMAIL-REPLY (STRING &OPTIONAL RECURSIVE) (OR RECURSIVE (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'NORMAL-REPLY NIL T)) (STRING-NCONC STRING "Reply to current message: " (GET 'NORMAL-REPLY ':WHO-LINE-DOCUMENTATION))) (DEFVAR *ZMAIL-REPLY-PROCESSING-LIST* '(DRAFT-REPLY COMSAT-REPLY XMAILR-REPLY NORMAL-REPLY)) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-REPLY "Reply to current message. Left controlled by *REPLY-MODE* and *REPLY-WINDOW-MODE*. Middle controlled by *MIDDLE-REPLY-MODE* and *MIDDLE-REPLY-WINDOW-MODE*. Right gives a menu to specify recipients and window configuration. Numeric argument of 1 replies according to *1R-REPLY-MODE*. Numeric argument of 3 or 4 yanks in message. Messages from COMSAT or draft messages are treated specially." (NUMERIC-ARG-OK) (DO ((L *ZMAIL-REPLY-PROCESSING-LIST* (CDR L)) (MODE) (STARTING-WINDOW)) ((NULL L) (FERROR NIL "Reply was not processed")) (MULTIPLE-VALUE (MODE STARTING-WINDOW) (FUNCALL (CAR L) *MSG*)) (AND MODE (RETURN (ZMAIL-MAIL MODE STARTING-WINDOW))))) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER NORMAL-REPLY (STRING &OPTIONAL RECURSIVE) (APPEND-MULTIPLE-MENU-DOCUMENTATION STRING *REPLY-MODES-ALIST* "//" #/L *REPLY-MODE* *REPLY-WINDOW-MODE*) (APPEND-MULTIPLE-MENU-DOCUMENTATION STRING *REPLY-MODES-ALIST* "//" #/M *MIDDLE-REPLY-MODE* *MIDDLE-REPLY-WINDOW-MODE*) (APPEND-TO-ARRAY STRING " R: menu.") (OR RECURSIVE (DOLIST (COM '(COM-ZMAIL-REPLY COM-ZMAIL-REPLY-ALL SUMMARY-REPLY-DOCUMENTATION)) (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION COM NIL T)))) (ASSOCIATE-OPTION-WITH-COMMAND-DOCUMENTATION *REPLY-MODE* NORMAL-REPLY) (ASSOCIATE-OPTION-WITH-COMMAND-DOCUMENTATION *REPLY-WINDOW-MODE* NORMAL-REPLY) (ASSOCIATE-OPTION-WITH-COMMAND-DOCUMENTATION *MIDDLE-REPLY-MODE* NORMAL-REPLY) (ASSOCIATE-OPTION-WITH-COMMAND-DOCUMENTATION *MIDDLE-REPLY-WINDOW-MODE* NORMAL-REPLY) (DEFUN NORMAL-REPLY (&REST MSGS &AUX (REPLY-MODE *REPLY-MODE*) (REPLY-WINDOW-MODE *REPLY-WINDOW-MODE*)) (COND (*NUMERIC-ARG-P* (SELECTQ *NUMERIC-ARG* (1 (SETQ REPLY-MODE *1R-REPLY-MODE*)) ((3 4) (SETQ REPLY-WINDOW-MODE ':YANK)))) ((EQ *ZMAIL-COMMAND-BUTTON* ':MIDDLE) (SETQ REPLY-MODE *MIDDLE-REPLY-MODE* REPLY-WINDOW-MODE *MIDDLE-REPLY-WINDOW-MODE*)) ((EQ *ZMAIL-COMMAND-BUTTON* ':RIGHT) (MULTIPLE-VALUE (REPLY-MODE REPLY-WINDOW-MODE) (DEFAULTED-MULTIPLE-MENU-CHOOSE-NEAR-MENU *REPLY-MODES-ALIST* REPLY-MODE REPLY-WINDOW-MODE)))) (SETUP-FOR-REPLY MSGS REPLY-MODE REPLY-WINDOW-MODE)) ;;; For use in building user commands to do special replying. (DEFUN SETUP-FOR-REPLY (MSGS REPLY-MODE REPLY-WINDOW-MODE) (INITIALIZE-FOR-MAIL (LEXPR-FUNCALL #'MAKE-DRAFT-MSG MSGS)) (INSERT-REPLY-HEADERS REPLY-MODE) (AND (EQ REPLY-WINDOW-MODE ':YANK) (INSERT-MSGS-INTO-WINDOW *REPLY-WINDOW* T)) (VALUES (IF (EQ REPLY-WINDOW-MODE ':TWO-WINDOWS) ':REPLY ':MAIL) ':REPLY)) (DEFUN DRAFT-REPLY (MSG &AUX DRAFT-MSG) (COND ((MSG-DRAFT-MSG-P MSG) (SETQ DRAFT-MSG (MAKE-DRAFT-MSG-FROM-MSG MSG)) (INITIALIZE-FOR-MAIL DRAFT-MSG NIL) (VALUES (DRAFT-MSG-LAST-WINDOW-CONFIGURATION DRAFT-MSG) ':REPLY)))) (DEFUN COMSAT-REPLY (MSG &AUX START-BP END-BP FAILED-MSG-START-BP FAILED-RECIPIENTS) (COND ((AND (LET ((FROM (CAR (MSG-GET MSG ':FROM)))) (EQUAL (GET (LOCF FROM) ':NAME) "COMSAT")) (SETQ FAILED-MSG-START-BP (SEARCH (SETQ START-BP (MSG-START-BP MSG)) " Failed message follows: ------- " NIL NIL NIL (SETQ END-BP (MSG-END-BP MSG))))) (DO ((LINE (BP-LINE START-BP) (LINE-NEXT LINE)) (END-LINE (BP-LINE FAILED-MSG-START-BP)) (IDX)) ((EQ LINE END-LINE)) (COND ((AND (STRING-EQUAL-START LINE "FAILED: ") (DO ((IDX1 NIL)) (NIL) (OR (AND (SETQ IDX (STRING-REVERSE-SEARCH-CHAR #/; LINE IDX1)) (SETQ IDX1 (STRING-REVERSE-SEARCH-CHAR #\SP LINE IDX))) (RETURN NIL)) (AND (STRING-EQUAL LINE " at " (- IDX1 3) 0 (1+ IDX1)) (RETURN T)))) (SETQ FAILED-RECIPIENTS (APPEND FAILED-RECIPIENTS (PARSE-ADDRESSES LINE 7 IDX)))) ((SETQ IDX (STRING-SEARCH " is an unknown recipient." LINE)) (SETQ FAILED-RECIPIENTS (APPEND FAILED-RECIPIENTS (PARSE-ADDRESSES LINE 0 IDX)))))) (FAILED-MAILER-RETRY MSG FAILED-MSG-START-BP END-BP FAILED-RECIPIENTS)))) (DEFUN XMAILR-REPLY (MSG &AUX FAILED-RECIPIENTS-START-BP FAILED-MSG-START-BP FAILED-RECIPIENTS FAILED-MSG-END-BP) (COND ((AND (LET ((FROM (CAR (MSG-GET MSG ':FROM)))) (EQUAL (GET (LOCF FROM) ':PERSONAL-NAME) "The Mailer Daemon")) (SETQ FAILED-RECIPIENTS-START-BP (SEARCH (MSG-START-BP MSG) " Message failed for the following: " NIL NIL NIL (MSG-END-BP MSG))) (SETQ FAILED-MSG-START-BP (SEARCH FAILED-RECIPIENTS-START-BP " ------------ " NIL NIL NIL (MSG-END-BP MSG)))) (DO ((LINE (BP-LINE FAILED-RECIPIENTS-START-BP) (LINE-NEXT LINE)) (END-LINE (LINE-PREVIOUS (BP-LINE FAILED-MSG-START-BP)))) ((EQ LINE END-LINE)) (SETQ FAILED-RECIPIENTS (APPEND FAILED-RECIPIENTS (PARSE-ADDRESSES LINE 0 (STRING-SEARCH-CHAR #/: LINE))))) (DO ((LINE (BP-LINE (MSG-END-BP MSG)) PLINE) (PLINE)) ((NOT (STRING-EQUAL (SETQ PLINE (LINE-PREVIOUS LINE)) "-------")) (SETQ FAILED-MSG-END-BP (CREATE-BP LINE 0)))) (FAILED-MAILER-RETRY MSG FAILED-MSG-START-BP FAILED-MSG-END-BP FAILED-RECIPIENTS)))) (DEFUN FAILED-MAILER-RETRY (MSG START-BP END-BP RECIPIENTS &AUX HEADERS) (MULTIPLE-VALUE (HEADERS START-BP) (PARSE-MSG-HEADERS START-BP END-BP T)) (INITIALIZE-FOR-MAIL (MAKE-DRAFT-MSG MSG) NIL) (DELETE-INTERVAL *HEADER-INTERVAL*) (LET* ((POINT (WINDOW-POINT *HEADER-WINDOW*)) (LINE (BP-LINE POINT)) (SUBJECT)) (INSERT-REPLY-HEADER-LIST POINT RECIPIENTS ':TO) (COND ((SETQ SUBJECT (GET (LOCF HEADERS) ':SUBJECT)) (AND (LISTP SUBJECT) (SETQ SUBJECT (CAR SUBJECT))) (OR (BEG-LINE-P POINT) (INSERT-MOVING POINT #\CR)) (INSERT-MOVING POINT "Subject: ") (INSERT POINT SUBJECT))) (MOVE-BP POINT LINE 5)) (INSERT-INTERVAL-MOVING (WINDOW-POINT *REPLY-WINDOW*) START-BP END-BP T) (VALUES ':MAIL ':HEADER)) ;;; Make headers right for this message (DEFUN INSERT-REPLY-HEADERS (REPLY-MODE &AUX (POINT (WINDOW-POINT *HEADER-WINDOW*)) MSGS FROM TO) (SETQ MSGS (DRAFT-MSG-MSGS-BEING-REPLIED-TO *DRAFT-MSG*)) (LOOP FOR MSG IN MSGS AS STATUS = (ASSURE-MSG-PARSED MSG) DO (SETQ FROM (APPEND FROM (REPLY-HEADER-TRIM (OR (GET STATUS ':REPLY-TO) (GET STATUS ':FROM)) FROM)))) (LOOP FOR MSG IN MSGS AS STATUS = (ASSURE-MSG-PARSED MSG) DO (SETQ TO (APPEND TO (REPLY-HEADER-TRIM (GET STATUS ':TO) TO)))) (AND (MEMQ REPLY-MODE '(:ALL :ALL-CC :TO :TO-CC :CC-TO :CC-ALL)) (INSERT-REPLY-HEADER-LIST POINT (REPLY-HEADER-TRIM (REPLY-HEADER-TRIM TO FROM) *DONT-REPLY-TO* T) (IF (MEMQ REPLY-MODE '(:ALL :TO :CC-TO :CC-ALL)) ':TO ':CC))) (AND (MEMQ REPLY-MODE '(:ALL :ALL-CC :CC-ALL)) (INSERT-REPLY-HEADER-LIST POINT (LOOP FOR MSG IN MSGS AS STATUS = (ASSURE-MSG-PARSED MSG) WITH CC DO (SETQ CC (APPEND CC (REPLY-HEADER-TRIM (GET STATUS ':CC) CC))) FINALLY (RETURN (REPLY-HEADER-TRIM (REPLY-HEADER-TRIM CC (APPEND FROM TO)) *DONT-REPLY-TO* T))) ':CC)) (LET (SUBJECT) (LOOP FOR MSG IN MSGS UNTIL (SETQ SUBJECT (GET (ASSURE-MSG-PARSED MSG) ':SUBJECT))) (COND (SUBJECT (AND (LISTP SUBJECT) (SETQ SUBJECT (CAR SUBJECT))) (OR (BEG-LINE-P POINT) (INSERT-MOVING POINT #\CR)) (INSERT-MOVING POINT "Subject: ") (INSERT-MOVING POINT SUBJECT) (INSERT POINT #\CR)))) (AND *GENERATE-IN-REPLY-TO-FIELD* (LET ((IN-REPLY-TO (GENERATE-IN-REPLY-TO-HEADER))) (COND (IN-REPLY-TO (OR (BEG-LINE-P POINT) (INSERT-MOVING POINT #\CR)) (INSERT-MOVING POINT (WITH-OUTPUT-TO-STRING (STREAM) (PRINT-HEADER STREAM IN-REPLY-TO ':IN-REPLY-TO))) (INSERT POINT #\CR))))) (MOVE-BP POINT (INTERVAL-FIRST-BP *HEADER-INTERVAL*)) (AND FROM (INSERT-REPLY-HEADER-LIST POINT FROM (IF (MEMQ REPLY-MODE '(:CC-ALL :CC-TO)) ':CC ':TO)))) (DEFUN REPLY-HEADER-TRIM (LIST-TO-TRIM LIST-TO-REMOVE &OPTIONAL STAR-SPECIAL) (LOOP FOR NEW IN LIST-TO-TRIM UNLESS (OR (WARN-OF-UNANSWERABLE-HEADER NEW) (MEMQ NEW INFERIORS) (LOOP FOR OLD IN LIST-TO-REMOVE THEREIS (REPLY-HEADER-TRIM-EQUAL NEW OLD STAR-SPECIAL))) COLLECT NEW WHEN (AND (GETL (LOCF NEW) '(:DISTRIBUTION-LIST :BRACKETED-LIST)) (EQ *REPLY-HEADER-FORMAT* ':USE-ORIGINAL)) NCONC (GET-HEADER-INFERIORS NEW) INTO INFERIORS)) (DEFUN GET-HEADER-INFERIORS (HEADER) (LOOP FOR INF IN (GET (LOCF HEADER) ':INFERIORS) NCONC (CONS INF (GET-HEADER-INFERIORS INF)))) (DEFUN WARN-OF-UNANSWERABLE-HEADER (HEADER &AUX (PLIST (LOCF HEADER))) (COND ((GET PLIST ':NAME) NIL) ;OK, normal header ((AND (GETL PLIST '(:DISTRIBUTION-LIST :BRACKETED-LIST)) (GET PLIST ':INFERIORS)) (NEQ *REPLY-HEADER-FORMAT* ':USE-ORIGINAL)) ;Use or ignore silently (T (FORMAT T "~&Cannot reply to /"~A/", address flushed~%" (STRING-FROM-HEADER HEADER ':USE-ORIGINAL)) T))) (DEFVAR *QUOTE-HOSTS-FOR-XMAILR* NIL) (DEFUN STRING-FROM-HEADER (HEADER FORMAT &AUX (PLIST (LOCF HEADER)) TEM) (IF (AND (EQ FORMAT ':USE-ORIGINAL) (SETQ TEM (GET PLIST ':INTERVAL))) (STRING-INTERVAL (FIRST TEM) (SECOND TEM) T) (LET ((STRING (GET PLIST ':NAME))) ;; If talking to the server, strip off any quoting (AND (EQ FORMAT ':HOST) (LET ((LEN (1- (STRING-LENGTH STRING)))) (AND (PLUSP LEN) (= (AREF STRING 0) #/") (= (AREF STRING LEN) #/") (SETQ STRING (SUBSTRING STRING 1 LEN))))) (LET ((HOST (GET PLIST ':HOST)) (AT (IF (MEMQ FORMAT '(:SHORT :HOST)) #/@ " at "))) (IF (AND HOST *QUOTE-HOSTS-FOR-XMAILR*) (SETQ STRING (STRING-APPEND STRING AT #/ (CAR HOST) #/)) (DOLIST (HOST HOST) (SETQ STRING (STRING-APPEND STRING AT HOST))))) (AND (MEMQ FORMAT '(:USE-ORIGINAL :INCLUDE-PERSONAL)) (SETQ TEM (GET PLIST ':PERSONAL-NAME)) (SETQ STRING (STRING-APPEND TEM " <" STRING #/>))) STRING))) (DEFUN REPLY-HEADER-TRIM-EQUAL (NEW OLD STAR-SPECIAL &AUX SL NL) (COND (STAR-SPECIAL (SETQ SL (STRING-LENGTH OLD)) (AND (= (AREF OLD (1- SL)) #/*) (SETQ SL (1- SL) NL SL))) (T (SETQ OLD (GET (LOCF OLD) ':NAME)))) (SETQ NEW (GET (LOCF NEW) ':NAME)) (STRING-EQUAL NEW OLD 0 0 NL SL)) (DEFUN INSERT-REPLY-HEADER-LIST (BP LIST TYPE &AUX NAME) (SETQ NAME (HEADER-TYPE-NAME TYPE)) (OR (BEG-LINE-P BP) (INSERT-MOVING BP #\CR)) (DO ((L LIST (CDR L)) (FLAG NIL T) (BP1 (COPY-BP BP))) ((NULL L) (AND FLAG (INSERT-MOVING BP #\CR))) (IF FLAG (INSERT-MOVING BP #/,) (INSERT-MOVING BP NAME) (INSERT-MOVING BP ": ")) (MOVE-BP BP1 BP) (INSERT-MOVING BP (STRING-FROM-HEADER (CAR L) *REPLY-HEADER-FORMAT*)) (INSERT BP1 (IF (< (BP-INDEX BP) 72.) #\SP " ")))) (DEFCOM COM-ADD-TO-FIELD "Add another to recipient. With a negative argument, removes the to field With a zero argument, only selects the start of that field." () (ADD-RECIPIENT-FIELD ':TO) DIS-TEXT) (DEFCOM COM-ADD-CC-FIELD "Add another cc recipient. With a negative argument, removes the cc field With a zero argument, only selects the start of that field." () (ADD-RECIPIENT-FIELD ':CC) DIS-TEXT) (DEFUN ADD-RECIPIENT-FIELD (TYPE &AUX BP BP2) (MULTIPLE-VALUE (BP BP2) (ADD-HEADER-FIELD TYPE (MINUSP *NUMERIC-ARG*) (MINUSP *NUMERIC-ARG*))) (AND BP2 (PLUSP *NUMERIC-ARG*) (NOT (END-LINE-P BP)) (LET ((BP3 (END-LINE BP2 -1))) (IF (< (BP-INDENTATION BP3) *FILL-COLUMN*) (SETQ BP2 (INSERT BP3 ", ")) (INSERT BP3 #/,) (COND ((NOT (LINE-BLANK-P (BP-LINE BP2))) (INSERT BP2 #\CR) (SETQ BP2 (BEG-LINE BP2 -1)))) (INSERT-MOVING BP2 " ")) (MOVE-BP (POINT) BP2)))) (DEFVAR *SUBJECT-PRONOUN-FROM-LIST*) (DEFVAR *SUBJECT-PRONOUN-TO-LIST*) (DEFUN INITIALIZE-SUBJECT-PRONOUN-LISTS (&AUX L1 L2) (DOLIST (ELEM '(("i" "you") ("me" "you") ("my" "your") ("mine" "yours") ("here" "there"))) (PUSH (CAR ELEM) L1) (PUSH (CADR ELEM) L2) (PUSH (CADR ELEM) L1) (PUSH (CAR ELEM) L2)) (SETQ *SUBJECT-PRONOUN-FROM-LIST* (NREVERSE L1) *SUBJECT-PRONOUN-TO-LIST* (NREVERSE L2))) (INITIALIZE-SUBJECT-PRONOUN-LISTS) (DEFCOM COM-CHANGE-SUBJECT-PRONOUNS "Fix up the subject field" () (ADD-HEADER-FIELD ':SUBJECT NIL NIL) (LET ((*INTERVAL* (CREATE-INTERVAL (COPY-BP (POINT) ':NORMAL) (COPY-BP (BEG-LINE (POINT) 1 T) ':MOVES)))) (QUERY-REPLACE-LIST (POINT) *SUBJECT-PRONOUN-FROM-LIST* *SUBJECT-PRONOUN-TO-LIST* T)) DIS-TEXT) (DEFCOM COM-ADD-SUBJECT-FIELD "Add a subject field. With a negative argument, removes the subject field With a zero argument, only selects the start of that field." () (ADD-HEADER-FIELD ':SUBJECT (NOT (ZEROP *NUMERIC-ARG*)) (MINUSP *NUMERIC-ARG*)) DIS-TEXT) (DEFCOM COM-ADD-FROM-FIELD "Add a from field. With a negative argument, removes the from field. With a zero argument, only selects the start of that field." () (ADD-HEADER-FIELD ':FROM (NOT (ZEROP *NUMERIC-ARG*)) (MINUSP *NUMERIC-ARG*)) DIS-TEXT) (DEFUN ADD-HEADER-FIELD (TYPE DELETE-P DELETE-HEADER-TOO-P &AUX NAME FIRST-BP LAST-BP STOP-AT-BLANK BP BP2) (SETQ NAME (HEADER-TYPE-NAME TYPE)) (COND (*INSIDE-MAIL* (SET-MAIL-WINDOW-CONFIGURATION NIL ':HEADER) (SETQ FIRST-BP (INTERVAL-FIRST-BP *HEADER-INTERVAL*) LAST-BP (INTERVAL-LAST-BP *HEADER-INTERVAL*))) (T (SETQ FIRST-BP (INTERVAL-FIRST-BP *INTERVAL*) LAST-BP (INTERVAL-LAST-BP *INTERVAL*) STOP-AT-BLANK T))) (OR (BEG-LINE-P LAST-BP) (INSERT LAST-BP #\CR)) (DO ((LINE (BP-LINE FIRST-BP) (LINE-NEXT LINE)) (LAST-LINE (BP-LINE LAST-BP)) (LEN (STRING-LENGTH NAME))) (NIL) (AND STOP-AT-BLANK (LINE-BLANK-P LINE) (RETURN (SETQ LAST-BP (CREATE-BP LINE 0)))) (AND (> (LINE-LENGTH LINE) LEN) (STRING-EQUAL LINE NAME 0 0 LEN LEN) (= (AREF LINE LEN) #/:) (RETURN (SETQ BP (CREATE-BP LINE (1+ LEN))))) (AND (EQ LINE LAST-LINE) (RETURN NIL))) (COND ((NULL BP) (SETQ BP (COPY-BP LAST-BP)) (COND ((NOT DELETE-HEADER-TOO-P) (INSERT-MOVING BP NAME) (INSERT-MOVING BP ": ") (INSERT BP #\CR)))) (T (IF DELETE-HEADER-TOO-P (SETQ BP (BEG-LINE BP)) (SETQ BP (FORWARD-OVER *BLANKS* BP))) (SETQ BP2 (CREATE-BP (DO ((LINE (LINE-NEXT (BP-LINE BP)) (LINE-NEXT LINE)) (LAST-LINE (BP-LINE LAST-BP))) ((EQ LINE LAST-LINE) LINE) (OR (AND (NOT (ZEROP (LINE-LENGTH LINE))) (MEMQ (AREF LINE 0) *BLANKS*)) (RETURN LINE))) 0)) (COND (DELETE-P (AND (NOT DELETE-HEADER-TOO-P) (SETQ BP2 (END-LINE BP2 -1))) (WITH-BP (SAVE-BP BP ':NORMAL) (KILL-INTERVAL BP BP2 T) (MOVE-BP BP SAVE-BP) (SETQ *CURRENT-COMMAND-TYPE* 'KILL)))))) (POINT-PDL-PUSH (POINT) *WINDOW*) (MOVE-BP (POINT) BP) (VALUES BP BP2)) (DEFCOM COM-ADD-MORE-TEXT "Reselect the text portion of the message" () (COND (*INSIDE-MAIL* (SET-MAIL-WINDOW-CONFIGURATION NIL ':REPLY) DIS-NONE) (T (MOVE-BP (POINT) (INTERVAL-LAST-BP *INTERVAL*)) DIS-BPS))) (DEFVAR *PRUNE-YANKED-HEADERS-KEEP-HEADERS* '(:DATE :FROM :ITS)) (DEFCOM COM-PRUNE-YANKED-HEADERS "Shorten up the headers on a yanked message" () (PROG TOP ((BP (COPY-BP (INTERVAL-FIRST-BP *REPLY-INTERVAL*)))) (DO ((LINE (BP-LINE BP) (LINE-NEXT LINE)) (LAST-LINE (BP-LINE (INTERVAL-LAST-BP *REPLY-INTERVAL*))) (STATE NIL) (TYPE)) (NIL) (SETQ TYPE (HEADER-LINE-TYPE LINE)) (COND ((EQ TYPE ':UNKNOWN) ;End of headers (COND (STATE (KILL-INTERVAL BP (CREATE-BP LINE 0) T) ;Things to be flushed (SETQ *LAST-COMMAND-TYPE* 'KILL ;Append any more kills *CURRENT-COMMAND-TYPE* 'KILL))) (MOVE-BP (POINT) LINE 0) (RETURN-FROM TOP NIL)) ((MEMQ TYPE *PRUNE-YANKED-HEADERS-KEEP-HEADERS*) (COND (STATE ;Things to be flushed (DELETE-INTERVAL BP (CREATE-BP LINE 0) T) (SETQ STATE NIL)))) ;No more (T (COND ((NOT STATE) ;Start flushing here (MOVE-BP BP LINE 0) (SETQ STATE T))))) (AND (EQ LINE LAST-LINE) (RETURN-FROM TOP NIL)))) DIS-TEXT) (DEFUN HEADER-LINE-TYPE (LINE &AUX LEXEMES) (IF (NLISTP (SETQ LEXEMES (RFC733-LEXER LINE 0 NIL NIL))) ':UNKNOWN (SELECTQ (CAAR LEXEMES) (EOF ':BLANK) (ATOM (SELECTQ (CAADR LEXEMES) ((ATSIGN AT-ATOM) (IF (EQ (CAADDR LEXEMES) 'ATOM) ':ITS ':UNKNOWN)) (COLON (OR (CDR (ASSOC (CADAR LEXEMES) *HEADER-NAME-ALIST*)) ':UNKNOWN)) (OTHERWISE ':UNKNOWN))) (OTHERWISE ':UNKNOWN)))) (DEFCOM COM-ADD-FCC-FIELD "Add another file recipient" () (LET ((MAIL-FILE (AND (NOT *NUMERIC-ARG-P*) (OR (GET-MOVE-MAIL-FILE) (ABORT-CURRENT-COMMAND))))) (ADD-RECIPIENT-FIELD ':FCC) (AND MAIL-FILE (INSERT-MOVING (POINT) (MAIL-FILE-NAME MAIL-FILE)))) DIS-TEXT) (DEFCOM COM-ADD-IN-REPLY-TO-FIELD "Add an in-reply-to field" () (LET ((IN-REPLY-TO (GENERATE-IN-REPLY-TO-HEADER))) (OR IN-REPLY-TO (BARF)) (ADD-HEADER-FIELD ':IN-REPLY-TO T T) (INSERT-MOVING (POINT) (WITH-OUTPUT-TO-STRING (STREAM) (PRINT-HEADER STREAM IN-REPLY-TO ':IN-REPLY-TO)))) DIS-TEXT) (DEFUN GENERATE-IN-REPLY-TO-HEADER () (APPLY #'GENERATE-REFERENCE-HEADER (DRAFT-MSG-MSGS-BEING-REPLIED-TO *DRAFT-MSG*))) (DEFUN GENERATE-REFERENCE-HEADER (&REST MSGS &AUX TEM) (LOOP FOR MSG IN MSGS AS STATUS = (ASSURE-MSG-PARSED MSG) COLLECT (IF (SETQ TEM (GET STATUS ':MESSAGE-ID)) `(:MESSAGE-ID ,TEM) `(:DATE ,(GET STATUS ':DATE) :FROM ,(CAR (GET STATUS ':FROM)))))) (DEFCOM COM-ADD-REFERENCES-FIELD "Add a References field" () (LET ((REFERENCES (REFERENCES-FOR-MAIL-FILE *MAIL-FILE*))) (OR REFERENCES (BARF)) (ADD-HEADER-TYPE-FIELD REFERENCES ':REFERENCES)) DIS-TEXT) (DEFUN ADD-HEADER-TYPE-FIELD (VAL TYPE) (ADD-HEADER-FIELD TYPE T T) (INSERT-MOVING (POINT) (WITH-OUTPUT-TO-STRING (STREAM) (PRINT-HEADER STREAM VAL TYPE)))) (DEFUN REFERENCES-FOR-MAIL-FILE (MAIL-FILE) (APPLY-ARRAY #'GENERATE-REFERENCE-HEADER (MAIL-FILE-ARRAY MAIL-FILE))) (DEFCOM COM-ADD-EXPIRATION-DATE-FIELD "Add an Expiration-date field" () (ADD-DATE-FIELD ':EXPIRATION-DATE)) (DEFUN ADD-DATE-FIELD (FIELD &AUX DATE) (SETQ DATE (TYPEIN-LINE-READLINE "Add ~A:" (HEADER-TYPE-NAME FIELD))) (SETQ DATE (TIME:PARSE-UNIVERSAL-TIME DATE)) (AND (STRINGP DATE) (BARF "Bad date: ~A" DATE)) (ADD-HEADER-TYPE-FIELD DATE FIELD) DIS-TEXT) (DEFCOM COM-ZMAIL-OTHER-WINDOW "Move to another other window" () (ROTATE-TO-OTHER-WINDOW (OR (OTHER-WINDOW) (BARF))) (SETQ *END-SENDS-MESSAGE-P* (NEQ *WINDOW* *HEADER-WINDOW*)) DIS-NONE) (DEFCOM COM-ZMAIL-YANK "Insert the message being replied to" () (LET ((CONFIG *WINDOW-CONFIGURATION*)) (AND *ONE-WINDOW-AFTER-YANK* (EQ CONFIG ':REPLY) (SETQ CONFIG ':SEND)) (SET-MAIL-WINDOW-CONFIGURATION CONFIG ':REPLY)) (INSERT-MSGS-INTO-WINDOW (IF (MEMQ *WINDOW-CONFIGURATION* *MSG-WINDOW-CONFIGURATIONS*) *MSG-WINDOW* *REPLY-WINDOW*) (NOT *NUMERIC-ARG-P*)) (SETQ *CURRENT-COMMAND-TYPE* 'YANK) DIS-TEXT) (DEFCOM COM-ZMAIL-REPLY-ONE-WINDOW "Just the text of the message being sent" () (SET-MAIL-WINDOW-CONFIGURATION ':SEND) (AND (EQ *WINDOW* *MSG-WINDOW*) (MAKE-WINDOW-CURRENT *REPLY-WINDOW*)) DIS-NONE) (DEFCOM COM-ZMAIL-REPLY-ZERO-WINDOWS "All of message in message window" () (SET-MAIL-WINDOW-CONFIGURATION ':BOTH (SELECT *WINDOW* (*HEADER-WINDOW* ':HEADER) (*REPLY-WINDOW* ':REPLY))) DIS-ALL) (DEFCOM COM-ZMAIL-REPLY-TWO-WINDOWS "Both the message and the reply" () (SET-MAIL-WINDOW-CONFIGURATION ':REPLY) DIS-NONE) (DEFUN INSERT-MSGS-INTO-WINDOW (WINDOW INDENT-P &OPTIONAL MSG) (LET ((POINT (WINDOW-POINT WINDOW)) (MARK (WINDOW-MARK WINDOW))) (SETQ *CURRENT-COMMAND-TYPE* 'YANK) (MOVE-BP MARK POINT) (POINT-PDL-PUSH POINT WINDOW NIL NIL) (AND (NULL MSG) (NULL *MSGS-BEING-REPLIED-TO-INTERVAL*) (SETQ MSG *MSG*)) (INSERT-INTERVAL-MOVING POINT (IF (NULL MSG) *MSGS-BEING-REPLIED-TO-INTERVAL* (MSG-INTERVAL MSG))) (AND INDENT-P (LET ((NON-BLANK-POINT (BACKWARD-OVER '(#\CR) POINT))) (INTERVAL-LINES (MARK NON-BLANK-POINT) (START-LINE STOP-LINE) (DO ((LINE START-LINE (LINE-NEXT LINE)) (DELTA (* 4 (FONT-SPACE-WIDTH)))) ((EQ LINE STOP-LINE)) (OR (LINE-BLANK-P LINE) (INDENT-LINE (CREATE-BP LINE 0) (+ DELTA (LINE-INDENTATION LINE)))))))) POINT)) (DEFCOM COM-RESTORE-DRAFT-FILE "Restore the saved text of the message from the given file." () (READ-DEFAULT-DRAFT-PATHNAME "Restore draft" (DRAFT-MSG-PATHNAME *DRAFT-MSG*)) (RESTORE-DRAFT-INTERNAL *HEADER-INTERVAL* *REPLY-INTERVAL*) (IF (MEMQ *WINDOW-CONFIGURATION* *MSG-WINDOW-CONFIGURATIONS*) (MUST-REDISPLAY *MSG-WINDOW* DIS-TEXT) (MUST-REDISPLAY *HEADER-WINDOW* DIS-TEXT) (MUST-REDISPLAY *REPLY-WINDOW* DIS-TEXT)) (SET-MAIL-WINDOW-CONFIGURATION NIL ':REPLY) (MOVE-BP (POINT) (INTERVAL-LAST-BP *REPLY-INTERVAL*)) DIS-NONE) (DEFUN MAKE-DRAFT-MSG-FROM-RESTORED-DRAFT (&AUX DRAFT-MSG) (CALL-POP-UP-MINI-BUFFER-EDITOR ':MOUSE #'READ-DEFAULT-DRAFT-PATHNAME "Restore draft") (SETQ DRAFT-MSG (MAKE-DRAFT-MSG)) (RESTORE-DRAFT-INTERNAL (DRAFT-MSG-HEADER-INTERVAL DRAFT-MSG) (DRAFT-MSG-REPLY-INTERVAL DRAFT-MSG)) (SETF (DRAFT-MSG-PATHNAME DRAFT-MSG) *DEFAULT-DRAFT-FILE-NAME*) DRAFT-MSG) (DEFUN RESTORE-DRAFT-INTERNAL (HEADER-INTERVAL REPLY-INTERVAL) (WITH-OPEN-FILE (STREAM *DEFAULT-DRAFT-FILE-NAME* '(:IN)) (DELETE-INTERVAL HEADER-INTERVAL) (DO ((INT-STREAM (INTERVAL-STREAM HEADER-INTERVAL)) (LINE)) (NIL) (AND (OR (NULL (SETQ LINE (FUNCALL STREAM ':LINE-IN LINE-LEADER-SIZE))) (ZEROP (ARRAY-ACTIVE-LENGTH LINE))) (RETURN NIL)) (FUNCALL INT-STREAM ':LINE-OUT LINE)) (DELETE-INTERVAL REPLY-INTERVAL) (STREAM-INTO-BP STREAM (INTERVAL-LAST-BP REPLY-INTERVAL)))) (DEFCOM COM-SAVE-DRAFT-FILE "Save the text of the message being composed." () (AND (NULL (DRAFT-MSG-PATHNAME *DRAFT-MSG*)) (READ-DEFAULT-DRAFT-PATHNAME "Save draft" NIL ':WRITE)) (SAVE-DRAFT-FILE-INTERNAL)) (DEFCOM COM-WRITE-DRAFT-FILE "Save the text of the message being composed to the given file." () (READ-DEFAULT-DRAFT-PATHNAME "Write draft" (DRAFT-MSG-PATHNAME *DRAFT-MSG*) ':WRITE) (SAVE-DRAFT-FILE-INTERNAL)) (DEFUN SAVE-DRAFT-FILE-INTERNAL () (WITH-OPEN-FILE (STREAM *DEFAULT-DRAFT-FILE-NAME* '(:OUT)) (DO ((LINE (BP-LINE (INTERVAL-FIRST-BP *HEADER-INTERVAL*)) (LINE-NEXT LINE)) (END-LINE (BP-LINE (INTERVAL-LAST-BP *HEADER-INTERVAL*)))) ((NULL LINE)) (OR (ZEROP (LINE-LENGTH LINE)) ;Don't write blank lines here (FUNCALL STREAM ':LINE-OUT LINE)) (AND (EQ LINE END-LINE) (RETURN NIL))) (FUNCALL STREAM ':TYO #\CR) ;Separate by blank line (STREAM-OUT-INTERVAL STREAM *REPLY-INTERVAL*) (CLOSE STREAM) (TYPEIN-LINE "Written: ~A" (FUNCALL STREAM ':TRUENAME))) (SETF (DRAFT-MSG-PATHNAME *DRAFT-MSG*) *DEFAULT-DRAFT-FILE-NAME*) DIS-NONE) (DEFUN READ-DEFAULT-DRAFT-PATHNAME (PROMPT &OPTIONAL DEFAULT (DIRECTION ':READ)) (SETQ *DEFAULT-DRAFT-FILE-NAME* (READ-DEFAULTED-PATHNAME PROMPT (OR DEFAULT *DEFAULT-DRAFT-FILE-NAME* (FUNCALL (FS:USER-HOMEDIR) ':NEW-NAME "DRAFT")) NIL NIL DIRECTION))) (DEFVAR *DRAFT-MSG-INTERNAL-HEADERS* '(:DATE :DRAFT-COMPOSITION-DATE)) (DEFUN MAKE-DRAFT-MSG-FROM-MSG (MSG &AUX DRAFT-MSG) (OR (MSG-DRAFT-MSG-P MSG) (BARF "This is not a draft message")) (COND ((AND (SETQ DRAFT-MSG (MSG-GET MSG 'DRAFT-MSG)) (= (NODE-TICK (MSG-INTERVAL MSG)) (NODE-TICK DRAFT-MSG)))) ;Already one and not modified (T (SETQ DRAFT-MSG (MAKE-DRAFT-MSG)) (SETF (DRAFT-MSG-MSG DRAFT-MSG) MSG) (MSG-PUT MSG DRAFT-MSG 'DRAFT-MSG) (LET ((MSG-INT (MSG-INTERVAL MSG)) (START-BP (INTERVAL-FIRST-BP DRAFT-MSG))) ;;Copy the text of the message, except for the composition-date (INSERT-INTERVAL START-BP (DO ((LINE (BP-LINE (INTERVAL-FIRST-BP MSG-INT)) (LINE-NEXT LINE))) ((NOT (GETL (LOCF (GET (LOCF (LINE-CONTENTS-PLIST LINE)) 'PARSED-HEADERS)) *DRAFT-MSG-INTERNAL-HEADERS*)) (CREATE-BP LINE 0))) (INTERVAL-LAST-BP MSG-INT) T) ;;Separate the headers from the text by finding the first blank line (DO ((LINE (BP-LINE START-BP) (LINE-NEXT LINE)) (END-LINE (BP-LINE (INTERVAL-LAST-BP DRAFT-MSG)))) ((EQ LINE END-LINE)) (COND ((LINE-BLANK-P LINE) (MOVE-BP (INTERVAL-LAST-BP (DRAFT-MSG-HEADER-INTERVAL DRAFT-MSG)) LINE 0) (MOVE-BP (INTERVAL-FIRST-BP (DRAFT-MSG-REPLY-INTERVAL DRAFT-MSG)) (LINE-NEXT LINE) 0) (RETURN)))) (SETF (NODE-TICK DRAFT-MSG) (TICK)) (SETF (NODE-TICK MSG-INT) *TICK*)))) DRAFT-MSG) (DEFCOM COM-SAVE-DRAFT-AS-MSG "Save the text of the message being composed as a message" () (LET ((MSG (AND (NOT *NUMERIC-ARG-P*) (DRAFT-MSG-MSG *DRAFT-MSG*))) (NEW-MAIL-FILE NIL)) (COND ((AND MSG (NEQ (MSG-PARSED-P MSG) ':KILLED)) (SETF (MSG-STATUS MSG) (SOME-PLIST (MSG-STATUS MSG) *INTERNAL-TYPE-PROPERTIES*)) (SETF (MSG-TICK MSG) (TICK)) (FUNCALL *SUMMARY-WINDOW* ':NEED-TO-REDISPLAY-MSG MSG)) (T (SETQ NEW-MAIL-FILE (COND ((NULL *MAIL-FILE-FOR-DRAFTS*) (OR *PRIMARY-MAIL-FILE* (LOOP FOR MF IN *MAIL-FILE-LIST* WHEN (MAIL-FILE-DISK-P MF) RETURN MF) (BARF "There is no disk mail file to put a draft message in." ))) ((GET-MAIL-FILE-FROM-PATHNAME (FS:MERGE-PATHNAME-DEFAULTS *MAIL-FILE-FOR-DRAFTS* *ZMAIL-PATHNAME-DEFAULTS*) T))) MSG (MAKE-EMPTY-MSG)) (SETF (DRAFT-MSG-MSG *DRAFT-MSG*) MSG) (FUNCALL *SUMMARY-WINDOW* ':NEED-FULL-REDISPLAY))) (LET ((END-BP (INTERVAL-LAST-BP *HEADER-INTERVAL*))) (OR (BEG-LINE-P END-BP) (INSERT END-BP #\CR))) (LET ((END-BP (INTERVAL-LAST-BP *REPLY-INTERVAL*))) (OR (BEG-LINE-P END-BP) (INSERT END-BP #\CR))) (LET ((INTERVAL (MSG-INTERVAL MSG))) (DELETE-INTERVAL INTERVAL) (LET ((END-BP (INTERVAL-LAST-BP INTERVAL)) (PLIST (LOCF (MSG-STATUS MSG))) (NOW (TIME:GET-UNIVERSAL-TIME))) (OR (GET PLIST ':DATE) (PUTPROP PLIST NOW ':DATE)) (PUTPROP PLIST NOW ':DRAFT-COMPOSITION-DATE) (INSERT-MOVING END-BP (WITH-OUTPUT-TO-STRING (STREAM) (OUTPUT-HEADER STREAM PLIST *DRAFT-MSG-INTERNAL-HEADERS* NIL NIL))) (INSERT-INTERVAL END-BP *DRAFT-MSG*)) (SETF (NODE-TICK INTERVAL) (TICK)) (SETF (NODE-TICK *DRAFT-MSG*) *TICK*)) (AND NEW-MAIL-FILE (FUNCALL NEW-MAIL-FILE ':ADD-MSG MSG)) (TYPEIN-LINE "Saved in ~A" (MAIL-FILE-NAME (MSG-MAIL-FILE MSG))) (IF NEW-MAIL-FILE (MSG-PUT MSG *DRAFT-MSG* 'DRAFT-MSG) (SET-PARSED-MSG-HEADERS MSG)) (AND (EQ MSG *MSG*) (MUST-REDISPLAY *MSG-WINDOW* DIS-TEXT))) DIS-NONE) ;;; If non-NIL, this host is tried first (DEFINE-SITE-HOST-LIST *MAIL-CHAOS-HOSTS* :CHAOS-MAIL-SERVER-HOSTS) (DEFVAR *MAIL-CHAOS-HOST* NIL) (DEFUN CHAOS-SEND-IT (PLIST INTERVAL TEMPLATE &AUX HOSTS) (FS:FORCE-USER-TO-LOGIN) (SETQ HOSTS *MAIL-CHAOS-HOSTS*) (AND (MEMQ FS:USER-LOGIN-MACHINE HOSTS) (PUSH FS:USER-LOGIN-MACHINE HOSTS)) (AND *MAIL-CHAOS-HOST* (PUSH *MAIL-CHAOS-HOST* HOSTS)) (AND (LOOP WITH RECIPIENTS = (GET-MAIL-RECIPIENTS PLIST) FOR HOST IN HOSTS ALWAYS (CHAOS-SEND-IT-1 HOST RECIPIENTS PLIST INTERVAL TEMPLATE)) (FERROR NIL "Cannot connect to a MAIL server"))) (DEFUN GET-MAIL-RECIPIENTS (PLIST) (LOOP FOR FIELD IN *RECIPIENT-TYPE-HEADERS* NCONC (LOOP FOR RECIPIENT IN (GET PLIST FIELD) COLLECT RECIPIENT))) (DEFUN CHAOS-SEND-IT-1 (HOST RECIPIENTS PLIST INTERVAL TEMPLATE) (WITH-OPEN-STREAM (STREAM (CHAOS:OPEN-STREAM HOST "MAIL" ':ERROR NIL)) (IF (STRINGP STREAM) STREAM ;; Output the recipients (DOLIST (RCPT RECIPIENTS) (SETQ RCPT (STRING-FROM-HEADER RCPT ':HOST)) (FUNCALL STREAM ':STRING-OUT RCPT) (FUNCALL STREAM ':TYO #\CR) (CHECK-CHAOS-MAIL-RESPONSE STREAM RCPT)) (FUNCALL STREAM ':TYO #\CR) ;Mark end of recipients (LET ((*QUOTE-HOSTS-FOR-XMAILR* (MEMQ (FUNCALL HOST ':SYSTEM-TYPE) '(:TOPS-20 :TENEX)))) (OUTPUT-HEADER-AND-MSG STREAM PLIST INTERVAL TEMPLATE)) (CHECK-CHAOS-MAIL-RESPONSE STREAM "the body of the message" T) NIL))) (DEFUN CHECK-CHAOS-MAIL-RESPONSE (STREAM ERRMES &OPTIONAL EOF-P) (FUNCALL STREAM ':FORCE-OUTPUT) (AND EOF-P (FUNCALL STREAM ':EOF)) (LET ((LINE (FUNCALL STREAM ':LINE-IN))) (SELECTQ (AREF LINE 0) (#/+) ;AOK (#/- (BARF "Negative response from host for ~A: ~A" ERRMES LINE)) (#/% (BARF "Temporary error from host for ~A: ~A" ERRMES LINE)) (OTHERWISE (BARF "Unknown response from host for ~A: ~A" ERRMES LINE))))) ;;; This connects separately to each host that is getting mail (DEFUN CHAOS-DIRECT-SEND-IT (PLIST INTERVAL TEMPLATE &AUX RCPTS) (FS:FORCE-USER-TO-LOGIN) (CANONICALIZE-HEADERS PLIST) (LOOP WITH RPLIST = (LOCF RCPTS) AND GATEWAY = (CAR *MAIL-CHAOS-HOSTS*) AND HOST FOR RECIPIENT IN (GET-MAIL-RECIPIENTS PLIST) DO (AND (NOT (AND (SETQ HOST (CAR (LAST (GET (LOCF RECIPIENT) ':HOST)))) (SETQ HOST (SI:PARSE-HOST HOST T)) (FUNCALL HOST ':NETWORK-TYPEP ':CHAOS))) (SETQ HOST GATEWAY)) (PUSH RECIPIENT (GET RPLIST HOST))) (LOOP FOR (HOST RECIPIENTS) ON RCPTS BY 'CDDR WITH ERRMES WHEN (SETQ ERRMES (CHAOS-SEND-IT-1 HOST RECIPIENTS PLIST INTERVAL TEMPLATE)) DO (FERROR NIL "Cannot connect to ~A: ~A" HOST ERRMES))) (DEFINE-ZMAIL-GLOBAL *DEFAULT-SEND-TEMPLATE* '(:DATE :FROM :SENDER :REPLY-TO :SUBJECT :TO :CC :FCC :IN-REPLY-TO :REFERENCES :MESSAGE-ID)) (DEFUN OUTPUT-HEADER-AND-MSG (STREAM PLIST INTERVAL TEMPLATE) (OUTPUT-HEADER STREAM PLIST TEMPLATE) (STREAM-OUT-INTERVAL STREAM INTERVAL)) (DEFUN OUTPUT-HEADER (STREAM PLIST TEMPLATE &OPTIONAL (CANONICALIZE-P T) (CR-AT-END T)) (AND CANONICALIZE-P (CANONICALIZE-HEADERS PLIST)) ;; Output all the headers (LOOP FOR IND IN TEMPLATE WITH HEADER DO (AND (SETQ HEADER (GET PLIST IND)) (PRINT-HEADER STREAM HEADER IND))) ;;Finish up (AND CR-AT-END (FUNCALL STREAM ':TYO #\CR))) (DEFUN CANONICALIZE-HEADERS (PLIST &AUX HOST) (SETQ HOST (NCONS (STRING FS:USER-LOGIN-MACHINE))) (LET ((DATE-PROP ':DATE) (FROM-PROP ':FROM)) (AND (GET PLIST 'REDISTRIBUTED-HEADERS) (SETQ DATE-PROP ':REDISTRIBUTED-DATE FROM-PROP ':REDISTRIBUTED-BY)) (OR (GET PLIST DATE-PROP) (PUTPROP PLIST (TIME:GET-UNIVERSAL-TIME) DATE-PROP)) (LET ((FROM (GET PLIST FROM-PROP))) (COND ((NULL FROM) (PUTPROP PLIST `((:PERSONAL-NAME ,FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST :NAME ,USER-ID :HOST ,HOST)) FROM-PROP)) ((NOT (AND (= (LENGTH FROM) 1) (EQUAL USER-ID (GET (LOCF (CAR FROM)) ':NAME)))) (PUTPROP PLIST `((:NAME ,USER-ID :HOST ,HOST)) ':SENDER))))) ;; Make sure everyone has a host who should (LOOP FOR (IND PROPS) ON (CAR PLIST) BY 'CDDR WHEN (MEMQ IND *ADDRESS-TYPE-HEADERS*) DO (LOOP FOR PROP ON PROPS AS PL = (LOCF (CAR PROP)) UNLESS (GET PL ':HOST) DO (PUTPROP PL HOST ':HOST) (REMPROP PL ':INTERVAL)))) ;This can no longer be used (DEFUN PRINT-HEADER (STREAM HEADER TYPE &AUX NAME) (SETQ NAME (HEADER-TYPE-NAME TYPE)) (COND ((EQ TYPE 'REDISTRIBUTED-HEADERS) (STREAM-OUT-INTERVAL STREAM HEADER)) ((MEMQ TYPE *ADDRESS-TYPE-HEADERS*) (PRINT-ADDRESS-HEADER STREAM HEADER NAME)) ((MEMQ TYPE *DATE-TYPE-HEADERS*) (MULTIPLE-VALUE-BIND (NIL MINUTES HOURS DAY MONTH YEAR DAY-OF-THE-WEEK DAYLIGHT-SAVINGS-P) (TIME:DECODE-UNIVERSAL-TIME HEADER) (FORMAT STREAM "~A: ~A, ~D ~A ~D, ~2,'0D:~2,'0D-~A~%" NAME (TIME:DAY-OF-THE-WEEK-STRING DAY-OF-THE-WEEK) DAY (TIME:MONTH-STRING MONTH) (+ YEAR 1900.) HOURS MINUTES (TIME:TIMEZONE-STRING TIME:*TIMEZONE* DAYLIGHT-SAVINGS-P)))) ((LISTP HEADER) (DO ((STRS HEADER (CDR STRS)) (STR) (LEN (+ (STRING-LENGTH NAME) 2)) (COMMA-P (MEMQ TYPE *SINGLE-LINE-TYPE-HEADERS*)) (REFERENCE-P (MEMQ TYPE *REFERENCE-TYPE-HEADERS*)) (FIRST-P T NIL)) ((NULL STRS)) (SETQ STR (CAR STRS)) (COND (FIRST-P (FUNCALL STREAM ':STRING-OUT NAME) (FUNCALL STREAM ':STRING-OUT ": ")) (T (DOTIMES (I LEN) (FUNCALL STREAM ':TYO #\SP)))) (IF REFERENCE-P (PRINT-REFERENCE STREAM STR) (FUNCALL STREAM ':STRING-OUT STR)) (AND COMMA-P (CDR STRS) (FUNCALL STREAM ':TYO #/,)) (FUNCALL STREAM ':TYO #\CR))) (T (FORMAT STREAM "~A: ~A~%" NAME HEADER)))) (DEFUN HEADER-TYPE-NAME (TYPE) (OR (CAR (RASSQ TYPE *HEADER-NAME-ALIST*)) (STRING TYPE))) (DEFUN PRINT-ADDRESS-HEADER (STREAM LIST NAME &OPTIONAL (MAX-COL 72.) &AUX PADLEN) (SETQ PADLEN (+ (STRING-LENGTH NAME) 2)) ;Account for ": " (FUNCALL STREAM ':STRING-OUT NAME) (FUNCALL STREAM ':STRING-OUT ": ") (DO ((L LIST (CDR L)) (X PADLEN (+ X LEN)) (LEN) (STR) (EOL-P T NIL)) ((NULL L)) (SETQ STR (STRING-FROM-HEADER (CAR L) *SEND-HEADER-FORMAT*) LEN (STRING-LENGTH STR)) (COND ((NOT EOL-P) (FUNCALL STREAM ':TYO #/,) (COND ((OR *QUOTE-HOSTS-FOR-XMAILR* (> (+ X LEN 2) MAX-COL)) (FUNCALL STREAM ':TYO #\CR) (DOTIMES (I PADLEN) (FUNCALL STREAM ':TYO #\SP)) (SETQ X PADLEN EOL-P T))) (COND ((NOT EOL-P) (FUNCALL STREAM ':TYO #\SP) (SETQ X (+ X 2)))))) (FUNCALL STREAM ':STRING-OUT STR)) (FUNCALL STREAM ':TYO #\CR)) (DEFUN PRINT-REFERENCE (STREAM REF &OPTIONAL (VERBOSE-P T) &AUX (PLIST (LOCF REF)) TEM) (IF (SETQ TEM (GET PLIST ':MESSAGE-ID)) (FUNCALL STREAM ':STRING-OUT TEM) (LET* ((DATE (GET PLIST ':DATE)) (FROM (GET PLIST ':FROM))) (COND (FROM (SETQ TEM (OR (STRING-FROM-HEADER FROM (IF VERBOSE-P ':INCLUDE-PERSONAL ':SHORT)) (GET (LOCF FROM) ':PERSONAL-NAME))) (SETQ FROM TEM))) (AND VERBOSE-P (FUNCALL STREAM ':STRING-OUT (IF FROM "The " "Your "))) (FUNCALL STREAM ':STRING-OUT "message") (AND DATE (MULTIPLE-VALUE-BIND (NIL MINUTES HOURS DAY MONTH YEAR NIL DAYLIGHT-SAVINGS-P) (TIME:DECODE-UNIVERSAL-TIME DATE) (FORMAT STREAM " of ~D ~A ~D ~2,'0D:~2,'0D-~A" DAY (TIME:MONTH-STRING MONTH ':SHORT) YEAR HOURS MINUTES (TIME:TIMEZONE-STRING TIME:*TIMEZONE* DAYLIGHT-SAVINGS-P)))) (COND (FROM (FUNCALL STREAM ':STRING-OUT " from ") (FUNCALL STREAM ':STRING-OUT FROM)))))) (DEFUN COM-ZMAIL-LOCAL-MAIL-INTERNAL (&AUX MAIL-FILE END-BP MSG) (SETQ MAIL-FILE (COND (*MSG* (MSG-MAIL-FILE *MSG*)) ((LOOP FOR MF IN *MAIL-FILE-LIST* WHEN (MAIL-FILE-DISK-P MF) RETURN MF)) (T (BARF "There is no disk mail file to put a local message in.")))) (SETQ MSG (MAKE-EMPTY-MSG) END-BP (MSG-END-BP MSG)) (LET* ((HEADERS `(:TO ((:NAME ,USER-ID)))) (PLIST (LOCF HEADERS))) (AND *LOCAL-MAIL-INCLUDE-SUBJECT* (PUTPROP PLIST "" ':SUBJECT)) (FUNCALL (IF (EQ *LOCAL-MAIL-HEADER-FORCE* ':ITS) #'OUTPUT-ITS-HEADER #'OUTPUT-HEADER) (INTERVAL-STREAM-INTO-BP END-BP) PLIST *DEFAULT-SEND-TEMPLATE*)) (FUNCALL MAIL-FILE ':ADD-MSG MSG) (OR (EQ MAIL-FILE *MAIL-FILE*) (FUNCALL *MAIL-FILE* ':ADD-MSG MSG)) (ZMAIL-SELECT-MSG MSG) (FUNCALL *SUMMARY-WINDOW* ':NEED-FULL-REDISPLAY) (LET* ((START-LINE (BP-LINE (MSG-START-BP MSG))) (SUBJ-LINE (AND *LOCAL-MAIL-INCLUDE-SUBJECT* (IF (EQ *LOCAL-MAIL-HEADER-FORCE* ':ITS) START-LINE (DO ((LINE (BP-LINE END-BP) (LINE-PREVIOUS LINE))) ((EQ LINE START-LINE) NIL) (AND (STRING-EQUAL-START LINE "Subject:") (RETURN LINE))))))) (MOVE-BP (POINT) (IF SUBJ-LINE (END-OF-LINE SUBJ-LINE) END-BP))) (MUST-REDISPLAY *WINDOW* DIS-ALL) (COM-EDIT-CURRENT-MSG)) (DEFUN OUTPUT-ITS-HEADER (STREAM PLIST IGNORE &AUX TEM) (CANONICALIZE-HEADERS PLIST) (FUNCALL STREAM ':STRING-OUT (STRING-FROM-HEADER (CAR (GET PLIST ':FROM)) ':SHORT)) (FUNCALL STREAM ':TYO #\SP) (COND ((SETQ TEM (GET PLIST ':SENDER)) (FUNCALL STREAM ':STRING-OUT "(Sent by ") (FUNCALL STREAM ':STRING-OUT (STRING-FROM-HEADER (CAR TEM) ':SHORT)) (FUNCALL STREAM ':STRING-OUT ") "))) (TIME:PRINT-UNIVERSAL-TIME (GET PLIST ':DATE) STREAM) (COND ((SETQ TEM (GET PLIST ':SUBJECT)) (FUNCALL STREAM ':STRING-OUT " Re: ") (FUNCALL STREAM ':STRING-OUT TEM))) (FUNCALL STREAM ':TYO #\CR) (OR (AND (NULL (GET PLIST ':CC)) (NULL (CDR (GET PLIST ':TO)))) ;One or fewer recipients (LOOP FOR (IND . NAME) IN '((:TO . "To") (:CC . "CC")) WITH RECIPIENTS DO (AND (SETQ RECIPIENTS (GET PLIST IND)) (PRINT-ADDRESS-HEADER STREAM RECIPIENTS NAME))))) (DEFUN GET-FCC-PATHNAMES (FCC) (IF (LISTP FCC) (LOOP FOR STR IN FCC NCONC (GET-FCC-PATHNAMES FCC)) (TV:PARSE-PATHNAME-LIST FCC))) (DEFUN CONSTRUCT-FCC-MSG (PLIST INTERVAL &AUX MSG) (SETQ MSG (MAKE-EMPTY-MSG)) (LET ((STREAM (INTERVAL-STREAM-INTO-BP (MSG-END-BP MSG)))) (OUTPUT-HEADER-AND-MSG STREAM PLIST INTERVAL *DEFAULT-SEND-TEMPLATE*) (FUNCALL STREAM ':FRESH-LINE)) MSG)