;;; Lisp Machine mail reader -*- Mode:LISP; Package:ZWEI -*- ;;; Mail file handling, definition are in DEFS ;;; ** (c) Copyright 1981 Massachusetts Institute of Technology ** (TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* MAIL-FILE "Select" SELECT-MAIL-FILE T "Select this mail file.") (DEFUN SELECT-MAIL-FILE (MAIL-FILE &OPTIONAL PRIMARY-TOO (MSG-TOO T)) (COND (MAIL-FILE (COND ((AND *MAIL-FILE* *MSG*) (SETF (MAIL-FILE-SAVED-CURRENT-MSG *MAIL-FILE*) *MSG*) (MSG-POINT-PDL-PUSH *MSG* *MAIL-FILE*))) (OR (TYPEP MAIL-FILE 'NEW-MAIL-FILE) (SETQ *MAIL-FILE-LIST* (CONS MAIL-FILE (DELQ MAIL-FILE *MAIL-FILE-LIST*)))) (SETQ *ZMAIL-FILE-NAME* (MAIL-FILE-NAME MAIL-FILE))) (T (SETQ *ZMAIL-FILE-NAME* "No current mail file"))) (FUNCALL *SUMMARY-WINDOW* ':SET-CURRENT-MAIL-FILE MAIL-FILE) (AND PRIMARY-TOO (SETQ *PRIMARY-MAIL-FILE* MAIL-FILE)) (SETQ *MAIL-FILE* MAIL-FILE) (DOLIST (COM '(COM-ZMAIL-SELECT COM-ZMAIL-SORT COM-ZMAIL-RENAME-MAIL-FILE SET-MSG-SUMMARY-LINE)) (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION COM)) (AND MSG-TOO (ZMAIL-SELECT-MSG *MSG* T NIL))) (DEFUN GET-MAIL-FILE-FROM-NAME (NAME &OPTIONAL CREATE-P) (COND ((DOLIST (MAIL-FILE *MAIL-FILE-LIST*) (AND (STRING-EQUAL NAME (MAIL-FILE-NAME MAIL-FILE)) (RETURN MAIL-FILE)))) (CREATE-P (MAKE-NEW-MAIL-FILE (FS:MERGE-PATHNAME-DEFAULTS NAME *ZMAIL-PATHNAME-DEFAULTS*))))) (DEFUN GET-MAIL-FILE-FROM-PATHNAME (PATHNAME &OPTIONAL CREATE-P) (SETQ PATHNAME (FS:MERGE-PATHNAME-DEFAULTS PATHNAME *ZMAIL-PATHNAME-DEFAULTS*)) (COND ((DOLIST (MAIL-FILE *MAIL-FILE-LIST*) (AND (MAIL-FILE-DISK-P MAIL-FILE) (EQ PATHNAME (DISK-MAIL-FILE-PATHNAME MAIL-FILE)) (RETURN MAIL-FILE)))) (CREATE-P (MAKE-NEW-MAIL-FILE PATHNAME)))) (DEFUN MSG-IN-MAIL-FILE-P (MSG MAIL-FILE &AUX ARRAY) (SETQ ARRAY (MAIL-FILE-ARRAY MAIL-FILE)) (DO ((I 0 (1+ I)) (NMSGS (ARRAY-ACTIVE-LENGTH ARRAY))) (( I NMSGS)) (AND (EQ MSG (AREF ARRAY I)) (RETURN I)))) (DEFUN LOCATE-MSG-IN-MAIL-FILE (MSG MAIL-FILE &AUX HINT) (COND ((AND (SETQ HINT (MSG-DISPLAYED-INDEX MSG)) (< HINT (MAIL-FILE-NMSGS MAIL-FILE)) (EQ MSG (AREF (MAIL-FILE-ARRAY MAIL-FILE) HINT))) HINT) ((MSG-IN-MAIL-FILE-P MSG MAIL-FILE)) (T (FERROR NIL "Cannot find ~S in ~S" MSG MAIL-FILE)))) (DEFUN MAKE-EMPTY-MSG (&AUX REAL-INTERVAL INTERVAL START-BP END-BP MSG) (SETQ REAL-INTERVAL (CREATE-INTERVAL) START-BP (COPY-BP (INTERVAL-FIRST-BP REAL-INTERVAL) ':NORMAL) END-BP (COPY-BP (INTERVAL-LAST-BP REAL-INTERVAL) ':MOVES) INTERVAL (CREATE-INTERVAL START-BP END-BP) MSG (MAKE-MSG TICK (TICK) REAL-INTERVAL REAL-INTERVAL INTERVAL INTERVAL)) (SETF (LINE-NODE (BP-LINE END-BP)) INTERVAL) (SETF (NODE-SUPERIOR INTERVAL) REAL-INTERVAL) (SETF (NODE-INFERIORS REAL-INTERVAL) (LIST INTERVAL)) MSG) (DEFVAR *PROPERTIES-NOT-COPIED* '(DELETED FILED)) (DEFUN COPY-MSG (MSG &AUX NMSG) (SETQ NMSG (MAKE-EMPTY-MSG)) (SETF (MSG-STATUS NMSG) (SOME-PLIST-NOT (CAR (ASSURE-MSG-PARSED MSG)) *PROPERTIES-NOT-COPIED*)) (SETF (MSG-PARSED-P NMSG) T) (LET* ((OLD-LINE (MSG-SUMMARY-LINE MSG)) (NEW-LINE (MAKE-SUMMARY-LINE MAKE-ARRAY (:LENGTH (ARRAY-ACTIVE-LENGTH OLD-LINE))))) (SETF (MSG-SUMMARY-LINE NMSG) NEW-LINE) (COPY-ARRAY-CONTENTS-AND-LEADER OLD-LINE NEW-LINE)) (INSERT-INTERVAL (MSG-END-BP NMSG) (MSG-INTERVAL MSG)) NMSG) (DEFVAR *MAIL-FILE-OPTION-ALIST* NIL) (DEFMACRO DEFINE-SETTABLE-MAIL-FILE-OPTION (OPTION DEFAULT &OPTIONAL TYPE NAME &REST ARGS) `(TV:DEFINE-USER-OPTION-1 ',OPTION '*MAIL-FILE-OPTION-ALIST* ,DEFAULT ',(OR TYPE ':SEXP) ',(OR NAME (MAKE-COMMAND-NAME OPTION)) . ,ARGS)) (DEFMACRO DEFINE-NOT-SETTABLE-MAIL-FILE-OPTION (OPTION) `(DEFINE-NOT-SETTABLE-MAIL-FILE-OPTION-1 ',OPTION)) (DEFUN DEFINE-NOT-SETTABLE-MAIL-FILE-OPTION-1 (OPTION) (OR (ASSQ OPTION *MAIL-FILE-OPTION-ALIST*) (PUSH (NCONS OPTION) *MAIL-FILE-OPTION-ALIST*))) (DEFINE-SETTABLE-MAIL-FILE-OPTION :APPEND NIL :BOOLEAN "Append messages moved into file") (DEFUN CHOOSE-MAIL-FILE-OPTIONS (MAIL-FILE &AUX OLD-FLAVOR OLD-APPEND-P PATHNAME FLAVOR APPEND-P OPTIONS PLIST OLD-SUMMARY-FORMAT WANT-TO-REVERSE) (SETQ OLD-FLAVOR (TYPEP MAIL-FILE) PATHNAME (DISK-MAIL-FILE-PATHNAME MAIL-FILE) OPTIONS (MAIL-FILE-OPTIONS MAIL-FILE) PLIST (LOCF OPTIONS) OLD-APPEND-P (GET PLIST ':APPEND) OLD-SUMMARY-FORMAT (GET PLIST ':SUMMARY-TEMPLATE)) (*CATCH 'ZWEI-COMMAND-LOOP ;In case aborted (MULTIPLE-VALUE (FLAVOR OPTIONS) (CHOOSE-MAIL-FILE-OPTIONS-1 PATHNAME OLD-FLAVOR OPTIONS)) (SETQ APPEND-P (GET PLIST ':APPEND)) (AND (NEQ APPEND-P OLD-APPEND-P) (> (MAIL-FILE-NMSGS MAIL-FILE) 1) (TYPEOUT-BEEP-YES-OR-NO-P "Reverse the messages already in ~A? " PATHNAME) (SETQ WANT-TO-REVERSE T)) (COND ((NEQ FLAVOR OLD-FLAVOR) (REMPROP PLIST ':APPEND) (LET ((NEW-MAIL-FILE (MAKE-MAIL-FILE FLAVOR ':PATHNAME PATHNAME ':ID T ':OPTIONS OPTIONS ':APPEND-P APPEND-P))) ;; ADD-MAIL-FILE adds messages in forward order, so that if the file is ;; prepended, they would be reversed accidentally. Similary, if now in append ;; mode, must reverse first to get old prepend mode messages right. (AND (EQ WANT-TO-REVERSE APPEND-P) (REVERSE-MAIL-FILE MAIL-FILE)) (FUNCALL NEW-MAIL-FILE ':ADD-MAIL-FILE MAIL-FILE) (LET ((OLD-SELECTED-P (EQ MAIL-FILE *MAIL-FILE*)) (OLD-PRIMARY-P (EQ MAIL-FILE *PRIMARY-MAIL-FILE*))) (KILL-MAIL-FILE MAIL-FILE) (AND OLD-SELECTED-P (SELECT-MAIL-FILE NEW-MAIL-FILE OLD-PRIMARY-P))))) (T (AND WANT-TO-REVERSE (REVERSE-MAIL-FILE MAIL-FILE)) (FUNCALL MAIL-FILE ':SET-OPTIONS OPTIONS)))) (OR (EQ OLD-SUMMARY-FORMAT (GET PLIST ':SUMMARY-TEMPLATE)) (CHANGE-MAIL-FILE-MSGS-SUMMARY-LINES MAIL-FILE)) (AND (EQ MAIL-FILE *MAIL-FILE*) (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'COM-ZMAIL-SORT))) (DEFUN CHOOSE-MAIL-FILE-OPTIONS-1 (PATHNAME FLAVOR OPTIONS &OPTIONAL (NEAR-MODE '(:MOUSE)) &AUX VARS VALS) (DECLARE (RETURN-LIST FLAVOR OPTIONS) (SPECIAL *POSSIBLE-FLAVORS*)) (SETQ VARS (NCONS 'FLAVOR) VALS (NCONS FLAVOR)) (LOOP FOR POSS IN *MAIL-FILE-OPTION-ALIST* AS VAR = (CAR POSS) AS TEM = (NCONS VAR) WITH PLIST = (LOCF OPTIONS) DO (SETQ VARS (NCONC VARS TEM)) (SETQ VALS (NCONC VALS (NCONS (IF (SETQ TEM (GETL PLIST TEM)) (CADR TEM) (GET VAR 'TV:DEFAULT-VALUE)))))) (LET ((*POSSIBLE-FLAVORS* (LOOP FOR FLAVOR IN (FUNCALL PATHNAME ':POSSIBLE-MAIL-FILE-FLAVORS) COLLECT (RASSQ FLAVOR *MAIL-FILE-FLAVOR-ALIST*) INTO FOO FINALLY (RETURN (NCONC FOO (NCONS (RASSQ 'TEXT-MAIL-FILE *MAIL-FILE-FLAVOR-ALIST*))))))) (PROGV VARS VALS (TV:CHOOSE-VARIABLE-VALUES (COMPUTE-MAIL-FILE-CHOICES FLAVOR) ':LABEL (FORMAT NIL "Options for ~A:" PATHNAME) ':NEAR-MODE NEAR-MODE ':MARGIN-CHOICES '("Do It" ("Abort" (ABORT-CURRENT-COMMAND))) ':FUNCTION 'CHOOSE-MAIL-FILE-OPTIONS-FUNCTION) (SETQ FLAVOR (SYMEVAL 'FLAVOR)) (SETQ OPTIONS (LOOP FOR VAR IN (FUNCALL (SI:GET-FLAVOR-HANDLER-FOR FLAVOR ':POSSIBLE-OPTIONS) ':POSSIBLE-OPTIONS) NCONC `(,VAR ,(SYMEVAL VAR)))))) (VALUES FLAVOR OPTIONS)) (DEFUN CHOOSE-MAIL-FILE-OPTIONS-FUNCTION (WINDOW VARIABLE OLDVAL NEWVAL) OLDVAL (COND ((EQ VARIABLE 'FLAVOR) (TV:WITH-SHEET-DEEXPOSED (WINDOW) (FUNCALL WINDOW ':SETUP (COMPUTE-MAIL-FILE-CHOICES NEWVAL) (FUNCALL WINDOW ':LABEL) (FUNCALL WINDOW ':FUNCTION) (SYMEVAL-IN-INSTANCE WINDOW 'TV:MARGIN-CHOICES))) T))) (DEFUN COMPUTE-MAIL-FILE-CHOICES (FLAVOR) (DECLARE (SPECIAL *POSSIBLE-FLAVORS*)) `((FLAVOR "Format" :ASSOC ,*POSSIBLE-FLAVORS*) . ,(MAPCAR #'(LAMBDA (X) (ASSQ X *MAIL-FILE-OPTION-ALIST*)) (FUNCALL (SI:GET-FLAVOR-HANDLER-FOR FLAVOR ':SETTABLE-OPTIONS) ':SETTABLE-OPTIONS)))) ;;; Mail file actors (DEFMETHOD (MAIL-FILE :PRINT-SELF) (STREAM &REST IGNORE) (SI:PRINTING-RANDOM-OBJECT (SELF STREAM) (PRINC (TYPEP SELF) STREAM) (FUNCALL STREAM ':TYO #\SP) (PRIN1 NAME STREAM))) (DEFUN MAKE-MAIL-FILE (TYPE &REST OPTIONS) (LEXPR-FUNCALL #'MAKE-INSTANCE TYPE OPTIONS)) (DEFMETHOD (MAIL-FILE :INIT) (PLIST) (SETQ ARRAY (MAKE-ARRAY 100 ':LEADER-LIST '(0))) (AND (GET PLIST ':APPEND-P) (PUTPROP (LOCF OPTIONS) T ':APPEND))) (DEFMETHOD (MAIL-FILE :KILL) () (SETQ *MAIL-FILE-LIST* (DELQ SELF *MAIL-FILE-LIST*)) (MSG-POINT-PDL-PURGE NIL SELF) (AND (EQ SELF *PRIMARY-MAIL-FILE*) (SETQ *PRIMARY-MAIL-FILE* NIL)) (AND (EQ SELF *MAIL-FILE*) (SELECT-MAIL-FILE (CAR *MAIL-FILE-LIST*)))) (DEFMETHOD (MAIL-FILE :ADD-MSG) (MSG &OPTIONAL AT-INDEX &AUX LEN) (SETQ LEN (ARRAY-ACTIVE-LENGTH ARRAY)) (COND ((NOT (DOTIMES (I LEN) ;If not already in file (AND (EQ MSG (AREF ARRAY I)) (RETURN T)))) (OR AT-INDEX (SETQ AT-INDEX (LET (PREDICATE APPEND-P) (LET ((PLIST (LOCF OPTIONS))) (SETQ PREDICATE (GET PLIST ':SORT) APPEND-P (GET PLIST ':APPEND))) (IF (NULL PREDICATE) (IF APPEND-P LEN 0) (LOOP FOR I FROM 0 TO LEN WHEN (OR (= I LEN) (EQ APPEND-P (FUNCALL PREDICATE MSG (AREF ARRAY I)))) DO (RETURN I)))))) (AND (< (ARRAY-LENGTH ARRAY) (1+ LEN)) (ADJUST-ARRAY-SIZE ARRAY (// (* LEN 5) 4))) (SETF (ARRAY-LEADER ARRAY 0) (1+ LEN)) (SETQ MSG (FUNCALL-SELF ':ADD-MSG-TEXT MSG AT-INDEX)) (DO ((I LEN (1- I)) (J (1- LEN) (1- J))) ((< J AT-INDEX)) (ASET (AREF ARRAY J) ARRAY I)) (ASET MSG ARRAY AT-INDEX)))) (DEFMETHOD (MAIL-FILE :ADD-MAIL-FILE) (MAIL-FILE &AUX NARRAY NLENGTH PREDICATE APPEND-P) (SETQ NARRAY (MAIL-FILE-ARRAY MAIL-FILE) NLENGTH (ARRAY-ACTIVE-LENGTH NARRAY)) (LET ((PLIST (LOCF OPTIONS))) (SETQ PREDICATE (GET PLIST ':SORT) APPEND-P (GET PLIST ':APPEND))) (AND (> NLENGTH 1) (OR PREDICATE (NULL APPEND-P)) (LET ((NNARRAY (MAKE-ARRAY NLENGTH))) (COPY-ARRAY-CONTENTS NARRAY NNARRAY) (IF (NULL PREDICATE) (ARRAY-NREVERSE NNARRAY) (FUNCALL (IF APPEND-P #'STABLE-SORT #'REVERSE-STABLE-SORT) NNARRAY PREDICATE)) (SETQ NARRAY NNARRAY))) ;; Now merge (LOOP FOR OLD-IDX FROM 0 WITH LENGTH = (ARRAY-ACTIVE-LENGTH ARRAY) AND NEW-IDX = 0 AS NMSG = (AREF NARRAY NEW-IDX) WHEN (OR ( OLD-IDX LENGTH) (EQ APPEND-P (AND PREDICATE (FUNCALL PREDICATE NMSG (AREF ARRAY OLD-IDX))))) DO (FUNCALL-SELF ':ADD-MSG NMSG OLD-IDX) (INCF NEW-IDX) (INCF LENGTH) UNTIL ( NEW-IDX NLENGTH))) (DEFMETHOD (MAIL-FILE :ADD-MSG-TEXT) (MSG AT-INDEX) AT-INDEX ;Not used MSG) (DEFMETHOD (MAIL-FILE :READ-NEXT-MSG) (&OPTIONAL IGNORE) NIL) (DEFMETHOD (MAIL-FILE :UPDATE-MSG-OPTIONS-IN-FILE-IF-NECESSARY) (MSG) MSG) (DEFMETHOD (MAIL-FILE :FULL-NAME) () (FUNCALL-SELF ':NAME)) ;;; Temporary mail files (DEFFLAVOR TEMP-MAIL-FILE (FULL-NAME) (MAIL-FILE) (:SETTABLE-INSTANCE-VARIABLES FULL-NAME)) (DEFRESOURCE TEMP-MAIL-FILE () :INITIAL-COPIES 0 :CONSTRUCTOR MAKE-TEMP-MAIL-FILE :CHECKER TEMP-MAIL-FILE-AVAILABLE-P) (DEFUN TEMP-MAIL-FILE-AVAILABLE-P (IGNORE MAIL-FILE IGNORE) (NOT (MEMQ MAIL-FILE *MAIL-FILE-LIST*))) (DEFUN MAKE-TEMP-MAIL-FILE (IGNORE) (MAKE-MAIL-FILE 'TEMP-MAIL-FILE ':APPEND-P T)) (DEFUN MAKE-NEW-TEMP-MAIL-FILE (NAME &OPTIONAL (FULL-NAME NAME) &AUX MAIL-FILE) (SETQ MAIL-FILE (ALLOCATE-RESOURCE 'TEMP-MAIL-FILE)) (SETF (MAIL-FILE-NAME MAIL-FILE) NAME) (FUNCALL MAIL-FILE ':SET-FULL-NAME FULL-NAME) (SETF (MAIL-FILE-SAVED-CURRENT-MSG MAIL-FILE) NIL) (NEW-MAIL-FILE MAIL-FILE) MAIL-FILE) ;;; Disk mail files (DEFMETHOD (DISK-MAIL-FILE :AFTER :INIT) (IGNORE) (SETQ INTERVAL (CREATE-INTERVAL))) (DEFMETHOD (DISK-MAIL-FILE :BEFORE :KILL) () (DOMSGS (MSG SELF) (SETF (MSG-PARSED-P MSG) ':KILLED)) ;; Get rid of any messages we killed this way (LOOP FOR MAIL-FILE IN *MAIL-FILE-LIST* WHEN (NOT (MAIL-FILE-DISK-P MAIL-FILE)) DO (EXPUNGE-MAIL-FILE MAIL-FILE NIL))) (DEFMETHOD (DISK-MAIL-FILE :PARSE-MSG) (MSG STATUS) (SET-PARSED-MSG-HEADERS MSG STATUS)) (DEFMETHOD (DISK-MAIL-FILE :UPDATE-MSG-END) (MSG &OPTIONAL IGNORE) MSG) ;;; Old mail (DEFFLAVOR OLD-MAIL-FILE () (DISK-MAIL-FILE MAIL-FILE) (:INIT-KEYWORDS :NEW-PRIMARY-P)) ;;; ALWAYS-NEW means do not read in any old file. FLAVOR overrides any default (DEFUN MAKE-NEW-MAIL-FILE (PATHNAME &OPTIONAL (NEAR-MODE '(:MOUSE)) FLAVOR ALWAYS-NEW &AUX STREAM MSG) (DECLARE (RETURN-LIST MAIL-FILE NEW-P)) (SETQ PATHNAME (FS:MERGE-PATHNAME-DEFAULTS PATHNAME *ZMAIL-PATHNAME-DEFAULTS*)) (COND ((NOT (OR ALWAYS-NEW (STRINGP (SETQ STREAM (OPEN PATHNAME '(:IN :NOERROR)))))) (GET-ZMAIL-FILE STREAM PATHNAME NIL FLAVOR)) ((AND STREAM (LET (ERR) (MULTIPLE-VALUE (ERR NIL MSG) (FS:FILE-PROCESS-ERROR STREAM PATHNAME NIL T)) (NOT (STRING-EQUAL ERR "FNF")))) (BARF MSG)) (T (TYPEIN-LINE "New file: ~A" PATHNAME) (VALUES (MAKE-NEW-MAIL-FILE-1 PATHNAME (COND ((OR ALWAYS-NEW (NULL *MAIL-FILE*)) NIL) ((AND *DEFAULT-MOVE-MAIL-FILE* (MAIL-FILE-DISK-P *DEFAULT-MOVE-MAIL-FILE*)) *DEFAULT-MOVE-MAIL-FILE*) ((MAIL-FILE-DISK-P *MAIL-FILE*) *MAIL-FILE*) (*PRIMARY-MAIL-FILE*)) NEAR-MODE FLAVOR) T)))) (DEFUN MAKE-NEW-MAIL-FILE-1 (PATHNAME &OPTIONAL MAIL-FILE NEAR-MODE FLAVOR PRIMARY-P &AUX OPTIONS PLIST APPEND-P) (SETQ PLIST (LOCF OPTIONS)) (COND (MAIL-FILE (SETQ FLAVOR (TYPEP MAIL-FILE) OPTIONS (FUNCALL MAIL-FILE ':STICKY-OPTIONS) APPEND-P (GET PLIST ':APPEND))) ((NULL FLAVOR) (MULTIPLE-VALUE (FLAVOR APPEND-P) (FUNCALL PATHNAME ':MAIL-FILE-FORMAT-COMPUTER NIL)))) (SETQ APPEND-P (SELECTQ *NEW-MAIL-FILE-APPEND-P* (:APPEND T) (:PREPEND NIL) (:STICKY APPEND-P) (:ASK (IF (EQ *ZMAIL-COMMAND-BUTTON* ':RIGHT) APPEND-P (LET ((CHOICE (TV:MENU-CHOOSE '(("Append" . :APPEND) ("Prepend" . :PREPEND))))) (OR CHOICE (ABORT-CURRENT-COMMAND)) (EQ CHOICE ':APPEND)))))) (COND ((EQ *ZMAIL-COMMAND-BUTTON* ':RIGHT) (PUTPROP PLIST APPEND-P ':APPEND) (OR NEAR-MODE (SETQ NEAR-MODE '(:MOUSE))) (MULTIPLE-VALUE (FLAVOR OPTIONS) (CHOOSE-MAIL-FILE-OPTIONS-1 PATHNAME FLAVOR OPTIONS NEAR-MODE)) (SETQ APPEND-P (CAR (REMPROP PLIST ':APPEND)))) (T (REMPROP PLIST ':APPEND))) ;Do not get confused in :INIT method (MAKE-MAIL-FILE FLAVOR ':PATHNAME PATHNAME ':ID T ':OPTIONS OPTIONS ':APPEND-P APPEND-P ':NEW-PRIMARY-P PRIMARY-P)) (DEFVAR *MAIL-FILE-FLAVOR-ALIST* NIL) (DEFUN ADD-MAIL-FILE-FLAVOR (FLAVOR NAME &AUX ELEM) (IF (SETQ ELEM (ASSOC NAME *MAIL-FILE-FLAVOR-ALIST*)) (SETF (CDR ELEM) FLAVOR) (PUSH (CONS NAME FLAVOR) *MAIL-FILE-FLAVOR-ALIST*))) (DEFMETHOD (OLD-MAIL-FILE :SETTABLE-OPTIONS) () NIL) (DEFMETHOD (OLD-MAIL-FILE :POSSIBLE-OPTIONS) () '(:APPEND)) (DEFMETHOD (OLD-MAIL-FILE :STICKY-OPTIONS) () (SOME-PLIST OPTIONS '(:APPEND))) (DEFMETHOD (OLD-MAIL-FILE :AFTER :INIT) (IGNORE) (SETQ NAME (FUNCALL PATHNAME ':STRING-FOR-PRINTING)) (SETQ TICK (TICK) MSG-UPDATE-TICK TICK) (AND STREAM (SETQ STATUS ':LOADING)) (NEW-MAIL-FILE SELF)) (DEFUN NEW-MAIL-FILE (MAIL-FILE) (SETQ *MAIL-FILE-LIST* (NCONC *MAIL-FILE-LIST* (NCONS MAIL-FILE))) ;; We may make another mail file available for left on Select. (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'COM-ZMAIL-SELECT)) ;;; Update the buffer version of a message's status (DEFMETHOD (OLD-MAIL-FILE :UPDATE-MSG-OPTIONS-IN-FILE-IF-NECESSARY) (MSG) (AND (> (MSG-TICK MSG) MSG-UPDATE-TICK) (FUNCALL-SELF ':UPDATE-MSG-OPTIONS-IN-FILE MSG))) (DEFMETHOD (OLD-MAIL-FILE :UPDATE-MSG-OPTIONS-IN-FILE) (MSG) MSG) (DEFMETHOD (OLD-MAIL-FILE :NEW-MSG) (MSG) (SETF (MSG-MAIL-FILE MSG) SELF) (MULTIPLE-VALUE-BIND (BEFORE AFTER) (FUNCALL-SELF ':NEW-HEADER-AND-TRAILER) (REPLACE-REAL-HEADER-AREA MSG BEFORE) (REPLACE-REAL-TRAILER-AREA MSG AFTER)) (FUNCALL-SELF ':UPDATE-MSG-END MSG) MSG) (DEFMETHOD (OLD-MAIL-FILE :NEW-HEADER-AND-TRAILER) () (VALUES "" "")) (DEFUN REPLACE-REAL-HEADER-AREA (MSG STRING &AUX START-BP MSG-REAL-INTERVAL PREV-END-BP PREV-END-BP-1 MOVE-BP-P MOVE-BP-1-P NEW-BP) (SETQ START-BP (MSG-START-BP MSG) MSG-REAL-INTERVAL (MSG-REAL-INTERVAL MSG)) (DELETE-INTERVAL (INTERVAL-FIRST-BP MSG-REAL-INTERVAL) START-BP T) (AND (SETQ MOVE-BP-P (NODE-PREVIOUS MSG-REAL-INTERVAL)) (SETQ PREV-END-BP (INTERVAL-LAST-BP MOVE-BP-P) PREV-END-BP-1 (INTERVAL-LAST-BP (CAR (NODE-INFERIORS MOVE-BP-P))) MOVE-BP-P (BP-= PREV-END-BP START-BP) MOVE-BP-1-P (BP-= PREV-END-BP-1 START-BP))) (SETQ NEW-BP (INSERT START-BP STRING)) ;; If we inserted text that made the end of the previous message move accidentally, ;; put it back where it was. (AND MOVE-BP-P (MOVE-BP PREV-END-BP START-BP)) (AND MOVE-BP-1-P (MOVE-BP PREV-END-BP-1 START-BP)) (MOVE-BP START-BP NEW-BP) (FUNCALL-SELF ':UPDATE-MSG-OPTIONS-IN-FILE MSG)) (DEFUN REPLACE-REAL-TRAILER-AREA (MSG STRING &AUX END-BP REAL-INTERVAL NEXT-START-BP NEXT-START-BP-1 MOVE-BP-P MOVE-BP-1-P) (SETQ END-BP (MSG-END-BP MSG) REAL-INTERVAL (MSG-REAL-INTERVAL MSG)) (DELETE-INTERVAL END-BP (INTERVAL-LAST-BP REAL-INTERVAL) T) (AND (SETQ MOVE-BP-P (NODE-NEXT REAL-INTERVAL)) (SETQ NEXT-START-BP (INTERVAL-FIRST-BP MOVE-BP-P) NEXT-START-BP-1 (INTERVAL-FIRST-BP (CAR (NODE-INFERIORS MOVE-BP-P))) MOVE-BP-P (BP-= NEXT-START-BP END-BP) MOVE-BP-1-P (BP-= NEXT-START-BP-1 END-BP))) (WITH-BP (OLD-END-BP END-BP ':NORMAL) (INSERT-MOVING END-BP STRING) (AND MOVE-BP-P (MOVE-BP NEXT-START-BP END-BP)) (AND MOVE-BP-1-P (MOVE-BP NEXT-START-BP-1 END-BP)) (MOVE-BP END-BP OLD-END-BP))) (DEFMETHOD (DISK-MAIL-FILE :FIRST-MSG-BP) () (INTERVAL-FIRST-BP INTERVAL)) ;;; The count of messages can be inconsistent while the text is being added, prevent lossage ;;; with background parsing (DEFWRAPPER (DISK-MAIL-FILE :ADD-MSG) (IGNORE . BODY) `(LOCK-MAIL-FILE (SELF) . ,BODY)) (DEFWRAPPER (DISK-MAIL-FILE :ADD-MAIL-FILE) (IGNORE . BODY) `(LOCK-MAIL-FILE (SELF) . ,BODY)) ;;; This actually links in the lines of a message (DEFMETHOD (OLD-MAIL-FILE :ADD-MSG-TEXT) (MSG AT-INDEX) (COND ((MSG-MAIL-FILE MSG) ;; This MSG-PUT and the COPY-MSG below insure that the message has been parsed ;; if its text is going to be copied. This is necessary so that the *** EOOH *** ;; line isn't copied as well. (MSG-PUT MSG T 'FILED) (AND *DELETE-AFTER-MOVE-TO-FILE* (ZMAIL-DELETE-MSG MSG)) (SETQ MSG (COPY-MSG MSG)))) (FUNCALL-SELF ':NEW-MSG MSG) (LET* ((MSG-INT (MSG-REAL-INTERVAL MSG)) (MSG-REAL-START-BP (INTERVAL-FIRST-BP MSG-INT)) (MSG-REAL-END-BP (INTERVAL-LAST-BP MSG-INT)) (NMSGS (ARRAY-ACTIVE-LENGTH ARRAY)) (INFS (NODE-INFERIORS INTERVAL)) (LINE2 (BP-LINE MSG-REAL-START-BP)) (LINE3 (BP-LINE MSG-REAL-END-BP)) PREV-MSG-END-BP LINE1 LINE4) (SETF (NODE-SUPERIOR MSG-INT) INTERVAL) (COND ((= AT-INDEX (1- NMSGS)) ;Putting in at the end (MULTIPLE-VALUE (LINE1 PREV-MSG-END-BP) (FUNCALL-SELF ':LAST-LINE-FOR-APPEND (1- NMSGS)))) (T (LET ((NEXT-MSG (AREF ARRAY AT-INDEX))) (LET ((NEXT-NODE (MSG-REAL-INTERVAL NEXT-MSG))) (SETF (NODE-NEXT MSG-INT) NEXT-NODE) (SETF (NODE-PREVIOUS NEXT-NODE) MSG-INT)) (SETQ LINE4 (BP-LINE (MSG-REAL-START-BP NEXT-MSG)) LINE1 (LINE-PREVIOUS LINE4))))) (COND (LINE1 (SETF (LINE-PREVIOUS LINE2) LINE1) (SETF (LINE-NEXT LINE1) LINE2) (AND PREV-MSG-END-BP (MOVE-BP PREV-MSG-END-BP LINE2 0))) (T (MOVE-BP (INTERVAL-FIRST-BP INTERVAL) MSG-REAL-START-BP))) (COND (LINE4 (AND (ZEROP (BP-INDEX MSG-REAL-END-BP)) (SETQ LINE3 (LINE-PREVIOUS LINE3))) (SETF (LINE-NEXT LINE3) LINE4) (SETF (LINE-PREVIOUS LINE4) LINE3) (LET ((MSG-END-BP (MSG-END-BP MSG))) (AND (BP-= MSG-END-BP MSG-REAL-END-BP) (MOVE-BP MSG-END-BP LINE4 0))) (MOVE-BP MSG-REAL-END-BP LINE4 0)) (T (MOVE-BP (INTERVAL-LAST-BP INTERVAL) LINE3 (LINE-LENGTH LINE3)))) (IF (ZEROP AT-INDEX) (SETF (NODE-INFERIORS INTERVAL) (CONS MSG-INT INFS)) (LET ((PREV-NODE (MSG-REAL-INTERVAL (AREF ARRAY (1- AT-INDEX))))) (SETF (NODE-NEXT PREV-NODE) MSG-INT) (SETF (NODE-PREVIOUS MSG-INT) PREV-NODE) (AND (SETQ INFS (MEMQ PREV-NODE INFS)) (PUSH MSG-INT (CDR INFS)))))) (MUNG-NODE INTERVAL) MSG) ;; If there was a message in here before, it may not have had a  or whatever at ;; the end of it. Also there may be extraneous newlines at the end of the file. (DEFMETHOD (OLD-MAIL-FILE :LAST-LINE-FOR-APPEND) (&OPTIONAL NMSGS &AUX BP LINE PREV-END-BP) (OR NMSGS (SETQ NMSGS (ARRAY-ACTIVE-LENGTH ARRAY))) (IF (PLUSP NMSGS) (LET ((MSG (AREF ARRAY (1- NMSGS)))) (FUNCALL-SELF ':UPDATE-MSG-END MSG T) (SETQ BP (MSG-REAL-END-BP MSG))) (SETQ BP (FUNCALL-SELF ':FIRST-MSG-BP))) (SETQ LINE (BP-LINE BP)) (AND (ZEROP (BP-INDEX BP)) (SETQ LINE (LINE-PREVIOUS LINE) PREV-END-BP BP)) (VALUES LINE PREV-END-BP)) ;;; This makes sure that a mail file that corresponds to an actual file has ;;; its messages in the right order. (DEFUN RESPLICE-MAIL-FILE (MAIL-FILE &AUX START-LINE START-BP ARRAY) (OR (SETQ START-LINE (LINE-PREVIOUS (BP-LINE (FUNCALL MAIL-FILE ':FIRST-MSG-BP)))) (SETQ START-BP (MAIL-FILE-START-BP MAIL-FILE))) (SETQ ARRAY (MAIL-FILE-ARRAY MAIL-FILE)) (DO ((I 0 (1+ I)) (NMSGS (ARRAY-ACTIVE-LENGTH ARRAY)) (LINE1 START-LINE (BP-LINE (MSG-END-BP MSG))) (MSG-END-BP NIL (MSG-END-BP MSG)) (REAL-END-BP START-BP (MSG-REAL-END-BP MSG)) (REAL-INT) (PREV-REAL-INT NIL REAL-INT) (LINE2) (MSG) (REAL-START-BP) (FLAG) (INFERIORS NIL (CONS REAL-INT INFERIORS))) (NIL) (AND (SETQ FLAG (AND MSG-END-BP REAL-END-BP (BP-= MSG-END-BP REAL-END-BP))) (DO ((L (BP-LINE (MSG-START-BP MSG)) (LINE-NEXT L)) (PL LINE1 L)) ((EQ L LINE1) (SETQ LINE1 PL)))) (COND (( I NMSGS) (LET ((MAIL-FILE-END-BP (MAIL-FILE-END-BP MAIL-FILE)) (BP (END-OF-LINE LINE1))) (SETF (LINE-NEXT LINE1) NIL) (MOVE-BP MAIL-FILE-END-BP BP) (MOVE-BP REAL-END-BP MAIL-FILE-END-BP) (AND FLAG (MOVE-BP MSG-END-BP MAIL-FILE-END-BP))) (AND MSG (FUNCALL MAIL-FILE ':UPDATE-MSG-END MSG)) (AND REAL-INT (SETF (NODE-NEXT REAL-INT) NIL)) (SETF (NODE-INFERIORS (DISK-MAIL-FILE-INTERVAL MAIL-FILE)) (NREVERSE INFERIORS)) (RETURN NIL))) (SETQ MSG (AREF ARRAY I) REAL-INT (MSG-REAL-INTERVAL MSG) REAL-START-BP (INTERVAL-FIRST-BP REAL-INT)) (SETF (NODE-PREVIOUS REAL-INT) PREV-REAL-INT) (AND PREV-REAL-INT (SETF (NODE-NEXT PREV-REAL-INT) REAL-INT)) (FUNCALL MAIL-FILE ':UPDATE-MSG-END MSG) (AND REAL-END-BP (MOVE-BP REAL-END-BP REAL-START-BP)) (AND FLAG (MOVE-BP MSG-END-BP REAL-START-BP)) (SETQ LINE2 (BP-LINE REAL-START-BP)) (AND LINE1 (SETF (LINE-NEXT LINE1) LINE2)) (SETF (LINE-PREVIOUS LINE2) LINE1)) (MUNG-NODE (DISK-MAIL-FILE-INTERVAL MAIL-FILE))) ;;; Reverse the order of messages in a mail file (DEFUN REVERSE-MAIL-FILE (MAIL-FILE) (ARRAY-NREVERSE (MAIL-FILE-ARRAY MAIL-FILE)) (AND (MAIL-FILE-DISK-P MAIL-FILE) (RESPLICE-MAIL-FILE MAIL-FILE))) ;;; This ought to be someplace else, maybe it is even (DEFUN ARRAY-NREVERSE (ARRAY) (DO ((I 0 (1+ I)) (J (1- (ARRAY-ACTIVE-LENGTH ARRAY)) (1- J))) ((< J I)) (ASET (PROG1 (AREF ARRAY I) (ASET (AREF ARRAY J) ARRAY I)) ARRAY J)) ARRAY) ;;; Update the list of options at the start of the file (DEFMETHOD (OLD-MAIL-FILE :UPDATE-OPTIONS-IN-FILE) ()) ;;; Simple write-only mail files without separators (ADD-MAIL-FILE-FLAVOR 'TEXT-MAIL-FILE "Text") (DEFFLAVOR TEXT-MAIL-FILE () (OLD-MAIL-FILE)) (DEFMETHOD (TEXT-MAIL-FILE :FORMAT-NAME) () "Text") ;;; If we try to read one of these in, don't get any messages (DEFMETHOD (TEXT-MAIL-FILE :LINE-END-OF-MSG-P) (&REST IGNORE) T) (DEFMETHOD (TEXT-MAIL-FILE :UPDATE-MSG-END) (MSG &OPTIONAL IGNORE) (LET ((END-LINE (BP-LINE (MSG-END-BP MSG)))) (SETF (LINE-LENGTH END-LINE) 0) (APPEND-TO-ARRAY END-LINE *TEXT-MAIL-FILE-SEPARATOR*))) ;;; I/O (DEFMETHOD (ZMAIL-FRAME :SET-MAIL-FILE) (PATHNAME) (AND (EQ PATHNAME T) ;Re-init (SETQ PATHNAME NIL *PRIMARY-MAIL-FILE* NIL *MAIL-FILE-LIST* NIL)) (COMMAND-BUFFER-PUSH `(:EXECUTE STARTUP-MAIL-FILE ,PATHNAME))) (DEFUN STARTUP-MAIL-FILE (&OPTIONAL NEW-PATHNAME &AUX STREAM PATHNAME MAIL-FILE ERR3) (SET-ZMAIL-USER) ;; Do not let the background process run again until all file requests are pending. ;; Otherwise the RMAIL file may all get in before the call to get-new-mail below. (WITH-BACKGROUND-PROCESS-LOCKED (COND ((OR (NULL *PRIMARY-MAIL-FILE*) NEW-PATHNAME) (SETQ PATHNAME (OR NEW-PATHNAME *ZMAIL-STARTUP-FILE-NAME*)) (AND PATHNAME (SETQ PATHNAME (FS:MERGE-PATHNAME-DEFAULTS PATHNAME *ZMAIL-PATHNAME-DEFAULTS*))) (DO ((LIST (AND (NULL PATHNAME) (FUNCALL (FS:USER-HOMEDIR) ':POSSIBLE-RMAIL-FILES)))) (NIL) (OR PATHNAME (POP LIST PATHNAME)) ;Get a pathname to use (SETQ STREAM (OPEN PATHNAME '(:IN :NOERROR))) (COND ((NOT (STRINGP STREAM)) (SETQ MAIL-FILE (GET-ZMAIL-FILE STREAM PATHNAME T)) (RETURN NIL))) (COND ((NULL LIST) ;Ran out of choices (MULTIPLE-VALUE (ERR3 NIL STREAM) (FS:FILE-PROCESS-ERROR STREAM NIL NIL T)) (AND (NOT (STRING-EQUAL ERR3 "FNF")) (BARF "Error: ~A" STREAM)) (LET ((TEM (READ-DEFAULTED-PATHNAME (FORMAT NIL "~A, use what file (CR to create ~A)" STREAM PATHNAME) PATHNAME NIL NIL ':NEW-OK))) (IF (NEQ TEM PATHNAME) (SETQ PATHNAME TEM) ;Gave a new file, try that, else make it (SETQ MAIL-FILE (MAKE-NEW-MAIL-FILE-1 PATHNAME NIL NIL NIL T)) (RETURN NIL)))) (T (SETQ PATHNAME NIL)))) (SELECT-MAIL-FILE MAIL-FILE (NULL NEW-PATHNAME) NIL) (COND (NEW-PATHNAME ;Not the primary mail file (SETQ *MSG-NO* -1) (ZMAIL-SELECT-NEXT-MSG NIL T)) ;Select the first message (T (LET ((*WINDOW* *MSG-WINDOW*) (*INTERVAL* *MSG-INTERVAL*)) (COM-GET-NEW-MAIL-INTERNAL T))))) (T DIS-NONE)))) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION COM-GET-NEW-MAIL "Read any new mail: L: normal mail file; R: specify file.") (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-GET-NEW-MAIL "Read any new mail. Click right to specify another new mail file. The file is not deleted in this case." (NO-MAIL-FILE-OK) (COM-GET-NEW-MAIL-INTERNAL NIL)) (DEFUN COM-GET-NEW-MAIL-INTERNAL (FIRST-TIME-P &OPTIONAL FOR-FILE &AUX FROM-FILE) (OR FOR-FILE (SETQ FOR-FILE (COND ((AND *MAIL-FILE* (GET (LOCF (MAIL-FILE-OPTIONS *MAIL-FILE*)) ':MAIL)) *MAIL-FILE*) ((NULL *PRIMARY-MAIL-FILE*) NIL) ((TYPEP *PRIMARY-MAIL-FILE* 'NEW-MAIL-FILE) (DISK-MAIL-FILE-OTHER-MAIL-FILE *PRIMARY-MAIL-FILE*)) (T *PRIMARY-MAIL-FILE*)))) (COND ((NULL FOR-FILE) (STARTUP-MAIL-FILE)) ;This will call COM-GET-NEW-MAIL-INTERNAL with FIRST-TIME-P ((DISK-MAIL-FILE-OTHER-MAIL-FILE FOR-FILE) (IF (DISK-MAIL-FILE-STATUS FOR-FILE) ;; Ordinary reading in of other file (FOREGROUND-BACKGROUND-FINISH FOR-FILE NIL) ;; Probably left around from an error (SETF (DISK-MAIL-FILE-OTHER-MAIL-FILE FOR-FILE) NIL)) (COM-GET-NEW-MAIL-INTERNAL NIL FOR-FILE)) (T (AND (EQ FOR-FILE *PRIMARY-MAIL-FILE*) (SELECTQ *RUN-GMSGS-P* (:YES T) (:NO NIL) (:ONCE-ONLY FIRST-TIME-P)) (GMSGS (FUNCALL (DISK-MAIL-FILE-PATHNAME FOR-FILE) ':HOST))) (AND (EQ *ZMAIL-COMMAND-BUTTON* ':RIGHT) (SETQ FROM-FILE (CALL-POP-UP-MINI-BUFFER-EDITOR ':MOUSE #'READ-DEFAULTED-PATHNAME "Get new mail from file" (DEFAULT-ZMAIL-MOVE-PATHNAME)))) ;; Possibly any mail file should be allowed that knows about getting new mail (GET-NEW-MAIL-FOR-MAIL-FILE FOR-FILE FROM-FILE NIL FIRST-TIME-P)))) (DEFUN GET-NEW-MAIL-FOR-MAIL-FILE (MAIL-FILE FROM-FILE DELETE-P TELL-BACKGROUND-P &AUX MOVE-P NEW-MAIL-FILE APPEND-P) (AND (DISK-MAIL-FILE-OTHER-MAIL-FILE MAIL-FILE) (BARF "Already reading new mail into ~A" (MAIL-FILE-NAME MAIL-FILE))) (SETQ APPEND-P (MAIL-FILE-APPEND-P MAIL-FILE)) (SELECT-MAIL-FILE MAIL-FILE) (SETQ NEW-MAIL-FILE (FUNCALL *MAIL-FILE* ':NEW-MAIL-FILE FROM-FILE DELETE-P)) (AND TELL-BACKGROUND-P (ZMAIL-BACKGROUND-REQUEST-PUSH `(ZMAIL-BACKGROUND-SET-NEW-MAIL-MAIL-FILE ,NEW-MAIL-FILE))) (COND ((NULL (FUNCALL NEW-MAIL-FILE ':START-NEXT-FILE)) (TYPEIN-LINE "No new mail") (SETF (DISK-MAIL-FILE-OTHER-MAIL-FILE *MAIL-FILE*) NIL) (SETQ MOVE-P (OR (NULL *MSG*) *ALWAYS-JUMP-AFTER-GET-NEW-MAIL*))) (T (SETQ MOVE-P T) (SELECT-MAIL-FILE NEW-MAIL-FILE (EQ MAIL-FILE *PRIMARY-MAIL-FILE*) NIL))) (IF (NOT MOVE-P) DIS-TEXT (LOCK-MAIL-FILE (*MAIL-FILE*) ;Don't allow getting all messages (SETQ *MSG-NO* (IF (AND APPEND-P (EQ *MAIL-FILE* MAIL-FILE)) (1- (MAIL-FILE-NMSGS *MAIL-FILE*)) ;but may have already. -1)) (ZMAIL-SELECT-NEXT-MSG NIL T)))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-GMSGS "Run gmsgs" () (GET-NEW-MAIL-FOR-MAIL-FILE *PRIMARY-MAIL-FILE* (GMSGS (FUNCALL (DISK-MAIL-FILE-PATHNAME *PRIMARY-MAIL-FILE*) ':HOST)) T NIL)) (DEFUN GMSGS (&OPTIONAL (HOST FS:USER-LOGIN-MACHINE) (STREAM STANDARD-OUTPUT)) (LET ((FILE-NAME (FUNCALL (FS:USER-HOMEDIR HOST) ':NEW-PATHNAME ':NAME USER-ID ':TYPE "GMSGS"))) (WITH-OPEN-STREAM (CSTREAM (CHAOS:OPEN-STREAM HOST (FORMAT NIL "GMSGS ~A;~A //G~A" (FUNCALL FILE-NAME ':DIRECTORY) (FUNCALL FILE-NAME ':NAME) *GMSGS-OTHER-SWITCHES*) ':DIRECTION ':INPUT ':ERROR NIL)) (AND (STRINGP CSTREAM) (BARF "Error: ~A" CSTREAM)) (STREAM-COPY-UNTIL-EOF CSTREAM STREAM)) FILE-NAME)) ;;; Setup for loading a mail file from stream, does not actually read any messages. ;;; FLAVOR is the parsing format to be forced on the file. If not specified, it ;;; is computed by looking at the file. (DEFUN GET-ZMAIL-FILE (STREAM PATHNAME &OPTIONAL BACKGROUND-P FLAVOR &AUX INFO) (SETQ INFO (FUNCALL STREAM ':INFO)) (OR (LET ((MAIL-FILE (GET-MAIL-FILE-FROM-PATHNAME PATHNAME))) (COND (MAIL-FILE (CLOSE STREAM) (OR (EQUAL INFO (DISK-MAIL-FILE-ID MAIL-FILE)) (BARF "File ~A has changed, you will lose" PATHNAME)) MAIL-FILE))) (LET (APPEND-P MAIL-FILE) (OR FLAVOR (MULTIPLE-VALUE (FLAVOR APPEND-P) (FUNCALL PATHNAME ':MAIL-FILE-FORMAT-COMPUTER STREAM))) (SETQ MAIL-FILE (MAKE-MAIL-FILE FLAVOR ':PATHNAME PATHNAME ':STREAM STREAM ':ID INFO ':APPEND-P APPEND-P)) (START-LOADING-MAIL-FILE MAIL-FILE STREAM BACKGROUND-P) MAIL-FILE))) (DEFUN START-LOADING-MAIL-FILE (MAIL-FILE STREAM BACKGROUND-P &OPTIONAL TRUENAME) (TYPEIN-LINE "Reading ~A file ~A" (FUNCALL MAIL-FILE ':FORMAT-NAME) (OR TRUENAME (FUNCALL STREAM ':TRUENAME))) (IF BACKGROUND-P (ZMAIL-BACKGROUND-REQUEST-PUSH (LIST 'ZMAIL-BACKGROUND-LOAD-FILE MAIL-FILE)) (LET ((*ZMAIL-BACKGROUND-P* ':DISABLE)) (LOAD-ALL-MSGS MAIL-FILE)))) (DEFUN LOAD-ALL-MSGS (MAIL-FILE &AUX OTHER-MAIL-FILE) (SETQ OTHER-MAIL-FILE (AND (TYPEP MAIL-FILE 'NEW-MAIL-FILE) (DISK-MAIL-FILE-OTHER-MAIL-FILE MAIL-FILE))) (FUNCALL MAIL-FILE ':READ-NEXT-MSG 177777) ;Finish reading in foreground (COND (OTHER-MAIL-FILE (SETQ MAIL-FILE OTHER-MAIL-FILE) (FUNCALL MAIL-FILE ':READ-NEXT-MSG 177777))) MAIL-FILE) ;;; This is the default message loader. Different formats provide two ;;; messages. :LINE-END-OF-MSG-P is passed a LINE, its LENGTH, and a ;;; STATE variable. It should return T if this was the last line, or ;;; END-IDX of the end of the message within that line or NIL, and ;;; updated STATE variable. STATE is NIL for the first line of each ;;; message. :CANONICAL-LAST-LINE is called to make a dummy line for ;;; the end of the file if the normal format requires this. This will ;;; default to an empty line. (DEFMETHOD (DISK-MAIL-FILE :READ-NEXT-MSG) (&OPTIONAL (NMSGS 1) &AUX EOF) (LOCK-MAIL-FILE (SELF) (COND ((MEMQ STATUS '(:LOADING-NEW-MAIL :LOADING)) (AND STREAM (DO ((TEST-FUNCTION (GET-HANDLER-FOR SELF ':LINE-END-OF-MSG-P)) (LAST-LINE-FUNCTION (GET-HANDLER-FOR SELF ':CANONICAL-LAST-LINE)) (FILE-TICK (OR TICK *TICK*)) (END-LINE) (LINE) (LENGTH) (START) (END-IDX) (MSG-REAL-START-BP) (STATE)) ;One piece of state for test function (EOF) (LET ((DEFAULT-CONS-AREA *ZMAIL-MSG-LINE-AREA*)) (MULTIPLE-VALUE (LINE EOF) (FUNCALL STREAM ':LINE-IN LINE-LEADER-SIZE))) (COND ((AND EOF (OR (NULL LINE) (ZEROP (LINE-LENGTH LINE)))) (OR START (RETURN NIL)) (SETQ LINE (FUNCALL LAST-LINE-FUNCTION ':CANONICAL-LAST-LINE)))) (OR END-LINE (SETQ END-LINE (LET ((LAST-BP (INTERVAL-LAST-BP INTERVAL))) (AND (NOT (ZEROP (BP-INDEX LAST-BP))) (INSERT LAST-BP #\CR)) (BP-LINE LAST-BP)))) (INSERT-LINE-WITH-LEADER LINE END-LINE) (SETQ LENGTH (LINE-LENGTH LINE)) (AND (NULL START) (PLUSP LENGTH) (DO I 0 (1+ I) ( I LENGTH) (OR (MEMQ (AREF LINE I) '(#\SP #\TAB)) (RETURN T))) (SETQ START LINE)) (MULTIPLE-VALUE (END-IDX STATE) (FUNCALL TEST-FUNCTION ':LINE-END-OF-MSG-P LINE LENGTH STATE)) (COND (END-IDX (SETQ MSG-REAL-START-BP (CREATE-BP START 0 ':NORMAL)) (LET ((MSG-REAL-INTERVAL (CREATE-INTERVAL MSG-REAL-START-BP (CREATE-BP END-LINE 0 ':MOVES))) (MSG-INTERVAL (CREATE-INTERVAL (COPY-BP MSG-REAL-START-BP ':NORMAL) (IF (EQ END-IDX T) (CREATE-BP END-LINE 0 ':MOVES) (CREATE-BP LINE END-IDX ':MOVES))))) (ARRAY-PUSH-EXTEND ARRAY (MAKE-MSG REAL-INTERVAL MSG-REAL-INTERVAL INTERVAL MSG-INTERVAL TICK FILE-TICK MAIL-FILE SELF)) (DO ((LINE START (LINE-NEXT LINE))) ((EQ LINE END-LINE)) (SETF (LINE-NODE LINE) MSG-REAL-INTERVAL)) (SETF (NODE-SUPERIOR MSG-INTERVAL) MSG-REAL-INTERVAL) (SETF (NODE-INFERIORS MSG-REAL-INTERVAL) (LIST MSG-INTERVAL)) (SETF (NODE-SUPERIOR MSG-REAL-INTERVAL) INTERVAL) (LET ((INFS (NODE-INFERIORS INTERVAL))) (LET ((LAST (CAR (LAST INFS)))) (SETF (NODE-PREVIOUS MSG-REAL-INTERVAL) LAST) (COND (LAST (SETF (NODE-NEXT LAST) MSG-REAL-INTERVAL) ;;The last-bp of the previous interval is :MOVES ;;but should have stayed at the start of this one. (LET ((LAST-BP (INTERVAL-LAST-BP LAST)) (LAST-BP-1 (INTERVAL-LAST-BP (CAR (NODE-INFERIORS LAST))))) (AND (BP-= LAST-BP LAST-BP-1) (MOVE-BP LAST-BP-1 MSG-REAL-START-BP)) (MOVE-BP LAST-BP MSG-REAL-START-BP))))) (SETF (NODE-INFERIORS INTERVAL) (NCONC INFS (NCONS MSG-REAL-INTERVAL))))) (AND ( (SETQ NMSGS (1- NMSGS)) 0) (RETURN NIL)) (SETQ START NIL STATE NIL))))) (IF (NOT EOF) T (FUNCALL-SELF ':LOADING-DONE) (AND (PLUSP NMSGS) (NOT *ZMAIL-BACKGROUND-P*) (FUNCALL-SELF ':READ-NEXT-MSG NMSGS))))))) (DEFMETHOD (DISK-MAIL-FILE :CANONICAL-LAST-LINE) () (CREATE-LINE 'ART-STRING 0 NIL)) (DEFWRAPPER (DISK-MAIL-FILE :LOADING-DONE) (IGNORE . BODY) `(IF (EQ *ZMAIL-BACKGROUND-P* T) (ZMAIL-BACKGROUND-RESPONSE-PUSH `(FILE-LOADED ,SELF)) SI:.DAEMON-CALLER-ARGS. . ,BODY)) (DEFMETHOD (OLD-MAIL-FILE :LOADING-DONE) () (FUNCALL STREAM ':CLOSE) (SETQ STREAM NIL) ;; If no new mail or new mail is not in yet, wait. (COND ((NULL OTHER-MAIL-FILE) (SETQ STATUS NIL)) ((NEQ (DISK-MAIL-FILE-STATUS OTHER-MAIL-FILE) ':AWAITING-SAVE) (SETQ STATUS ':AWAITING-NEW-MAIL)) (T ;; If new mail all in may need to append it now. (AND (MAIL-FILE-APPEND-P SELF) (INSERT-NEW-MAIL SELF OTHER-MAIL-FILE)) ;; Now ready to save back out. (IF *INHIBIT-BACKGROUND-SAVES* (SETQ STATUS ':SAVING-REQUIRED) (MAIL-FILE-BACKGROUND-SAVE SELF)))) (ZMAIL-BACKGROUND-REQUEST-PUSH (LIST 'ZMAIL-BACKGROUND-PARSE-MSGS SELF 0)) (AND (NEQ *MSG* ':NO-SELECT) (COMPUTE-CURRENT-MSG-NAME))) ;We may now know how many messages (DEFWRAPPER (DISK-MAIL-FILE :SAVING-DONE) (IGNORE . BODY) `(IF *ZMAIL-BACKGROUND-P* (ZMAIL-BACKGROUND-RESPONSE-PUSH `(FILE-SAVED ,SELF)) SI:.DAEMON-CALLER-ARGS. ;Prevent compiler warnings . ,BODY)) (DEFMETHOD (OLD-MAIL-FILE :SAVING-DONE) (&OPTIONAL FORCING-OUT) (SETQ TICK (TICK)) (SETQ ID (FUNCALL STREAM ':INFO)) (FUNCALL STREAM ':CLOSE) (TYPEIN-LINE "Written: ~A" (FUNCALL STREAM ':TRUENAME)) (COND (OTHER-MAIL-FILE (OR (EQ (DISK-MAIL-FILE-STATUS OTHER-MAIL-FILE) ':AWAITING-SAVE) (FERROR NIL "New mail file out of synch, get a wizard")) (OR (FUNCALL OTHER-MAIL-FILE ':SAVING-DONE FORCING-OUT) (SETQ OTHER-MAIL-FILE NIL)))) (SETQ STATUS NIL)) (DEFUN INSERT-NEW-MAIL (OLD-FILE NEW-FILE &AUX APPEND-P OLD-INT NEW-INT INT-APPEND-P) (AND (GET (LOCF (MAIL-FILE-OPTIONS OLD-FILE)) ':REVERSE-NEW-MAIL) (REVERSE-MAIL-FILE NEW-FILE)) (SETQ APPEND-P (MAIL-FILE-APPEND-P OLD-FILE) OLD-INT (DISK-MAIL-FILE-INTERVAL OLD-FILE) NEW-INT (DISK-MAIL-FILE-INTERVAL NEW-FILE)) (LOCK-MAIL-FILE (OLD-FILE) (LOCK-MAIL-FILE (NEW-FILE) (IF (SETQ INT-APPEND-P (OR APPEND-P (ZEROP (MAIL-FILE-NMSGS OLD-FILE)))) (MULTIPLE-VALUE-BIND (END-LINE PREV-MSG-END-BP) (FUNCALL OLD-FILE ':LAST-LINE-FOR-APPEND) (IF END-LINE (LET ((START-LINE (BP-LINE (INTERVAL-FIRST-BP NEW-INT)))) (SETF (LINE-NEXT END-LINE) START-LINE) (SETF (LINE-PREVIOUS START-LINE) END-LINE) (AND PREV-MSG-END-BP (MOVE-BP PREV-MSG-END-BP START-LINE 0))) (MOVE-BP (INTERVAL-FIRST-BP OLD-INT) (INTERVAL-FIRST-BP NEW-INT))) (MOVE-BP (INTERVAL-LAST-BP OLD-INT) (INTERVAL-LAST-BP NEW-INT))) (LET ((START-LINE (BP-LINE (FUNCALL OLD-FILE ':FIRST-MSG-BP)))) (LET ((PREV (LINE-PREVIOUS START-LINE)) (NEW-START-LINE (BP-LINE (INTERVAL-FIRST-BP NEW-INT)))) (SETF (LINE-PREVIOUS NEW-START-LINE) PREV) (IF PREV (SETF (LINE-NEXT PREV) NEW-START-LINE) (MOVE-BP (INTERVAL-FIRST-BP OLD-INT) NEW-START-LINE 0))) (LET ((NEW-END-LINE (BP-LINE (INTERVAL-LAST-BP NEW-INT)))) (AND (ZEROP (LINE-LENGTH NEW-END-LINE)) (LINE-PREVIOUS NEW-END-LINE) (SETQ NEW-END-LINE (LINE-PREVIOUS NEW-END-LINE))) (SETF (LINE-NEXT NEW-END-LINE) START-LINE) (SETF (LINE-PREVIOUS START-LINE) NEW-END-LINE)))) (LET ((NEW-INFS (NODE-INFERIORS NEW-INT)) (OLD-INFS (NODE-INFERIORS OLD-INT)) LAST-INT FIRST-INT) (DOLIST (INT NEW-INFS) (SETF (NODE-SUPERIOR INT) OLD-INT)) (IF INT-APPEND-P (SETQ LAST-INT (CAR (LAST OLD-INFS)) FIRST-INT (CAR NEW-INFS) OLD-INFS (NCONC OLD-INFS NEW-INFS)) (SETQ LAST-INT (CAR (LAST NEW-INFS)) FIRST-INT (CAR OLD-INFS) OLD-INFS (NCONC NEW-INFS OLD-INFS))) (SETF (NODE-INFERIORS OLD-INT) OLD-INFS) (COND ((AND LAST-INT FIRST-INT) (LET* ((LAST-INT-END (INTERVAL-LAST-BP LAST-INT)) (FIRST-INT-START (INTERVAL-FIRST-BP FIRST-INT)) (LAST-INT-END-1 (INTERVAL-LAST-BP (CAR (NODE-INFERIORS LAST-INT)))) (MOVE-1-P (BP-= LAST-INT-END LAST-INT-END-1))) (MOVE-BP LAST-INT-END FIRST-INT-START) (AND MOVE-1-P (MOVE-BP LAST-INT-END-1 FIRST-INT-START))) (SETF (NODE-NEXT LAST-INT) FIRST-INT) (SETF (NODE-PREVIOUS FIRST-INT) LAST-INT)))) (LET* ((NEW-ARRAY (MAIL-FILE-ARRAY NEW-FILE)) (OLD-ARRAY (MAIL-FILE-ARRAY OLD-FILE)) (NMSGS (ARRAY-ACTIVE-LENGTH NEW-ARRAY)) (OLDLEN (ARRAY-ACTIVE-LENGTH OLD-ARRAY)) (NEWLEN (+ NMSGS OLDLEN))) (AND (< (ARRAY-LENGTH OLD-ARRAY) NEWLEN) (ADJUST-ARRAY-SIZE OLD-ARRAY (// (* NEWLEN 5) 4))) (OR APPEND-P ;; If prepending, make space in the array (DO ((I (1- OLDLEN) (1- I)) (J (1- NEWLEN) (1- J))) ((< I 0)) (ASET (AREF OLD-ARRAY I) OLD-ARRAY J))) (SETF (ARRAY-LEADER OLD-ARRAY 0) NEWLEN) (DO ((I 0 (1+ I)) (J (IF APPEND-P OLDLEN 0) (1+ J)) (MSG)) (( I NMSGS)) (SETQ MSG (AREF NEW-ARRAY I)) ;; It is important that the message be parsed by the new mail file, so that UNSEEN ;; properties get put on. That is why this MSG-PUT is before the :NEW-MSG. (MSG-PUT MSG T 'RECENT) (FUNCALL OLD-FILE ':NEW-MSG MSG) (ASET MSG OLD-ARRAY J)) ;; If this is new mail for a prepending BABYL file, and there is still some old mail ;; to come in, the last new message won't get a formfeed. Fix it now. (AND (NOT APPEND-P) (ZEROP OLDLEN) (PLUSP NEWLEN) (EQ (DISK-MAIL-FILE-STATUS OLD-FILE) ':LOADING) (LET* ((MSG (AREF NEW-ARRAY (1- NEWLEN))) (LAST-BP (INTERVAL-LAST-BP OLD-INT)) (MSG-LAST-BP (MSG-REAL-END-BP MSG)) (AT-END-P (BP-= LAST-BP MSG-LAST-BP))) (FUNCALL OLD-FILE ':UPDATE-MSG-END MSG T) (AND AT-END-P (MOVE-BP LAST-BP (END-LINE MSG-LAST-BP)))))))) (COND ((EQ NEW-FILE *MAIL-FILE*) (SELECT-MAIL-FILE OLD-FILE (EQ NEW-FILE *PRIMARY-MAIL-FILE*))) ((EQ OLD-FILE *MAIL-FILE*) ;*MSG-NO* may need changing (ZMAIL-SELECT-MSG *MSG* T NIL))) (MSG-POINT-PDL-FORWARD-MAIL-FILE NEW-FILE OLD-FILE) (LET ((SORT (GET (LOCF (MAIL-FILE-OPTIONS OLD-FILE)) ':SORT))) (AND SORT (SORT-MAIL-FILE OLD-FILE SORT APPEND-P)))) (DEFUN MAIL-FILE-BACKGROUND-SAVE (MAIL-FILE) (COND ((AND (NEQ *ZMAIL-BACKGROUND-P* ':DISABLE) (DISK-MAIL-FILE-OTHER-MAIL-FILE MAIL-FILE)) (MAIL-FILE-SAVE-SETUP MAIL-FILE) (ZMAIL-BACKGROUND-REQUEST-PUSH (LIST 'ZMAIL-BACKGROUND-SAVE-FILE MAIL-FILE (INTERVAL-STREAM (DISK-MAIL-FILE-INTERVAL MAIL-FILE))))) (T (SETF (DISK-MAIL-FILE-STATUS MAIL-FILE) NIL)))) ;;; New mail (DEFFLAVOR NEW-MAIL-FILE (FILE-LIST PENDING-FILE-LIST FILE-LIST-MAIL-CHECK-INFO (NEXT-PENDING-FILE-LIST NIL) (PENDING-DELETION-LIST NIL)) (DISK-MAIL-FILE) (:INITABLE-INSTANCE-VARIABLES FILE-LIST)) (DEFUN MAKE-NEW-MAIL-MAIL-FILE (TYPE LIST FROM-MAIL-FILE) (OR (MAIL-FILE-APPEND-P FROM-MAIL-FILE) (SETQ LIST (NREVERSE LIST))) (MAKE-MAIL-FILE TYPE ':OTHER-MAIL-FILE FROM-MAIL-FILE ':FILE-LIST LIST)) (DEFMETHOD (NEW-MAIL-FILE :AFTER :INIT) (IGNORE) (SETF (DISK-MAIL-FILE-OTHER-MAIL-FILE OTHER-MAIL-FILE) SELF) (SETQ PENDING-FILE-LIST FILE-LIST STATUS ':NEW-MAIL FILE-LIST-MAIL-CHECK-INFO (LOOP FOR X IN FILE-LIST COLLECT (LIST (CAR X) NIL)))) ;;; This gets called when starting to get new mail or after one file of new mail ;;; has been read in. It should return T if it has started something loading. (DEFMETHOD (NEW-MAIL-FILE :START-NEXT-FILE) () (DO ((TEM) (FILE) (RENAME) (DELETE-P) (LOADING-NAME NIL NIL) (LOADING-TRUENAME NIL NIL)) ((NULL PENDING-FILE-LIST) NIL) (POP PENDING-FILE-LIST TEM) (SETF `(,FILE ,RENAME ,DELETE-P) TEM) (COND ((NOT RENAME) ;;No file to rename to, see if new file exists (SETQ STREAM (OPEN FILE '(:IN :NOERROR)))) ((NOT (STRINGP (SETQ STREAM (OPEN RENAME '(:IN :NOERROR))))) ;;If file to rename to already exists, ;;arrange for real file to get read in after saving done next time (SETQ NEXT-PENDING-FILE-LIST (NCONC NEXT-PENDING-FILE-LIST (NCONS TEM)))) ((NOT (STRINGP (SETQ STREAM (OPEN FILE '(:PROBE :NOERROR))))) ;;Rename to new file. This does not use the :RENAME operation since that ;;doesn't work correctly on Tops-20 and does not return the TRUENAME. (SETQ LOADING-NAME (FUNCALL STREAM ':PATHNAME) LOADING-TRUENAME (FUNCALL STREAM ':TRUENAME)) (RENAMEF FILE RENAME) ;;Get the renamed file (SETQ STREAM (OPEN RENAME '(:IN))))) (COND ((NOT (STRINGP STREAM)) ;If we have something ready to go (SETQ PATHNAME (OR LOADING-NAME (FUNCALL STREAM ':PATHNAME)) NAME (FUNCALL PATHNAME ':STRING-FOR-PRINTING) STATUS ':LOADING-NEW-MAIL) (START-LOADING-MAIL-FILE SELF STREAM T LOADING-TRUENAME) (AND DELETE-P (PUSH (FUNCALL STREAM ':TRUENAME) PENDING-DELETION-LIST)) (RETURN T)) (T (SETQ STREAM NIL))))) ;Don't leave string around ;;; This is called when the one file is all the way in (DEFMETHOD (NEW-MAIL-FILE :LOADING-DONE) () (COND (STREAM (FUNCALL STREAM ':CLOSE) (SETQ STREAM NIL) (COND ((FUNCALL-SELF ':START-NEXT-FILE)) ;We can still do more, continue (T ;; If the other file is all in or we are prepending, can put together now (AND (OR (NOT (MAIL-FILE-APPEND-P OTHER-MAIL-FILE)) (MEMQ (DISK-MAIL-FILE-STATUS OTHER-MAIL-FILE) '(NIL :AWAITING-NEW-MAIL :SAVING-REQUIRED))) (INSERT-NEW-MAIL OTHER-MAIL-FILE SELF)) (SETQ STATUS ':AWAITING-SAVE) (COND ((NOT (MEMQ (DISK-MAIL-FILE-STATUS OTHER-MAIL-FILE) ;;Loading or already saving '(NIL :AWAITING-NEW-MAIL :SAVING-REQUIRED)))) (*INHIBIT-BACKGROUND-SAVES* (SETF (DISK-MAIL-FILE-STATUS OTHER-MAIL-FILE) ':SAVING-REQUIRED)) (T (MAIL-FILE-BACKGROUND-SAVE OTHER-MAIL-FILE)))))))) ;;; This is called after the primary mail file has been saved out with us in it ;;; It should return T if it has started up again (DEFMETHOD (NEW-MAIL-FILE :SAVING-DONE) (FORCING-OUT) (SETQ STATUS ':NEW-MAIL) (DOLIST (FILE PENDING-DELETION-LIST) (DELETEF FILE)) (SETQ PENDING-DELETION-LIST NIL) (COND ((AND (NOT FORCING-OUT) (SETQ PENDING-FILE-LIST NEXT-PENDING-FILE-LIST)) (SETQ NEXT-PENDING-FILE-LIST NIL) ;; Start things over (STORE-ARRAY-LEADER 0 ARRAY 0) (SETQ INTERVAL (CREATE-INTERVAL)) (FUNCALL-SELF ':START-NEXT-FILE)))) ;;; This is called from the background process to see if there is new mail (DEFMETHOD (NEW-MAIL-FILE :BACKGROUND-CHECK-FOR-NEW-MAIL) (&AUX STREAM CREATION-DATE) (AND (EQ STATUS ':NEW-MAIL) ;Only if idle (DOLIST (ELEM FILE-LIST-MAIL-CHECK-INFO) (COND ((AND (NOT (STRINGP (SETQ STREAM (OPEN (FIRST ELEM) '(:PROBE :NOERROR))))) (NOT (EQUAL (SETQ CREATION-DATE (FUNCALL STREAM ':CREATION-DATE)) (SECOND ELEM)))) (SETF (SECOND ELEM) CREATION-DATE) (MULTIPLE-VALUE-BIND (NIL MINUTES HOURS) (TIME:DECODE-UNIVERSAL-TIME CREATION-DATE) (ZMAIL-BACKGROUND-RESPONSE-PUSH (LIST 'NEW-MAIL "New mail in ~A at ~D:~2,'0D" (FIRST ELEM) HOURS MINUTES)))))))) ;;; ITS mail files (DEFFLAVOR ITS-MAIL-FILE () () (:INCLUDED-FLAVORS DISK-MAIL-FILE)) (DEFFLAVOR ITS-NEW-MAIL-FILE () (ITS-MAIL-FILE NEW-MAIL-FILE)) (DEFMETHOD (ITS-NEW-MAIL-FILE :FORMAT-NAME) () "Mail") (DEFMETHOD (FS:ITS-PATHNAME-MIXIN :MAIL-FILE-FORMAT-COMPUTER) (STREAM &AUX FLAVOR APPEND-P) (IF (NULL STREAM) (SETQ FLAVOR 'RMAIL-MAIL-FILE) (LET ((FIRST-LINE (FUNCALL STREAM ':LINE-IN))) (FUNCALL STREAM ':SET-POINTER 0) (IF (STRING-EQUAL FIRST-LINE "Babyl Options:") ;; Looks like a babyl file (SETQ FLAVOR 'BABYL-MAIL-FILE) ;; Default is rmail file (SETQ FLAVOR 'RMAIL-MAIL-FILE) (AND (STRING-EQUAL FIRST-LINE "*APPEND*") (SETQ APPEND-P T))))) (VALUES FLAVOR APPEND-P)) (DEFVAR *ZMAIL-FILE-FN2S* '("BABYL" "RMAIL")) (DEFMETHOD (FS:ITS-PATHNAME-MIXIN :POSSIBLE-RMAIL-FILES) () (LOOP FOR FN2 IN *ZMAIL-FILE-FN2S* COLLECT (FUNCALL-SELF ':NEW-PATHNAME ':NAME USER-ID ':TYPE FN2))) (DEFMETHOD (FS:ITS-PATHNAME-MIXIN :POSSIBLE-MAIL-FILE-FLAVORS) () '(RMAIL-MAIL-FILE BABYL-MAIL-FILE)) (DEFMETHOD (FS:ITS-PATHNAME-MIXIN :NEW-MAIL-PATHNAME) () (FUNCALL-SELF ':NEW-PATHNAME ':NAME (OR FS:NAME USER-ID) ':TYPE "MAIL")) (DEFMETHOD (FS:ITS-PATHNAME-MIXIN :ZMAIL-TEMP-FILE-NAME) () "_Z") (DEFMETHOD (FS:ITS-PATHNAME-MIXIN :NEW-MAIL-FILE-FLAVOR) () 'ITS-NEW-MAIL-FILE) ;;; Messages on ITS end with a line with a  in it (DEFMETHOD (ITS-MAIL-FILE :LINE-END-OF-MSG-P) (LINE LENGTH IGNORE &AUX END-IDX) (AND (> LENGTH 0) (SETQ END-IDX (STRING-SEARCH-CHAR #/ LINE)) (NOT (DO I (1+ END-IDX) (1+ I) ( I LENGTH) (OR (MEMQ (AREF LINE I) '(#\SP #\TAB #\FF)) (RETURN T)))) END-IDX)) (DEFMETHOD (ITS-MAIL-FILE :CANONICAL-LAST-LINE) (&AUX LINE) (SETQ LINE (CREATE-LINE 'ART-STRING 1 NIL)) (ASET #/ LINE 0) LINE) (DEFMETHOD (ITS-MAIL-FILE :NEW-HEADER-AND-TRAILER) () (VALUES "" #\CR)) (DEFMETHOD (ITS-MAIL-FILE :UPDATE-MSG-END) (MSG &OPTIONAL IGNORE) (LET ((END-LINE (BP-LINE (MSG-END-BP MSG)))) (SETF (LINE-LENGTH END-LINE) 0) (ARRAY-PUSH-EXTEND END-LINE #/))) (DEFMETHOD (ITS-NEW-MAIL-FILE :BEFORE :PARSE-MSG) (MSG STATUS) MSG (PUTPROP STATUS T 'UNSEEN)) ;;; RMAIL mail files (ADD-MAIL-FILE-FLAVOR 'RMAIL-MAIL-FILE "Rmail") (DEFFLAVOR RMAIL-MAIL-FILE () (ITS-MAIL-FILE OLD-MAIL-FILE)) (DEFMETHOD (RMAIL-MAIL-FILE :FORMAT-NAME) () "Rmail") (DEFMETHOD (RMAIL-MAIL-FILE :AFTER :INIT) (PLIST) ;; If APPEND-P, flush the *APPEND* line from the stream, it is not part of a message. (AND (GET PLIST ':APPEND-P) STREAM (LET ((FIRST-BP (INTERVAL-FIRST-BP INTERVAL))) (INSERT-LINE-WITH-LEADER (FUNCALL STREAM ':LINE-IN LINE-LEADER-SIZE) (BP-LINE FIRST-BP))))) (DEFMETHOD (RMAIL-MAIL-FILE :SETTABLE-OPTIONS) () '(:APPEND)) (DEFMETHOD (RMAIL-MAIL-FILE :NEW-MAIL-FILE) (&OPTIONAL NEW-PATHNAME DELETE-P &AUX LIST) (IF NEW-PATHNAME (SETQ LIST (LIST (LIST NEW-PATHNAME NIL DELETE-P))) (SETQ NEW-PATHNAME (FUNCALL PATHNAME ':NEW-MAIL-PATHNAME)) (SETQ LIST (LIST (LIST NEW-PATHNAME (FUNCALL NEW-PATHNAME ':NEW-TYPE "_ZMAIL") T))) (COND (*RUN-GMSGS-P* (SETQ NEW-PATHNAME (FUNCALL NEW-PATHNAME ':NEW-TYPE "GMSGS")) (PUSH (LIST NEW-PATHNAME (FUNCALL NEW-PATHNAME ':NEW-TYPE "_ZGMSG") T) LIST)))) (MAKE-NEW-MAIL-MAIL-FILE 'ITS-NEW-MAIL-FILE LIST SELF)) (DEFMETHOD (RMAIL-MAIL-FILE :FIRST-MSG-BP) () (LET* ((FIRST-BP (INTERVAL-FIRST-BP INTERVAL)) (LINE (BP-LINE FIRST-BP))) (IF (STRING-EQUAL LINE "*APPEND*") (CREATE-BP (LINE-NEXT LINE) 0) FIRST-BP))) (DEFMETHOD (RMAIL-MAIL-FILE :UPDATE-OPTIONS-IN-FILE) () (LET* ((FIRST-BP (INTERVAL-FIRST-BP INTERVAL)) (LINE (BP-LINE FIRST-BP)) (APPEND-P (GET (LOCF OPTIONS) ':APPEND))) (COND ((EQ (STRING-EQUAL LINE "*APPEND*") APPEND-P)) (APPEND-P (INSERT FIRST-BP "*APPEND* ")) (T (DELETE-INTERVAL FIRST-BP (BEG-LINE FIRST-BP 1 T) T))))) ;;; BABYL mail files (ADD-MAIL-FILE-FLAVOR 'BABYL-MAIL-FILE "Babyl") (DEFFLAVOR BABYL-MAIL-FILE () (ITS-MAIL-FILE OLD-MAIL-FILE)) (DEFMETHOD (BABYL-MAIL-FILE :FORMAT-NAME) () "Babyl") (DEFMETHOD (BABYL-MAIL-FILE :SETTABLE-OPTIONS) () '(:APPEND :REVERSE-NEW-MAIL :VERSION :MAIL :OWNER :SORT :DELETE-EXPIRED :SUMMARY-WINDOW-FORMAT)) (DEFMETHOD (BABYL-MAIL-FILE :POSSIBLE-OPTIONS) () '(:APPEND :BABYL-P :|NO REFORMATION| :REVERSE-NEW-MAIL :VERSION :MAIL :OWNER :SORT :DELETE-EXPIRED :KEYWORDS :KEYWORDS-STRING :SUMMARY-WINDOW-FORMAT)) (DEFMETHOD (BABYL-MAIL-FILE :STICKY-OPTIONS) () (SOME-PLIST OPTIONS '(:APPEND :BABYL-P))) ;;; Read the options section of the mail file (DEFMETHOD (BABYL-MAIL-FILE :AFTER :INIT) (PLIST) (IF STREAM (SETQ OPTIONS (PARSE-BABYL-OPTIONS STREAM INTERVAL)) (OR (GET (LOCF OPTIONS) ':VERSION) (PUTPROP (LOCF OPTIONS) *HIGHEST-BABYL-VERSION* ':VERSION)) (AND (GET PLIST ':NEW-PRIMARY-P) (NOT (GET (LOCF OPTIONS) ':MAIL)) (PUTPROP (LOCF OPTIONS) (NCONS (FUNCALL PATHNAME ':NEW-MAIL-PATHNAME)) ':MAIL)) (INSERT (INTERVAL-LAST-BP INTERVAL) #/))) (DEFUN PARSE-BABYL-OPTIONS (STREAM INTERVAL) (FS:SET-DEFAULT-PATHNAME (FUNCALL STREAM ':PATHNAME) *ZMAIL-PATHNAME-DEFAULTS*) (DO ((END-LINE (BP-LINE (INTERVAL-LAST-BP INTERVAL))) (LINE) (LIST NIL)) (NIL) (SETQ LINE (FUNCALL STREAM ':LINE-IN LINE-LEADER-SIZE)) (INSERT-LINE-WITH-LEADER LINE END-LINE) (AND (STRING-SEARCH-CHAR #/ LINE) (RETURN LIST)) (SETQ LIST (APPEND LIST (OPTION-FROM-STRING LINE))))) (DEFVAR *OPTION-SPECIAL-CHARS* '(#/( #/" #// #/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9)) ;;; Parse a single line of a babyl option or an unparsed message header (DEFUN OPTION-FROM-STRING (STRING &AUX I TYPE PARSE-FUNCTION PROP) (SETQ I (STRING-SEARCH-CHAR #/: STRING) TYPE (INTERN (STRING-UPCASE (NSUBSTRING STRING 0 I)) "")) (AND I (SETQ I (OR (STRING-SEARCH-NOT-SET '(#\SP #\TAB) STRING (SETQ I (1+ I))) (STRING-LENGTH STRING)))) (IF (SETQ PARSE-FUNCTION (GET TYPE 'BABYL-OPTION-PARSER)) (FUNCALL PARSE-FUNCTION TYPE STRING I) (COND ((NULL I) (SETQ PROP T)) ((MEMQ (AREF STRING I) *OPTION-SPECIAL-CHARS*) (LET ((PACKAGE (PKG-FIND-PACKAGE "")) (IBASE 10.)) (SETQ PROP (READ-FROM-STRING STRING NIL I)))) (T (SETQ PROP (SUBSTRING STRING I)))) (LIST TYPE PROP))) (DEFMETHOD (BABYL-MAIL-FILE :UPDATE-OPTIONS-IN-FILE) (&AUX PLIST) (SETQ PLIST (LOCF OPTIONS)) ;; Move this to the first (COND ((OR (NEQ (CAAR PLIST) ':BABYL-P) (NEQ (CADAR PLIST) T)) (REMPROP PLIST ':BABYL-P) (PUTPROP PLIST T ':BABYL-P))) (DO ((LINE (BP-LINE (INTERVAL-FIRST-BP INTERVAL)) (LINE-NEXT LINE)) (DONE NIL) (PROPS)) ((STRING-SEARCH #/ LINE) (LOOP FOR (IND PROP) ON (CDR PLIST) BY 'CDDR WITH BP = (CREATE-BP LINE 0) WHEN (AND PROP (NOT (MEMQ IND DONE)) (GETL IND '(BABYL-OPTION-PARSER BABYL-OPTION-PRINTER BABYL-OPTION-P))) DO (SETQ LINE (STRING-FROM-OPTION IND PLIST) BP (INSERT (INSERT BP LINE) #\CR)) (LOOP FOR IND IN (OPTION-FROM-STRING LINE) BY 'CDDR DO (PUSH IND DONE)))) (SETQ PROPS (OPTION-FROM-STRING LINE)) (AND (LOOP FOR (IND PROP) ON PROPS BY 'CDDR UNLESS (EQUAL PROP (GET PLIST IND)) RETURN T) ;Not still the same (IF (NOT (LOOP FOR (IND PROP) ON PROPS BY 'CDDR WHEN (GET PLIST IND) RETURN T)) ;All properties NIL (LET ((BP (CREATE-BP LINE 0))) (DELETE-INTERVAL BP (BEG-LINE BP 1 T) T)) (MUNG-NODE (LINE-NODE LINE)) (SETF (LINE-LENGTH LINE) 0) (STRING-FROM-OPTION (CAR PROPS) PLIST LINE))) (LOOP FOR IND IN PROPS BY 'CDDR DO (PUSH IND DONE)))) ;;; Convert a message header into a string (DEFUN STRING-FROM-OPTION (PROP PLIST &OPTIONAL STRING &AUX VAL TEM) (OR STRING (SETQ STRING (MAKE-EMPTY-STRING 40))) (SETQ VAL (GET PLIST PROP)) (WITH-OUTPUT-TO-STRING (STREAM STRING) (COND ((SETQ TEM (GET PROP 'BABYL-OPTION-PRINTER)) (FUNCALL TEM STREAM PROP VAL PLIST)) (T (FORMAT STREAM "~:" PROP) (COND ((NEQ VAL T) (FUNCALL STREAM ':TYO #/:) (LET ((BASE 10.) (*NOPOINT T)) (FUNCALL (IF (AND (STRINGP VAL) (NOT (MEMQ (AREF VAL 0) *OPTION-SPECIAL-CHARS*)) (NOT (STRING-SEARCH-SET '(#\SP #\TAB) VAL))) #'PRINC #'PRIN1) VAL STREAM))))))) STRING) ;;; The options themselves (DEFINE-NOT-SETTABLE-MAIL-FILE-OPTION :BABYL-P) (DEFUN (:|BABYL OPTIONS| BABYL-OPTION-PARSER) (&REST IGNORE) '(:BABYL-P T)) (DEFUN (:BABYL-P BABYL-OPTION-PRINTER) (STREAM &REST IGNORE) (FORMAT STREAM "Babyl Options:")) ;;; Limits of Babyl file formats supported here (DEFCONST *LOWEST-BABYL-VERSION* 4) (DEFCONST *HIGHEST-BABYL-VERSION* 5) (DEFINE-SETTABLE-MAIL-FILE-OPTION :VERSION 5 :NUMBER) (DEFUN (:VERSION BABYL-OPTION-PARSER) (IGNORE STRING START &AUX VERSION) (SETQ VERSION (PARSE-NUMBER STRING START)) (AND (OR (NULL VERSION) (< VERSION *LOWEST-BABYL-VERSION*) (> VERSION *HIGHEST-BABYL-VERSION*)) (CERROR T NIL NIL "Babyl version is ~D, not supported by this version of ZMail" VERSION)) `(:VERSION ,VERSION)) (DEFINE-NOT-SETTABLE-MAIL-FILE-OPTION :|NO REFORMATION|) ;;; Ordinary printing ok (DEFPROP :|NO REFORMATION| T BABYL-OPTION-P) (DEFINE-SETTABLE-MAIL-FILE-OPTION :OWNER NIL :STRING-OR-NIL) (DEFPROP :OWNER T BABYL-OPTION-P) (DEFPROP :STRING-OR-NIL (PRINT-STRING-OR-NIL READ-STRING-OR-NIL) TV:CHOOSE-VARIABLE-VALUES-KEYWORD) (DEFUN PRINT-STRING-OR-NIL (STRING STREAM) (AND STRING (FUNCALL STREAM ':STRING-OUT STRING))) (DEFUN READ-STRING-OR-NIL (STREAM &AUX STRING) (SETQ STRING (READLINE STREAM)) (AND (PLUSP (STRING-LENGTH STRING)) STRING)) (DEFINE-SETTABLE-MAIL-FILE-OPTION :MAIL NIL :PATHNAME-LIST) (DEFPROP :MAIL PATHNAME-LIST-OPTION-PARSER BABYL-OPTION-PARSER) (DEFUN PATHNAME-LIST-OPTION-PARSER (TYPE STRING START) (DO ((I START (1+ J)) (J) (PATHNAME-LIST NIL)) (NIL) (OR (SETQ I (STRING-SEARCH-NOT-SET *WHITESPACE-CHARS* STRING I)) (RETURN NIL)) (SETQ J (STRING-SEARCH-CHAR #/, STRING I)) (PUSH (FS:MERGE-PATHNAME-DEFAULTS (NSUBSTRING STRING I J) *ZMAIL-PATHNAME-DEFAULTS*) PATHNAME-LIST) (OR J (RETURN (LIST TYPE (NREVERSE PATHNAME-LIST)))))) (DEFPROP :MAIL PATHNAME-LIST-OPTION-PRINTER BABYL-OPTION-PRINTER) (DEFUN PATHNAME-LIST-OPTION-PRINTER (STREAM PROP PATHNAME-LIST IGNORE) (FORMAT STREAM "~:: ~{~A~^, ~}" PROP PATHNAME-LIST)) (DEFINE-SETTABLE-MAIL-FILE-OPTION :REVERSE-NEW-MAIL NIL :BOOLEAN) (DEFUN (:APPEND BABYL-OPTION-PARSER) (IGNORE STRING START &AUX APPEND REVERSE) (IF (NULL START) ;Append (SETQ APPEND T) (LET ((N (PARSE-NUMBER STRING START NIL 8))) (SETQ APPEND (BIT-TEST N 1) REVERSE (BIT-TEST N 2)))) `(:APPEND ,APPEND :REVERSE-NEW-MAIL ,REVERSE)) (DEFPROP :APPEND PRINT-APPEND-AND-REVERSE-NEW-MAIL BABYL-OPTION-PRINTER) (DEFPROP :REVERSE-NEW-MAIL PRINT-APPEND-AND-REVERSE-NEW-MAIL BABYL-OPTION-PRINTER) (DEFUN PRINT-APPEND-AND-REVERSE-NEW-MAIL (STREAM IGNORE IGNORE PLIST &AUX (BITS 0)) (AND (GET PLIST ':APPEND) (SETQ BITS (LOGIOR BITS 1))) (AND (GET PLIST ':REVERSE-NEW-MAIL) (SETQ BITS (LOGIOR BITS 2))) (FORMAT STREAM "Append:~O" BITS)) (DEFINE-SETTABLE-MAIL-FILE-OPTION :SUMMARY-WINDOW-FORMAT *DEFAULT-SUMMARY-TEMPLATE* :SEXP) (DEFPROP :SUMMARY-WINDOW-FORMAT SEXP-OPTION-PARSER BABYL-OPTION-PARSER) (DEFUN SEXP-OPTION-PARSER (TYPE STRING START) `(,TYPE ,(READ-FROM-STRING STRING NIL START))) (DEFPROP :SUMMARY-WINDOW-FORMAT SEXP-OPTION-PRINTER BABYL-OPTION-PRINTER) (DEFUN SEXP-OPTION-PRINTER (STREAM PROP SEXP IGNORE) (FORMAT STREAM "~:: ~S" PROP SEXP)) (DEFMETHOD (BABYL-MAIL-FILE :NEW-MAIL-FILE) (&OPTIONAL NEW-PATHNAME DELETE-P) (MAKE-NEW-MAIL-MAIL-FILE (FUNCALL PATHNAME ':NEW-MAIL-FILE-FLAVOR) (IF NEW-PATHNAME (LIST (LIST NEW-PATHNAME NIL DELETE-P)) (LOOP FOR NEW-PATHNAME IN (GET (LOCF OPTIONS) ':MAIL) COLLECT (LIST NEW-PATHNAME (FUNCALL NEW-PATHNAME ':NEW-TYPE (STRING-APPEND (FUNCALL NEW-PATHNAME ':ZMAIL-TEMP-FILE-NAME) (FUNCALL NEW-PATHNAME ':TYPE))) T))) SELF)) (DEFMETHOD (BABYL-MAIL-FILE :BEFORE :PARSE-MSG) (MSG STATUS) (LET* ((START-BP (MSG-START-BP MSG)) (END-BP (MSG-END-BP MSG)) (REAL-START-LINE (BP-LINE (MSG-REAL-START-BP MSG))) (END-LINE (BP-LINE END-BP)) (START-LINE REAL-START-LINE)) (DO () ((NOT (LINE-BLANK-P START-LINE))) (SETQ START-LINE (LINE-NEXT START-LINE))) (FUNCALL (IF (< (GET (LOCF OPTIONS) ':VERSION) 5) #'PARSE-MSG-OLD-BABYL-STATUS-LINE #'PARSE-MSG-NEW-BABYL-STATUS-LINE) START-LINE STATUS) (DO ((LINE START-LINE (LINE-NEXT LINE))) ((EQ LINE END-LINE)) (COND ((STRING-EQUAL LINE "*** EOOH ***") (SETQ START-LINE LINE) (RETURN NIL)))) (SETQ END-LINE (LINE-NEXT START-LINE)) ;;Make lines in the header area point to MSG-REAL-INTERVAL rather than ;;MSG-INTERVAL. (DO ((LINE REAL-START-LINE (LINE-NEXT LINE))) ((EQ LINE END-LINE)) (SETF (LINE-NODE LINE) *INTERVAL*)) (MOVE-BP START-BP END-LINE 0))) (DEFMETHOD (BABYL-MAIL-FILE :AFTER :PARSE-MSG) (MSG STATUS) (OR (GET (LOCF OPTIONS) ':|NO REFORMATION|) (REFORMAT-HEADERS MSG STATUS))) (DEFMETHOD (BABYL-MAIL-FILE :NEW-HEADER-AND-TRAILER) () (VALUES " *** EOOH *** " #\CR)) (DEFMETHOD (BABYL-MAIL-FILE :UPDATE-MSG-END) (MSG &OPTIONAL FOR-APPEND-P) (LET ((END-LINE (BP-LINE (MSG-END-BP MSG))) (REAL-END-BP (MSG-REAL-END-BP MSG)) (INTERVAL-LAST-BP (INTERVAL-LAST-BP INTERVAL))) (SETF (LINE-LENGTH END-LINE) 0) (ARRAY-PUSH-EXTEND END-LINE #/) (IF (NOT (AND (NOT FOR-APPEND-P) (EQ (BP-LINE REAL-END-BP) (BP-LINE INTERVAL-LAST-BP)))) (ARRAY-PUSH-EXTEND END-LINE #\PAGE) (MOVE-BP REAL-END-BP END-LINE 1) (MOVE-BP INTERVAL-LAST-BP END-LINE 1)))) (DEFMETHOD (BABYL-MAIL-FILE :BEFORE :LOADING-DONE) (&AUX TEM) (AND (PLUSP (SETQ TEM (ARRAY-ACTIVE-LENGTH ARRAY))) (FUNCALL-SELF ':UPDATE-MSG-END (AREF ARRAY (1- TEM))))) (DEFMETHOD (BABYL-MAIL-FILE :BEFORE :SET-OPTIONS) (NEW-OPTIONS) (AND ( (GET (LOCF OPTIONS) ':VERSION) (GET (LOCF NEW-OPTIONS) ':VERSION)) (DOMSGS (MSG SELF) (FUNCALL-SELF ':UPDATE-MSG-OPTIONS-IN-FILE MSG)))) (DEFMETHOD (BABYL-MAIL-FILE :FIRST-MSG-BP) () (DO ((LINE (BP-LINE (INTERVAL-FIRST-BP INTERVAL)) (LINE-NEXT LINE))) ((STRING-SEARCH #/ LINE) ;; If this used to standalone, assume about to have new messages (AND (= (LINE-LENGTH LINE) 1) (ARRAY-PUSH-EXTEND LINE #\PAGE)) (LET ((NEXT (LINE-NEXT LINE))) (IF NEXT (CREATE-BP NEXT 0) (CREATE-BP LINE (LINE-LENGTH LINE))))))) ;;; Handling of babyl status line at start of message. Format is: ;;; ::= "," "," ;;; ::= ( ",")* ;;; ::= ( ",")* (DEFUN PARSE-MSG-NEW-BABYL-STATUS-LINE (LINE STATUS &AUX KEYWORDS) (DO ((I 0 (1+ J)) (STATE 0) ;0 - reformatted, 1 - basic-labels, ;2 - user-labels (LEN (ARRAY-ACTIVE-LENGTH LINE)) (J) (STR) (TEM)) (( I LEN)) (OR (SETQ J (STRING-SEARCH-CHAR #/, LINE I LEN)) (RETURN)) (SETQ STR (SUBSTRING LINE I J)) ;; *** Temporary *** (AND (EQUAL STR "badHeader") (SETQ STR "bad-header")) ;; *** End Temporary (SELECTQ STATE (0 (PUTPROP STATUS (NOT (STRING-EQUAL STR "0")) 'REFORMATTED) (SETQ STATE 1)) (1 (OR (SETQ TEM (CDR (ASS #'STRING-EQUAL STR *SAVED-INTERNAL-PROPERTIES-ALIST*))) (FERROR NIL "Bad status line ~A" LINE)) (PUTPROP STATUS T TEM)) (2 (COND ((NOT (SETQ TEM (CDR (ASS #'STRING-EQUAL STR *KEYWORD-ALIST*)))) (SETQ TEM (INTERN (STRING-UPCASE STR) "")) (SETQ *KEYWORD-ALIST* (NCONC *KEYWORD-ALIST* (NCONS (CONS STR TEM)))))) (PUSH TEM KEYWORDS))) (SETQ J (1+ J)) (AND (= J LEN) (RETURN)) (SELECTQ (AREF LINE J) (#/, (AND (> (SETQ STATE (1+ STATE)) 2) (RETURN)) (SETQ J (1+ J))) (#\SP) (OTHERWISE (FERROR NIL "Bad status line ~A" LINE)))) (COND (KEYWORDS (SETQ KEYWORDS (NREVERSE KEYWORDS)) (PUTPROP STATUS KEYWORDS 'KEYWORDS) (PUTPROP STATUS (STRING-FROM-KEYWORDS KEYWORDS) 'KEYWORDS-STRING)))) (DEFMETHOD (BABYL-MAIL-FILE :UPDATE-MSG-OPTIONS-IN-FILE) (MSG &AUX MSG-STATUS BP LINE) (SETQ MSG-STATUS (ASSURE-MSG-PARSED MSG) BP (MSG-REAL-START-BP MSG) LINE (BP-LINE BP)) (SETF (LINE-LENGTH LINE) 0) (FUNCALL (IF (< (GET (LOCF OPTIONS) ':VERSION) 5) #'UPDATE-MSG-OLD-BABYL-STATUS-LINE #'UPDATE-MSG-NEW-BABYL-STATUS-LINE) LINE MSG-STATUS) (MUNG-BP-LINE-AND-INTERVAL BP)) (DEFUN UPDATE-MSG-NEW-BABYL-STATUS-LINE (LINE STATUS) (ARRAY-PUSH-EXTEND LINE (IF (GET STATUS 'REFORMATTED) #/1 #/0)) (ARRAY-PUSH-EXTEND LINE #/,) (DO ((LIST *SAVED-INTERNAL-PROPERTIES-ALIST* (CDR LIST)) (KEY)) ((NULL LIST)) (SETQ KEY (CDAR LIST)) (COND ((GET STATUS KEY) (ARRAY-PUSH-EXTEND LINE #\SP) (APPEND-TO-ARRAY LINE (CAAR LIST)) (ARRAY-PUSH-EXTEND LINE #/,)))) (ARRAY-PUSH-EXTEND LINE #/,) (DOLIST (KEYWORD (GET STATUS 'KEYWORDS)) (ARRAY-PUSH-EXTEND LINE #\SP) (APPEND-TO-ARRAY LINE (CAR (RASSQ KEYWORD *KEYWORD-ALIST*))) (ARRAY-PUSH-EXTEND LINE #/,))) ;;; This is settable, but not in the standard way (DEFINE-NOT-SETTABLE-MAIL-FILE-OPTION :KEYWORDS) (DEFINE-NOT-SETTABLE-MAIL-FILE-OPTION :KEYWORDS-STRING) (DEFPROP :KEYWORDS PARSE-KEYWORDS-LIST BABYL-OPTION-PARSER) (DEFPROP :LABELS PARSE-KEYWORDS-LIST BABYL-OPTION-PARSER) (DEFUN PARSE-KEYWORDS-LIST (IGNORE STRING &OPTIONAL (START 0) END &AUX KEYWORDS-STRING KEYWORDS) (SETQ KEYWORDS-STRING (SUBSTRING STRING START END)) (DO ((I0 0 (1+ I1)) (I1) (I2) (STR)) (NIL) (OR (SETQ I0 (STRING-SEARCH-NOT-SET *WHITESPACE-CHARS* KEYWORDS-STRING I0)) (RETURN NIL)) (SETQ I1 (STRING-SEARCH-CHAR #/, KEYWORDS-STRING I0)) (AND (SETQ I2 (STRING-SEARCH-CHAR #/= KEYWORDS-STRING I0 I1)) (SETQ I0 (1+ I2))) (SETQ STR (SUBSTRING KEYWORDS-STRING I0 I1)) (PUSH (OR (ASSOC STR *KEYWORD-ALIST*) (LET* ((KEY (INTERN (STRING-UPCASE STR) "")) (ELEM (CONS STR KEY))) (SETQ *KEYWORD-ALIST* (NCONC *KEYWORD-ALIST* (NCONS ELEM))) ELEM)) KEYWORDS) (OR I1 (RETURN NIL))) ;;Avoid writing out an empty labels line. (AND (NULL KEYWORDS) (SETQ KEYWORDS-STRING NIL)) `(:KEYWORDS ,(NREVERSE KEYWORDS) :KEYWORDS-STRING ,KEYWORDS-STRING)) ;;; This updates the string of all keywords at the head of the file ;;; The idea is that old keywords that are still valid are kept in the old order, and new ;;; ones appended at the end. (DEFUN (:KEYWORDS BABYL-OPTION-PRINTER) (STREAM IGNORE KEYWORDS PLIST &AUX STRING COMMA-FLAG) (SETQ STRING (MAKE-EMPTY-STRING 25.)) (LET ((KEYWORDS-STRING (GET PLIST ':KEYWORDS-STRING))) (AND KEYWORDS-STRING (DO ((I0 0 (1+ I1)) (I1) (I2) (STR) (KEY) (ELEM)) (NIL) (SETQ I1 (STRING-SEARCH-CHAR #/, KEYWORDS-STRING I0) I2 (STRING-SEARCH-CHAR #/= KEYWORDS-STRING I0 I1) STR (SUBSTRING KEYWORDS-STRING (IF I2 (1+ I2) I0) I1) KEY (INTERN (STRING-UPCASE STR) "")) (COND ((SETQ ELEM (RASSQ KEY KEYWORDS)) (SETQ KEYWORDS (REMQ ELEM KEYWORDS)) (AND COMMA-FLAG (ARRAY-PUSH-EXTEND STRING #/,)) (SETQ COMMA-FLAG T) (APPEND-TO-ARRAY STRING KEYWORDS-STRING I0 I1))) (OR I1 (RETURN NIL))))) (DO ((AL KEYWORDS (CDR AL))) ((NULL AL)) (AND COMMA-FLAG (ARRAY-PUSH-EXTEND STRING #/,)) (SETQ COMMA-FLAG T) (APPEND-TO-ARRAY STRING (CAAR AL))) (PUTPROP PLIST STRING ':KEYWORDS-STRING) (FUNCALL STREAM ':STRING-OUT (IF ( (GET PLIST ':VERSION) 5) "Labels:" "Keywords:")) (FUNCALL STREAM ':STRING-OUT STRING)) ;;; *** BEGINNING OF OLD BABYL STUFF *** (DEFVAR *BABYL-BIT-MASK-PROPERTIES* '(REFORMATTED ;1 UNSEEN ;2 - really stored the other way LOSING-HEADERS ;4 ANSWERED ;10 FILED ;20 )) (DEFUN PARSE-MSG-OLD-BABYL-STATUS-LINE (LINE STATUS &AUX I) (COND ((= (AREF LINE (SETQ I 0)) #/D) (PUTPROP STATUS T 'DELETED) (SETQ I 1))) (DO ((BITS (LOGXOR (PARSE-NUMBER LINE I NIL 8) 2)) ;Check SEEN, not UNSEEN (L *BABYL-BIT-MASK-PROPERTIES* (CDR L)) (N 1 (LSH N 1))) ((NULL L)) (AND (BIT-TEST BITS N) (PUTPROP STATUS T (CAR L)))) (LET ((IDX (STRING-SEARCH-CHAR #/{ LINE))) (AND IDX (MULTIPLE-VALUE-BIND (KEYWORDS STRING) (PARSE-KEYWORDS LINE IDX) (PUTPROP STATUS KEYWORDS 'KEYWORDS) (PUTPROP STATUS STRING 'KEYWORDS-STRING))))) (DEFUN PARSE-KEYWORDS (LINE IDX &AUX (LENGTH (ARRAY-ACTIVE-LENGTH LINE)) KEYWORDS) (DO ((I0 IDX (STRING-SEARCH-CHAR #/{ LINE I1 LENGTH)) (I1) (STR) (KEY)) ((NULL I0)) (OR (SETQ I1 (STRING-SEARCH-CHAR #/} LINE (SETQ I0 (1+ I0)) LENGTH)) (RETURN NIL)) (SETQ STR (SUBSTRING LINE I0 I1) KEY (INTERN (STRING-UPCASE STR) "")) (OR (RASSQ KEY *KEYWORD-ALIST*) ;; Keywords not officially defined go at the end of the list (SETQ *KEYWORD-ALIST* (NCONC *KEYWORD-ALIST* (NCONS (CONS STR KEY))))) (PUSH KEY KEYWORDS)) (SETQ KEYWORDS (NREVERSE KEYWORDS)) (VALUES KEYWORDS (STRING-FROM-KEYWORDS KEYWORDS))) (DEFUN UPDATE-MSG-OLD-BABYL-STATUS-LINE (LINE STATUS &AUX (BITS 10000)) (DO ((L *BABYL-BIT-MASK-PROPERTIES* (CDR L)) (N 1 (LSH N 1))) ((NULL L)) (AND (GET STATUS (CAR L)) (SETQ BITS (LOGIOR BITS N)))) (FORMAT LINE "~O" (LOGXOR BITS 2)) ;Store SEEN, not UNSEEN (DOLIST (KEYWORD (GET STATUS 'KEYWORDS)) (FORMAT LINE " {~A}" (CAR (RASSQ KEYWORD *KEYWORD-ALIST*)))) (AND (GET STATUS 'DELETED) (ASET #/D LINE 0))) ;;; *** END OF OLD BABYL STUFF *** (DEFVAR *MAIL-FILE-SORT-ALIST* `(("None" :VALUE NIL) . ,*SORT-KEY-ALIST-1*)) (DEFINE-SETTABLE-MAIL-FILE-OPTION :SORT NIL :MENU-ALIST "Sort predicate" *MAIL-FILE-SORT-ALIST*) (DEFPROP :SORT MENU-ALIST-BABYL-OPTION-PARSER BABYL-OPTION-PARSER) (DEFPROP :SORT MENU-ALIST-BABYL-OPTION-PRINTER BABYL-OPTION-PRINTER) (DEFINE-SETTABLE-MAIL-FILE-OPTION :DELETE-EXPIRED NIL :MENU-ALIST "Delete expired messages" *YES-NO-ASK-ALIST*) (DEFPROP :DELETE-EXPIRED MENU-ALIST-BABYL-OPTION-PARSER BABYL-OPTION-PARSER) (DEFPROP :DELETE-EXPIRED MENU-ALIST-BABYL-OPTION-PRINTER BABYL-OPTION-PRINTER) (DEFUN MENU-ALIST-BABYL-OPTION-PARSER (TYPE STRING START) (LIST TYPE (IF (NULL START) T (DOLIST (ELEM (FOURTH (ASSQ TYPE *MAIL-FILE-OPTION-ALIST*))) (AND (STRING-EQUAL (CAR ELEM) STRING 0 START) (RETURN (TV:MENU-EXECUTE-NO-SIDE-EFFECTS ELEM))))))) (DEFUN MENU-ALIST-BABYL-OPTION-PRINTER (STREAM TYPE VALUE IGNORE) (FORMAT STREAM "~:~:[: ~A~]" TYPE (EQ VALUE T) (NAME-FROM-MENU-VALUE VALUE (FOURTH (ASSQ TYPE *MAIL-FILE-OPTION-ALIST*))))) (DEFUN NAME-FROM-MENU-VALUE (VALUE ITEM-LIST) (DOLIST (ELEM ITEM-LIST) (AND (EQ (TV:MENU-EXECUTE-NO-SIDE-EFFECTS ELEM) VALUE) (RETURN (CAR ELEM))))) ;;; T(w)enex mail files. Each message has one status line of the form ;;; ,;bits. E.g. ;;; 30-Jan-81 16:53:05-EST,129;000000000001 (DEFFLAVOR TENEX-MAIL-FILE () () (:INCLUDED-FLAVORS DISK-MAIL-FILE)) (DEFMETHOD (TENEX-MAIL-FILE :FORMAT-NAME) () "Tenex mail") (DEFMETHOD (FS:TOPS20-PATHNAME-MIXIN :MAIL-FILE-FORMAT-COMPUTER) (STREAM) (VALUES (IF (OR (NULL STREAM) (LET ((FIRST-LINE (FUNCALL STREAM ':LINE-IN))) (FUNCALL STREAM ':SET-POINTER 0) (STRING-EQUAL FIRST-LINE "Babyl Options:"))) ;; Babyl is the default when no stream since that is the filename ;; prompted. Perhaps this should be improved? 'BABYL-MAIL-FILE 'TENEX-OLD-MAIL-FILE) T)) ;Always APPEND-P (ADD-MAIL-FILE-FLAVOR 'TENEX-OLD-MAIL-FILE "Tenex") (DEFFLAVOR TENEX-OLD-MAIL-FILE () (TENEX-MAIL-FILE OLD-MAIL-FILE)) (DEFMETHOD (FS:TOPS20-PATHNAME-MIXIN :POSSIBLE-RMAIL-FILES) () (LIST (FUNCALL-SELF ':NEW-PATHNAME ':NAME USER-ID ':TYPE "BABYL"))) (DEFMETHOD (FS:TOPS20-PATHNAME-MIXIN :POSSIBLE-MAIL-FILE-FLAVORS) () '(TENEX-OLD-MAIL-FILE BABYL-MAIL-FILE)) (DEFMETHOD (FS:TOPS20-PATHNAME-MIXIN :NEW-MAIL-PATHNAME) () (FUNCALL-SELF ':NEW-PATHNAME ':NAME "MAIL" ':TYPE "TXT" ':VERSION 1)) (DEFMETHOD (FS:TENEX-PATHNAME-MIXIN :NEW-MAIL-PATHNAME) () (FUNCALL-SELF ':NEW-PATHNAME ':NAME "MESSAGE" ':TYPE "TXT" ':VERSION 1)) (DEFVAR *TENEX-BIT-MASK-PROPERTIES* '(UNSEEN ;1 - really the other way around DELETED ;2 ALWAYS-SHOW ;4 ANSWERED)) ;10 (DEFMETHOD (TENEX-MAIL-FILE :BEFORE :PARSE-MSG) (MSG STATUS &AUX LINE COMMA-POS SEMI-POS) (SETQ LINE (BP-LINE (MSG-REAL-START-BP MSG))) (COND ((PLUSP (LINE-LENGTH LINE)) (SETQ COMMA-POS (STRING-SEARCH-CHAR #/, LINE) SEMI-POS (STRING-SEARCH-CHAR #/; LINE (1+ COMMA-POS))) (PUTPROP STATUS (TIME:PARSE-UNIVERSAL-TIME LINE 0 COMMA-POS) 'RECEIVED-DATE) (DO ((BITS (LOGXOR (PARSE-NUMBER LINE (1+ SEMI-POS) NIL 8) 1)) (L *TENEX-BIT-MASK-PROPERTIES* (CDR L)) (N 1 (LSH N 1))) ((NULL L)) (AND (BIT-TEST BITS N) (PUTPROP STATUS T (CAR L)))))) (MOVE-BP (MSG-START-BP MSG) (LINE-NEXT LINE) 0)) (DEFMETHOD (TENEX-OLD-MAIL-FILE :NEW-HEADER-AND-TRAILER) () (VALUES #\CR "")) (DEFMETHOD (TENEX-OLD-MAIL-FILE :UPDATE-MSG-OPTIONS-IN-FILE) (MSG &AUX STATUS BP LINE) (SETQ STATUS (ASSURE-MSG-PARSED MSG) BP (MSG-REAL-START-BP MSG) LINE (BP-LINE BP)) (SETF (LINE-LENGTH LINE) 0) (LET (DAY MONTH YEAR HOURS MINUTES SECONDS DST-P (BITS 0)) (MULTIPLE-VALUE (SECONDS MINUTES HOURS DAY MONTH YEAR NIL DST-P) (TIME:DECODE-UNIVERSAL-TIME (OR (CADR (GETL STATUS '(RECEIVED-DATE :DATE))) (TIME:GET-UNIVERSAL-TIME)) TIME:*TIMEZONE*)) (DO ((L *TENEX-BIT-MASK-PROPERTIES* (CDR L)) (N 1 (LSH N 1))) ((NULL L)) (AND (GET STATUS (CAR L)) (SETQ BITS (LOGIOR BITS N)))) (FORMAT LINE "~D-~A-~D ~D:~2,'0D:~2,'0D-~A,~D;~12,'0O" DAY (TIME:MONTH-STRING MONTH ':SHORT) YEAR HOURS MINUTES SECONDS (TIME:TIMEZONE-STRING TIME:*TIMEZONE* DST-P) (COUNT-PDP-10-CHARS (MSG-START-BP MSG) (MSG-REAL-END-BP MSG) T) (LOGXOR BITS 1))) (MUNG-BP-LINE-AND-INTERVAL BP)) (DEFUN COUNT-PDP-10-CHARS (FROM-BP &OPTIONAL TO-BP IN-ORDER-P) (GET-INTERVAL FROM-BP TO-BP IN-ORDER-P) (LET ((FIRST-LINE (BP-LINE FROM-BP)) (FIRST-INDEX (BP-INDEX FROM-BP)) (LAST-LINE (BP-LINE TO-BP)) (LAST-INDEX (BP-INDEX TO-BP))) (COND ((EQ FIRST-LINE LAST-LINE) (- LAST-INDEX FIRST-INDEX)) (T (DO ((LINE (LINE-NEXT FIRST-LINE) (LINE-NEXT LINE)) (I 2 (+ 2 I (LINE-LENGTH LINE)))) ((EQ LINE LAST-LINE) (+ I (- (LINE-LENGTH FIRST-LINE) FIRST-INDEX) LAST-INDEX))))))) ;;; Messages on tenex has a byte count at the front ;;; @@@@ This should have an = check for the STATE; if the state has gone ;;; @@@@ negative, it means this line didn't end with a newline, and the ;;; @@@@ byte count for the next message is here as well. Somehow this fact ;;; @@@@ must be communicated to the caller. Maybe the best thing is to ;;; @@@@ pass BP's around instead of lines? (DEFMETHOD (TENEX-MAIL-FILE :LINE-END-OF-MSG-P) (LINE LENGTH STATE) (SETQ STATE (IF STATE (- STATE (+ LENGTH 2)) (LET* ((COMMA-IDX (1+ (%STRING-SEARCH-CHAR #/, LINE 0 LENGTH))) (SEMI-IDX (%STRING-SEARCH-CHAR #/; LINE COMMA-IDX LENGTH))) (PARSE-NUMBER LINE COMMA-IDX SEMI-IDX 10.)))) (VALUES ( STATE 0) STATE)) (DEFMETHOD (FS:TOPS20-PATHNAME-MIXIN :NEW-MAIL-FILE-FLAVOR) () 'TENEX-NEW-MAIL-FILE) (DEFMETHOD (FS:TOPS20-PATHNAME-MIXIN :ZMAIL-TEMP-FILE-NAME) () "_ZMAIL_") (DEFMETHOD (FS:TENEX-PATHNAME-MIXIN :ZMAIL-TEMP-FILE-NAME) () "-ZMAIL-") (DEFFLAVOR TENEX-NEW-MAIL-FILE () (TENEX-MAIL-FILE NEW-MAIL-FILE)) ;;; Hardcopy functions ;;; Options for all (DEFVAR *INCLUDE-SUMMARY-ALIST* '(("Yes" :VALUE T :DOCUMENTATION "Print summary and messages.") ("No" :VALUE NIL :DOCUMENTATION "Do not print a summary.") ("Just summary" :VALUE :JUST-SUMMARY :DOCUMENTATION "Print summary but not messages themselves."))) (DEFINE-ZMAIL-HARDCOPY-OPTION *HARDCOPY-SUMMARY-P* T :MENU-ALIST "Include summary" *INCLUDE-SUMMARY-ALIST*) (DEFINE-ZMAIL-HARDCOPY-OPTION *HARDCOPY-SEPARATE-PAGES* NIL :BOOLEAN "Print each message on a separate page") (DEFINE-ZMAIL-HARDCOPY-OPTION *HARDCOPY-SEPARATOR-LINE* NIL :STRING-OR-NIL "Line between messages (when not on separate pages)") (DEFVAR *ZMAIL-DEVICE-INDEPENDENT-HARDCOPY-OPTIONS* NIL) (DEFVAR *ZMAIL-SINGLE-MSG-DEVICE-INDEPENDENT-HARDCOPY-OPTIONS* NIL) (DEFVAR *ZMAIL-WHOLE-FILE-DEVICE-INDEPENDENT-HARDCOPY-OPTIONS* '(*HARDCOPY-SUMMARY-P* *HARDCOPY-SEPARATE-PAGES* *HARDCOPY-SEPARATOR-LINE*)) (DEFSTRUCT (HARDCOPY-DEVICE :LIST :CONC-NAME) KEY FLAVOR OTHER-OPTIONS) (DEFMACRO ADD-HARDCOPY-DEVICE (FLAVOR-NAME KEY NAME OTHER-OPTION-VARIABLES) `(ADD-HARDCOPY-DEVICE-1 ',FLAVOR-NAME ',KEY ',NAME ,OTHER-OPTION-VARIABLES)) (DEFVAR *HARDCOPY-DEVICE-ALIST* NIL) (DEFVAR *HARDCOPY-DEVICE-MENU-ALIST* NIL) (DEFUN ADD-HARDCOPY-DEVICE-1 (FLAVOR KEY NAME OTHER-OPTIONS &AUX DEVICE) (SETQ DEVICE (MAKE-HARDCOPY-DEVICE KEY KEY FLAVOR FLAVOR OTHER-OPTIONS OTHER-OPTIONS)) (SETQ *HARDCOPY-DEVICE-ALIST* (CONS DEVICE (DELQ (ASSQ KEY *HARDCOPY-DEVICE-ALIST*) *HARDCOPY-DEVICE-ALIST*))) (SETQ *HARDCOPY-DEVICE-MENU-ALIST* (CONS (CONS NAME KEY) (DELQ (RASSQ KEY *HARDCOPY-DEVICE-MENU-ALIST*) *HARDCOPY-DEVICE-MENU-ALIST*))) ;; If this is being added after normal initializations (LET ((INIT (ASSOC "SITE:*HARDCOPY-DEVICE*" SI:SITE-INITIALIZATION-LIST))) (AND INIT (EVAL (SI:INIT-FORM INIT))))) (DEFVAR *HARDCOPY-WHOLE-FILE-P*) (DEFUN COMPUTE-HARDCOPY-CHOICES (DEVICE &AUX ALIST) (OR *HARDCOPY-DEVICE* (BARF "No known hardcopy devices at this site")) (SETQ DEVICE (ASSQ DEVICE *HARDCOPY-DEVICE-ALIST*)) (SETQ ALIST `(*HARDCOPY-DEVICE* ,@(HARDCOPY-DEVICE-OTHER-OPTIONS DEVICE) ,@*ZMAIL-DEVICE-INDEPENDENT-HARDCOPY-OPTIONS* ,@(IF *HARDCOPY-WHOLE-FILE-P* *ZMAIL-WHOLE-FILE-DEVICE-INDEPENDENT-HARDCOPY-OPTIONS* *ZMAIL-SINGLE-MSG-DEVICE-INDEPENDENT-HARDCOPY-OPTIONS*))) (SETQ ALIST (MAPCAR #'(LAMBDA (X) (ASSQ X *ZMAIL-HARDCOPY-OPTION-ALIST*)) ALIST)) (SETQ ALIST (TV:PRUNE-USER-OPTION-ALIST ALIST)) ALIST) (DEFUN CHOOSE-HARDCOPY-OPTIONS (NEAR-MODE *HARDCOPY-WHOLE-FILE-P*) (TV:CHOOSE-VARIABLE-VALUES (COMPUTE-HARDCOPY-CHOICES *HARDCOPY-DEVICE*) ':LABEL "Hardcopy options:" ':NEAR-MODE NEAR-MODE ':MARGIN-CHOICES '("Do It" ("Abort" (ABORT-CURRENT-COMMAND))) ':FUNCTION 'CHOOSE-HARDCOPY-OPTIONS-FUNCTION)) (DEFUN CHOOSE-HARDCOPY-OPTIONS-FUNCTION (WINDOW VARIABLE OLDVAL NEWVAL) OLDVAL (FUNCALL *PROFILE-EDITOR* ':VARIABLE-TICK) (COND ((EQ VARIABLE '*HARDCOPY-DEVICE*) (TV:WITH-SHEET-DEEXPOSED (WINDOW) (FUNCALL WINDOW ':SETUP (COMPUTE-HARDCOPY-CHOICES NEWVAL) (FUNCALL WINDOW ':LABEL) (FUNCALL WINDOW ':FUNCTION) (SYMEVAL-IN-INSTANCE WINDOW 'TV:MARGIN-CHOICES))) T))) ;;; This makes hardcopy be a MAIL-FILE for GET-MOVE-MAIL-FILE (DEFUN MAKE-HARDCOPY-MAIL-FILE (CHOOSE-OPTIONS-P FOR-WHOLE-FILE-P NEAR-MODE) (AND CHOOSE-OPTIONS-P (CHOOSE-HARDCOPY-OPTIONS NEAR-MODE FOR-WHOLE-FILE-P)) (MAKE-INSTANCE (HARDCOPY-DEVICE-FLAVOR (ASSQ *HARDCOPY-DEVICE* *HARDCOPY-DEVICE-ALIST*)))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-HARDCOPY-MSG "Hardcopy the current message." () (FUNCALL (MAKE-HARDCOPY-MAIL-FILE (EQ *ZMAIL-COMMAND-BUTTON* ':RIGHT) NIL (RECTANGLE-NEAR-COMMAND-MENU)) ':ADD-MSG *MSG*) DIS-NONE) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-HARDCOPY-ALL "Hardcopy the current mail file." () (FUNCALL (MAKE-HARDCOPY-MAIL-FILE (EQ *ZMAIL-COMMAND-BUTTON* ':RIGHT) T (RECTANGLE-NEAR-COMMAND-MENU)) ':ADD-MAIL-FILE *MAIL-FILE*) DIS-NONE) (DEFFLAVOR HARDCOPY-MAIL-FILE () () (:INCLUDED-FLAVORS SI:LINE-OUTPUT-STREAM-MIXIN)) (DEFMETHOD (HARDCOPY-MAIL-FILE :PRINT-SELF) (STREAM &REST IGNORE) (SI:PRINTING-RANDOM-OBJECT (SELF STREAM) (PRINC (TYPEP SELF) STREAM) (FUNCALL STREAM ':TYO #\SP) (PRIN1 (FUNCALL-SELF ':NAME) STREAM))) (DEFMETHOD (HARDCOPY-MAIL-FILE :DRAW-UNDERLINE) () NIL) (DEFMACRO WITH-HARDCOPY-OUTPUT ((HARDCOPY-MAIL-FILE) &BODY BODY) `(UNWIND-PROTECT (PROGN ,@BODY (FUNCALL ,HARDCOPY-MAIL-FILE ':CLOSE)) (FUNCALL ,HARDCOPY-MAIL-FILE ':CLOSE ':ABORT))) (DEFMETHOD (HARDCOPY-MAIL-FILE :ADD-MSG) (MSG) (WITH-HARDCOPY-OUTPUT (SELF) (FUNCALL-SELF ':OPEN (MAIL-FILE-NAME (MSG-MAIL-FILE MSG)) (MSG-GET MSG ':DATE)) (HARDCOPY-ONE-MSG MSG SELF (MSG-DISPLAYED-INDEX MSG) NIL))) (DEFMETHOD (HARDCOPY-MAIL-FILE :ADD-MAIL-FILE) (MAIL-FILE &AUX ARRAY NMSGS) (SETQ ARRAY (MAIL-FILE-ARRAY MAIL-FILE) NMSGS (ARRAY-ACTIVE-LENGTH ARRAY)) (WITH-HARDCOPY-OUTPUT (SELF) (FUNCALL-SELF ':OPEN (MAIL-FILE-NAME MAIL-FILE) NIL) (COND (*HARDCOPY-SUMMARY-P* (FUNCALL-SELF ':LINE-OUT (FUNCALL MAIL-FILE ':FULL-NAME)) (FUNCALL-SELF ':DRAW-UNDERLINE) (FUNCALL-SELF ':LINE-OUT *SUMMARY-WINDOW-LABEL*) (DO ((I 0 (1+ I)) (MSG) (STATUS) (STRING)) (( I NMSGS)) (SETQ MSG (AREF ARRAY I) ;; Message must be parsed before the MSG-SUMMARY-LINE is valid. STATUS (ASSURE-MSG-PARSED MSG) STRING (MSG-SUMMARY-LINE MSG)) (FORMAT SELF " ~3D~C" (1+ I) (STATUS-LETTER STATUS)) (FUNCALL-SELF ':STRING-OUT STRING 0 (MIN (STRING-LENGTH STRING) 90.)) (FUNCALL-SELF ':TYO #\CR)))) (COND ((NEQ *HARDCOPY-SUMMARY-P* ':JUST-SUMMARY) (DO ((I 0 (1+ I)) (MSG) (FIRST-P T NIL)) (( I NMSGS)) (COND ((IF FIRST-P *HARDCOPY-SUMMARY-P* *HARDCOPY-SEPARATE-PAGES*) (FUNCALL-SELF ':TYO #\PAGE)) ((AND *HARDCOPY-SEPARATOR-LINE* (NOT FIRST-P)) (FUNCALL-SELF ':LINE-OUT *HARDCOPY-SEPARATOR-LINE*))) (SETQ MSG (AREF ARRAY I)) (HARDCOPY-ONE-MSG MSG SELF I MAIL-FILE)))))) (DEFUN HARDCOPY-ONE-MSG (MSG HARDCOPY-MAIL-FILE INDEX MAIL-FILE &AUX TEM) (FORMAT HARDCOPY-MAIL-FILE "Message #~D" (1+ INDEX)) (AND (NEQ MAIL-FILE (SETQ TEM (MSG-MAIL-FILE MSG))) (FORMAT HARDCOPY-MAIL-FILE " (from ~A)" (MAIL-FILE-NAME TEM))) (COND ((SETQ TEM (MSG-GET MSG 'KEYWORDS-STRING)) (FUNCALL HARDCOPY-MAIL-FILE ':TYO #\SP) (FUNCALL HARDCOPY-MAIL-FILE ':STRING-OUT TEM))) (FUNCALL HARDCOPY-MAIL-FILE ':TYO #\CR) (STREAM-OUT-INTERVAL HARDCOPY-MAIL-FILE (MSG-INTERVAL MSG))) ;;; Hardware specific (DEFFLAVOR HARDCOPY-TO-FILE-MIXIN (*FILE-STREAM*) () (:INCLUDED-FLAVORS HARDCOPY-MAIL-FILE)) (DEFMETHOD (HARDCOPY-TO-FILE-MIXIN :TYO) PASS-MESSAGE-TO-FILE-STREAM) (DEFMETHOD (HARDCOPY-TO-FILE-MIXIN :STRING-OUT) PASS-MESSAGE-TO-FILE-STREAM) (DEFMETHOD (HARDCOPY-TO-FILE-MIXIN :LINE-OUT) PASS-MESSAGE-TO-FILE-STREAM) (DECLARE-FLAVOR-INSTANCE-VARIABLES (HARDCOPY-TO-FILE-MIXIN) (DEFUN PASS-MESSAGE-TO-FILE-STREAM (&REST ARGS) (APPLY *FILE-STREAM* ARGS))) (DEFMETHOD (HARDCOPY-TO-FILE-MIXIN :CLOSE) (&OPTIONAL ABORT-P) (FUNCALL *FILE-STREAM* ':CLOSE ABORT-P)) ;;; TPL (DEFFLAVOR TPL-HARDCOPY-MAIL-FILE () (HARDCOPY-TO-FILE-MIXIN HARDCOPY-MAIL-FILE)) (ADD-HARDCOPY-DEVICE TPL-HARDCOPY-MAIL-FILE :TPL "TPL" NIL) (DEFMETHOD (TPL-HARDCOPY-MAIL-FILE :NAME) () "TPL:") (DEFMETHOD (TPL-HARDCOPY-MAIL-FILE :OPEN) (IGNORE IGNORE) (SETQ *FILE-STREAM* (OPEN "TPL:" '(:OUT)))) ;;; XGP (DEFINE-ZMAIL-HARDCOPY-OPTION *HARDCOPY-XGP-FONT-NAME* "20FG" :STRING "Font") (DEFFLAVOR XGP-HARDCOPY-MAIL-FILE () (HARDCOPY-TO-FILE-MIXIN HARDCOPY-MAIL-FILE)) (ADD-HARDCOPY-DEVICE XGP-HARDCOPY-MAIL-FILE :XGP "XGP" '(*HARDCOPY-XGP-FONT-NAME*)) (DEFMETHOD (XGP-HARDCOPY-MAIL-FILE :NAME) () "the XGP") (DEFMETHOD (XGP-HARDCOPY-MAIL-FILE :OPEN) (IGNORE IGNORE) (SETQ *FILE-STREAM* (OPEN (FS:MAKE-PATHNAME ':HOST "AI" ':DIRECTORY ".XGPR." ':NAME USER-ID ':VERSION ':NEWEST) '(:OUT :SUPER-IMAGE))) (FORMAT *FILE-STREAM* "~%;skip 1~%;squish~%;kset ~A,,~%~|~%" *HARDCOPY-XGP-FONT-NAME*)) (DEFMETHOD (XGP-HARDCOPY-MAIL-FILE :AFTER :CLOSE) (&OPTIONAL ABORT-P) (OR ABORT-P (WITH-OPEN-FILE (STREAM SI:XGP-QUEUE-FILENAME '(:OUT)) (FORMAT STREAM ";status ~A LM ~C ~\DATIME\ ~A ~%;delete~2%~A~%" USER-ID FS:USER-GROUP-AFFILIATION (FUNCALL *FILE-STREAM* ':PATHNAME) (FUNCALL *FILE-STREAM* ':TRUENAME))))) (DEFMETHOD (XGP-HARDCOPY-MAIL-FILE :DRAW-UNDERLINE) () (FUNCALL *FILE-STREAM* ':TYO 177) ;Underscore (FUNCALL *FILE-STREAM* ':TYO 1) (FUNCALL *FILE-STREAM* ':TYO 41) (FUNCALL *FILE-STREAM* ':TYO 0) ;at baseline (LET ((END-X (* 7. PRESS:XGP-DOTS-PER-INCH))) ;7 inches over (FUNCALL *FILE-STREAM* ':TYO (LDB 0707 END-X)) (FUNCALL *FILE-STREAM* ':TYO (LDB 0007 END-X)))) ;;; Press (DEFINE-ZMAIL-HARDCOPY-OPTION *HARDCOPY-NUMBER-OF-COPIES* 1 :NUMBER "Number of copies") (DEFVAR *PRESS-HARDCOPY-OPTIONS* '(*HARDCOPY-NUMBER-OF-COPIES*)) (DEFFLAVOR PRESS-HARDCOPY-MAIL-FILE (*FILE-NAME* *CREATION-DATE*) (HARDCOPY-MAIL-FILE)) (DEFWRAPPER (PRESS-HARDCOPY-MAIL-FILE :ADD-MSG) (IGNORE . BODY) `(PRESS:BIND-PRESS-VARIABLES . ,BODY)) (DEFWRAPPER (PRESS-HARDCOPY-MAIL-FILE :ADD-MAIL-FILE) (IGNORE . BODY) `(PRESS:BIND-PRESS-VARIABLES . ,BODY)) (DEFMETHOD (PRESS-HARDCOPY-MAIL-FILE :TYO) (CHAR) (PRESS:PRESS-CHAR CHAR)) (DEFMETHOD (PRESS-HARDCOPY-MAIL-FILE :STRING-OUT) (STRING &OPTIONAL (START 0) END) (PRESS:PRESS-STRING STRING START END)) (DEFMETHOD (PRESS-HARDCOPY-MAIL-FILE :BEFORE :OPEN) (FILE-NAME CREATION-DATE) (SETQ *FILE-NAME* FILE-NAME *CREATION-DATE* CREATION-DATE)) (DEFMETHOD (PRESS-HARDCOPY-MAIL-FILE :AFTER :OPEN) (IGNORE IGNORE) (PRESS:PRESS-START-PAGE) (MULTIPLE-VALUE-BIND (FAMILY FACE SIZE) (PRESS:DECODE-FONT-NAME (FUNCALL-SELF ':FONT-NAME)) (PRESS:PRESS-SELECT-FONT (PRESS:PRESS-DEFINE-FONT FAMILY FACE SIZE 0)))) (DEFMETHOD (PRESS-HARDCOPY-MAIL-FILE :CLOSE) (&OPTIONAL ABORT-P) (COND ((NOT ABORT-P) (PRESS:PRESS-END-PAGE) (PRESS:PRESS-END-FILE *FILE-NAME* (TIME:PRINT-UNIVERSAL-TIME (OR *CREATION-DATE* (TIME:GET-UNIVERSAL-TIME)) NIL))))) (DEFMETHOD (PRESS-HARDCOPY-MAIL-FILE :DRAW-UNDERLINE) () PRESS:(LET ((OLD-X PRESS-X) (OLD-Y PRESS-Y) (Y PRESS-Y)) (PRESS-LINE 0 Y (- (* 85. 254.) 4000.) Y) (PRESS-SET-CURSOR OLD-X OLD-Y))) (DEFINE-ZMAIL-HARDCOPY-OPTION *HARDCOPY-SPOOL-P* NIL :BOOLEAN "Spool thru MC") (DEFINE-ZMAIL-HARDCOPY-OPTION *HARDCOPY-DOVER-FONT-NAME* "LPT8" :STRING "Font") (ADD-HARDCOPY-DEVICE DOVER-HARDCOPY-MAIL-FILE :DOVER "Dover" `(*HARDCOPY-DOVER-FONT-NAME* ,@*PRESS-HARDCOPY-OPTIONS* *HARDCOPY-SPOOL-P*)) (DEFFLAVOR DOVER-HARDCOPY-MAIL-FILE () (PRESS-HARDCOPY-MAIL-FILE)) (DEFMETHOD (DOVER-HARDCOPY-MAIL-FILE :NAME) () "the Dover") (DEFMETHOD (DOVER-HARDCOPY-MAIL-FILE :OPEN) (IGNORE IGNORE) (PRESS:PRESS-START-FILE (IF *HARDCOPY-SPOOL-P* (FORMAT NIL "MC: .DOVR.; ~A >" USER-ID) PRESS:DOVER-ADDRESS))) (DEFMETHOD (DOVER-HARDCOPY-MAIL-FILE :FONT-NAME) () *HARDCOPY-DOVER-FONT-NAME*) ;;; This comes after all the hardware specific options, so that it gets the right ;;; possibilities. (DEFINE-SITE-ALIST-USER-OPTION (*HARDCOPY-DEVICE* *ZMAIL-HARDCOPY-OPTION-ALIST*) "Output device" *HARDCOPY-DEVICE-MENU-ALIST* :DEFAULT-HARDCOPY-MODE)