LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031625. :SYSTEM-TYPE :LOGICAL :VERSION 8. :TYPE "LISP" :NAME "MESSAGE" :DIRECTORY ("REL3-SOURCE" "MAIL-READER") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758716541. :AUTHOR "REL3" :LENGTH-IN-BYTES 23403. :LENGTH-IN-BLOCKS 23. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                         ;;; -*- Mode:Common-Lisp; Package:ZWEI; Base:10 -*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;                                 MS 2151;;; Copyright (C) 1985,1987 Texas Instruments Incorporated. All rights reserved.;;;;;; Manipulation of message objects;;;(defun ADD-LINE-TO-MESSAGE (new-line msg &optional at-line)  "Make NEW-LINE become part of the text for MSG before AT-LINE (default is last line of message)."  (incf (message-char-count msg) (length new-line))  (incf (message-line-count msg))  (setf (line-node new-line) msg)  (splice-line-into-interval new-line (or at-line (bp-line (interval-last-bp msg)))));;  Also handles potentially-lowercased attributes, though with a speed penalty.;;  Test for the "normal" case first, ie, attributes added by Bandy and thus uppercase.(defun MESSAGE-ATTRIBUTE-P (attribute msg)  (if (eq attribute :undeleted);make life easier since this is used so often      (not (or (memeq :deleted (message-attributes msg))       (member :deleted (message-attributes msg) :test #'string-equal)))      (and (or (memeq attribute (message-attributes msg))       (member attribute (message-attributes msg) :test #'string-equal))   t)))(defun ADD-MESSAGE-ATTRIBUTE (attribute msg)  "Add ATTRIBUTE (a symbol or string) to MSG if not already present.If added, update all summary lines associated with MSG, mark messageand its buffer as modified, and return T.  Otherwise return NIL."  (send msg :add-attribute attribute))(defmethod (message-node :ADD-ATTRIBUTE) (attribute)  (unless (keywordp attribute)    (when (stringp attribute)      (setq attribute (string-upcase attribute)))    (setq attribute (intern attribute *mail-utility-package*)))  (when (not (memeq attribute attributes))    (push attribute attributes)    (unless (memeq attribute '(:print :apply))      (mung-message self))    (dolist (line summary-lines)      (add-summary-attribute attribute line))    t))(defun DELETE-MESSAGE-ATTRIBUTE (attribute msg)  "Delete ATTRIBUTE (a symbol or string from MESSAGE if present.If deleted, update all summary lines associated withMESSAGE, mark message (and its buffer) as modified, andreturn T.  Otherwise return NIL."    (send msg :delete-attribute attribute))(defmethod (message-node :DELETE-ATTRIBUTE) (attribute)  (unless (keywordp attribute)    (when (stringp attribute)      (setq attribute (string-upcase attribute)))    (setq attribute (intern attribute *mail-utility-package*)))    (when (memeq attribute attributes)    (setf attributes (deleq attribute attributes))    (unless (memeq attribute '(:print :apply))      (mung-message self))    (dolist (line summary-lines)      (delete-summary-attribute attribute line))    t))(defun MESSAGE-MARKED-P (msg)  (or (message-attribute-p :deleted msg)      (message-attribute-p :apply msg)      (message-attribute-p :print msg)))(defun DELETE-MESSAGE-MARKS (msg)  (delete-message-attribute :deleted msg)  (delete-message-attribute :apply msg)  (delete-message-attribute :print msg));;  Handles lowercased keywords at a slight speed penalty.;;  Test for the EQ case first, the normal case.(defun MESSAGE-KEYWORD-P (keyword msg)  (and (or (memeq keyword (message-keywords msg))   (member keyword (message-keywords msg) :test #'string-equal))       t))(defun ADD-MESSAGE-KEYWORD (keyword msg)  ;; Ensure the arg is appropriate for eq comparison.  (unless (keywordp keyword)    (when (stringp keyword)      (setq keyword (string-upcase keyword)))    (setq keyword (intern keyword *mail-utility-package*)))  (when (not (memeq keyword (message-keywords msg)))    (send msg :change-keywords (push-end keyword (message-keywords msg)))    t))(defun DELETE-MESSAGE-KEYWORD (keyword msg)  ;; Ensure the arg is appropriate for eq comparison.  (unless (keywordp keyword)    (when (stringp keyword)      (setq keyword (string-upcase keyword)))    (setq keyword (intern keyword *mail-utility-package*)))    (when (memeq keyword (message-keywords msg))    (send msg :change-keywords (deleq keyword (message-keywords msg)))    t))(defun SET-MESSAGE-KEYWORDS (keyword-list msg)  (send msg :change-keywords keyword-list))(defmethod (message-node :CHANGE-KEYWORDS) (keyword-list)    (setq keywords keyword-list)  (setf (message-keywords-string self) (make-message-keyword-string keyword-list))  (when summary-lines     (update-message-summary self))  (mung-message self)  (dolist (keyword keyword-list)    (unless (memeq keyword (get-mail-option (message-file-buffer self) :labels))      (setf (get-mail-option (message-file-buffer self) :labels)    (sort (push keyword (get-mail-option (message-file-buffer self) :labels)) #'string-lessp)))    (unless (memeq keyword *all-mail-keywords*)      (setq *all-mail-keywords* (sort (push keyword *all-mail-keywords*) #'string-lessp))      (setq *mail-keywords-completion-alist*    (sort (push (list (string keyword) keyword) *mail-keywords-completion-alist*) #'string-lessp :key #'car)))))(defun MAKE-MESSAGE-KEYWORD-STRING (list)    (if (null list)      ""      ;; Hopefully this conses less than calling format every time... otherwise it's a waste of code      (let ((string (make-array (* 10 (length list)) :element-type 'string-char :fill-pointer 0)))(string-nconc string "{")(loop for tail on list      do      (string-nconc string (string (car tail)))      (if (cdr tail)  (string-nconc string ", ")  (string-nconc string "}")))string)))(defun UPDATE-MESSAGE-INFO (msg)  "Recalculate various info about MESSAGE (e.g. char count and line count)after modification (e.g. editing or reformatting)."    (setf (message-char-count msg) 0)  (setf (message-line-count msg) 0)  (setf (message-headers-end-bp msg) nil)    (loop    with last-line = (interval-last-bp msg)    for line = (bp-line (interval-first-bp msg)) then (line-next line)    until (or (null line) (eq line last-line))    do    (when (string-equal "Subject" line :end2 7)      (let ((start-index (mail:header-line-body-index line)))(setf (message-name msg) (subseq line start-index    (min (line-length line) (+ start-index *max-message-name-length*))))))    (when (and (null (message-headers-end-bp msg))       (mail:string-blank-p line))      (setf (message-headers-end-bp msg) (create-bp line 0)))    (incf (message-line-count msg))    (incf (message-char-count msg) (length line))    finally    (unless (message-headers-end-bp msg)      (setf (message-headers-end-bp msg) (create-bp last-line 0)))));;;debug(defun print-message-status (msg)  (loop    for h-list in (cdr (message-status msg)) by #'cddr    do    (print h-list) (terpri)    (dolist (h h-list)      (send h :text))))(defun ASSURE-MESSAGE-PARSED (msg &optional full-parse-p)    (let ((parsed (message-parsed-p msg)))    (cond ((and (null full-parse-p) (null parsed))   (parse-message-headers msg nil)   (setf (message-parsed-p msg) t))  ((and full-parse-p (or (null parsed) (eq parsed t)))   (parse-message-headers msg t)   (setf (message-parsed-p msg) :full))))  (message-status msg))(defun PARSE-MESSAGE-HEADERS (msg &optional full-parse-p &rest just-these-headers)  (send msg :parse-headers full-parse-p just-these-headers))  (defmethod (message-node :PARSE-HEADERS) (&optional full-parse-p just-these-headers)    (setq status nil);must start fresh  (do* ((start-line (bp-line first-bp) (line-next end-line))end-line type plist body-start interval)       ((or (null start-line)    (eq start-line (bp-line headers-end-bp))))    (using-resource (string mail-temp-string 100)      (when full-parse-p(string-nconc string start-line))      ;; Peek ahead until the end of this header is found      (do* ((line1 start-line (line-next line1))    (next-line (line-next line1) (line-next line1)))   ((or (null next-line)(mail:string-blank-p next-line)(eq next-line (bp-line headers-end-bp))(mail:header-line-p next-line))    (setq end-line line1))(when full-parse-p  (string-nconc string " " next-line)))            (setq type (mail:header-line-type start-line))      (when (and type (or (null just-these-headers) (memeq type just-these-headers)))(setq body-start (mail:header-line-body-index start-line)      interval (make-interval (create-bp start-line body-start) (create-bp end-line (length end-line)))      plist `(:interval ,interval))(case type  (:date   (multiple-value-bind (utime errorp)        (ignore-errors (time:parse-universal-time start-line body-start nil))     (unless (or errorp (= utime 0))       (setq plist (nconc plist `(:universal-time ,utime)))))))(when full-parse-p  (let ((header (mail:parse-header-string string)))    (setq plist (nconc plist `(:header ,header)))    (when (and (typep header 'mail:address-header)       (send header :address-list))      (setq plist (nconc plist `(:address-list ,(send header :address-list)))))))(let ((assoc-item (assoc type status)))  (if assoc-item      (push-end plist assoc-item)    (push `(,type ,plist) status))))))    status)(defun GET-MESSAGE-HEADER (msg header-type &optional property default)  "Return property list for HEADER-TYPE from MSG.  If the message has multiplelines of header-type, just the first one is returned (see GET-MESSAGE-HEADER-ALL).If PROPERTY is supplied, return just the value of that property or DEFAULT if not found."  (let ((plist (second (assoc header-type (the list (message-status msg)) :test #'eq))))    (if property(getf plist property default)      plist)))(defun GET-MESSAGE-HEADER-ALL (msg header-type)  "Return a list of property lists for all HEADER-TYPE lines in MSG."  (cdr (assoc header-type (the list (message-status msg)) :test #'eq)));;; This is obsolete, but some user filters may reference it(defmethod (message-node :reply-list) ()  "a list of addresses to send a reply to"    (with-open-stream (stream (interval-stream self))        (let ((parsed-header)  (to (copy-list '(:to)))  (resent-to (copy-list '(:resent-to)))  (cc (copy-list '(:cc)))  (resent-cc (copy-list '(:resent-cc)))  (bcc (copy-list '(:bcc)))  (resent-bcc (copy-list '(:resent-bcc)))  (from-list (copy-list '(:from)))  (resent-from (copy-list '(:resent-from)))  (reply-to (copy-list '(:reply-to)))  (resent-reply-to (copy-list '(:resent-reply-to)))  (the-end))            (loop(multiple-value-setq (parsed-header the-end)  (mail:parse-header stream))(select (send parsed-header :type)  (:to    (setf to (nconc to (send parsed-header :address-list))))    (:resent-to    (setf resent-to (nconc resent-to (send parsed-header :address-list))))    (:cc    (setf cc (nconc cc (send parsed-header :address-list))))    (:resent-cc    (setf resent-cc (nconc resent-cc  (send parsed-header :address-list))))    (:from    (setf from-list (nconc from-list (send parsed-header :address-list))))    (:resent-from    (setf resent-from (nconc resent-from (send parsed-header :address-list))))    (:bcc    (setf bcc (nconc bcc (send parsed-header :address-list))))    (:resent-bcc   (setf resent-bcc (nconc resent-bcc (send parsed-header :address-list))))    (:reply-to   (setf reply-to (nconc reply-to (send parsed-header :address-list))))    (:resent-reply-to    (setf resent-reply-to (nconc resent-reply-to (send parsed-header :address-list)))));; Return if end of header is found.(when the-end  (return)))      (list to resent-to cc resent-cc from-list resent-from bcc resent-bcc reply-to resent-reply-to))))(defun MAYBE-REFORMAT-MESSAGE-HEADERS (msg)    (when (and (not (get-mail-option (send msg :superior) :no-reformation))     *reformat-headers-automatically*     (or (null (message-original-headers msg)) (and (not (message-reformatted-p msg))      ;; the following indicates that the user has manually      ;; "deformatted" the header... leave it that way      (null (get msg :saved-reformatted-headers)))))    (send msg :reformat-headers)))(defun REFORMAT-MESSAGE-HEADERS (msg &optional from-original)  (send msg :reformat-headers from-original))(defmethod (message-node :REFORMAT-HEADERS) (&optional from-original)    (with-message-read-only-suppressed (self)    (cond ((and (get self :saved-reformatted-headers)(null from-original))   (delete-interval first-bp headers-end-bp)   (insert-interval first-bp (get self :saved-reformatted-headers)))  (t   (cond ((null original-headers)  (setq original-headers (copy-interval first-bp headers-end-bp))) (from-original  (unless (get self :saved-reformatted-headers)    (setf (get self :saved-reformatted-headers) (copy-interval first-bp headers-end-bp)))  (deformat-message-headers self)))   (let ((keep-list (select-and-order-headers-interval      *reformat-headers-include-list* *reformat-headers-exclude-list*      first-bp headers-end-bp)))     (delete-interval first-bp headers-end-bp)     (mung-message self)     (dolist (header keep-list)       (reformat-one-header header)       (dolist (line header) (splice-line-into-interval line (bp-line headers-end-bp))))     (setq status nil)     (setq parsed-p nil)     (setq reformatted-p t))))))(defun SELECT-AND-ORDER-HEADERS-INTERVAL (include-list exclude-list from-bp &optional to-bp)    (let (keep-alist random-keep)    (get-interval from-bp to-bp t)    (do ((line (bp-line from-bp) (line-next line)) type header)((or (null line) (eq line (bp-line to-bp))))      (when (mail:string-blank-p line)(return));exit loop if blank line encountered      (setq type (mail:header-line-type line))      (cond ((null type);Continuation line     (when header       (push-end line header)))        ((eql (mail:header-line-body-index line) (length line));flush headers with no body     (setq header nil))        (t     (cond ((and exclude-list (memeq type exclude-list));flush members of the exclude list    (setq header nil))   ((and include-list (memeq type include-list));keep members of the include list    (setq header (list line))    ;; push-end retains order of identical fields (i.e. multiple CC fields).    (push-end (list (position type (the list *reformat-headers-include-list*) :test #'eq) header)      keep-alist))   ((or exclude-list (and (null exclude-list) (null include-list)))    ;; exclude-list exists and this header is not on it (or both list are nil) -- keep it    (setq header (list line))    (push-end header random-keep))   (t    ;; exclude list is nil and this header not on include list -- flush it    (setq header nil))))))            (when keep-alist;; Sort headers base on order(setq keep-alist (sort keep-alist #'< :key #'car));; Now turn the alist into a regular list(loop  for item on keep-alist  for header = (cadar item)  do  (setf (car item) header)))      ;; Tack random headers onto the end      (nconc keep-alist random-keep)))  (defun REFORMAT-ONE-HEADER (line-list &optional prefix node)  ;;; Note: the cons cells in line-list are destructively modified, but the  ;;; lines within it are copied.    (let* ((line (car line-list)) (colon-index (position #\: line)) (body-start (mail:header-line-body-index line)) (body-goal-column (+ *reformat-headers-body-goal-column* (length prefix))) new-line)        (cond ((and colon-index body-goal-column (numberp body-start));protect thyself   (setq new-line (create-line (array-type line)       (+ (line-length line) (length prefix))       (or node (line-node line))))   (setf (line-length new-line) 0)   (when prefix     (append-to-line new-line prefix))   (append-to-line new-line line 0 (1+ colon-index) (+ colon-index 2))   (incf colon-index (length prefix))   (case *reformat-headers-case*     (:upcase (nstring-upcase new-line :end colon-index))     (:downcase (nstring-downcase new-line :end colon-index))     (:capitalize (nstring-capitalize new-line :end colon-index)))   (when (> body-goal-column (length new-line))     (append-to-line new-line " " 0 1 (- body-goal-column (length new-line))))   (append-to-line new-line line body-start)   (setf (car line-list) new-line)   (setq body-start (mail:header-line-body-index new-line))      (loop for line-list-tail on (cdr line-list) for line = (car line-list-tail) for old-start = (string-search-not-set mail:*white-space-characters* line) for new-line = (create-line (array-type line)     (+ (line-length line) body-start (length prefix))     (or node (line-node line))) do (setf (line-length new-line) 0) (when prefix   (append-to-line new-line prefix)) (append-to-line new-line " " 0 1 body-start) (append-to-line new-line line (or old-start 0)) (setf (car line-list-tail) new-line))   (loop for function in *reformat-one-header-hook* doing (funcall function new-line line-list body-goal-column)))    ;; this shouldn't happen but if first line appears malformed, just copy everything.  (t   (loop     for line-tail on line-list     do     (setf (car line-tail) (copy-line (car line-tail) (or node (line-node (car line-tail)))))))))  line-list)(defun DEFORMAT-MESSAGE-HEADERS (msg)    (when (typep (message-original-headers msg) 'interval)    (with-message-read-only-suppressed (msg)      (unless (get msg :saved-reformatted-headers)(setf (get msg :saved-reformatted-headers)      (copy-interval (interval-first-bp msg) (message-headers-end-bp msg))))      (delete-interval (interval-first-bp msg) (message-headers-end-bp msg) t)      (insert-interval (interval-first-bp msg) (message-original-headers msg) nil t)      (mung-message msg)      (setf (message-reformatted-p msg) nil)      (setf (message-status msg) nil)      (setf (message-parsed-p msg) nil))))(defun PRINT-FORMATTED-MESSAGE (msg &optional stream prefix-string partial (reformat-p t)(headers-exclude-list *reformat-headers-exclude-list*)(headers-include-list *reformat-headers-include-list*))  "Print MSG on STREAM beginning each line with PREFIX-STRING.  Reformatheaders if REFORMAT-P is non-nil using HEADERS-EXCLUDE-LIST andHEADERS-INCLUDE-LIST.  If PARTIAL is :TEXT, print only the text of themessage; if :HEADERS print only the headers."    (let (out)    (cond ((eq stream t) (setq out *standard-output*))  ((null stream) (setq out (make-string-output-stream     (make-array (or (message-char-count msg) 1000) :element-type 'string-char :fill-pointer 0))))  (t (setq out stream)))    (fresh-line out)    (let ((start-bp (copy-bp (interval-first-bp msg)))  (stop-bp (copy-bp (interval-last-bp msg))))      (unless (eq partial :text)(cond (reformat-p       (let ((keep-list (select-and-order-headers-interval  headers-include-list headers-exclude-list  (interval-first-bp msg) (message-headers-end-bp msg)))) (dolist (header keep-list)   (reformat-one-header header prefix-string)   (dolist (line header)     (write-line line out)))))      ((message-original-headers msg)       ;;? Using copy-interval gets around some bug in interval streams which trashes the interval       (stream-out-interval out (copy-interval (message-original-headers msg))))      (t       (stream-out-interval out start-bp (message-headers-end-bp msg))))(move-bp start-bp (message-headers-end-bp msg)))      (when (eq partial :text)(move-bp start-bp (message-headers-end-bp msg)))      (unless (eq partial :headers);; Find last non blank line(loop  for line = (bp-line stop-bp) then (line-previous line)  until (or (null line) (eq line (bp-line start-bp)))  do (if (mail:string-blank-p line)       (move-bp stop-bp line 0)       (return)))(loop  with last-line = (bp-line stop-bp)  for line = (bp-line start-bp) then (line-next line)  until (or (null line) (eq line last-line))  do (format out "~@[~A~]~A~%" prefix-string line))))    (unless stream      (get-output-stream-string out))))(defun COPY-MESSAGE-OBJECT (msg)  (send msg :copy-self))(defmethod (message-node :COPY-SELF) ()  (let ((new-msg (make-instance 'message-node:name (copy-seq name):original-headers (and original-headers (copy-interval original-headers)):keywords (copy-list keywords):attributes (copy-list attributes):reformatted-p reformatted-p)))    (with-read-only-suppressed (new-msg)      (insert-interval (interval-last-bp new-msg) self))    (update-message-info new-msg)    new-msg))(defun COPY-MESSAGE-INIT (pathname)  "Call before copying a message to another file.  If PATHNAME isalready in memory as a mail buffer, return the buffer object.  Otherwisereturn 2 values, an open output stream to PATHNAME ready for appendingmessages to and the mail file format to use.  If the file must becreated, behavior depends on *default-new-mail-file-format*.  Since anopen stream may be returned, caller must provide the unwind-protectnecessary to ensure it is closed."  (unless (pathnamep pathname)    (setq pathname (parse-namestring pathname)))    (or (find-mail-buffer pathname)      (prepare-mail-file-for-append pathname)))(defun MUNG-MESSAGE (msg)  "Mark MSG and its owner buffer as modifed."  (setf (node-tick msg) *tick*)  (setf (node-tick (message-file-buffer msg)) *tick*)  (dolist (line (message-summary-lines msg))    (when (typep (line-node line) 'zmacs-buffer)      (must-redisplay-buffer (line-node line) dis-line line 0))))(defun COLLECT-MESSAGE-ADDRESSES (msg header-types &optional just-one-p not-these-addresses)  "Return a list of addresses in MSG found in HEADER-TYPES.  If JUST-ONE-P, return only addressesfound in one of the HEADER-TYPES. In this case the HEADER-TYPES should be passed with thepreferred headers first.  Do not return any addresses that match those in NOT-THESE-ADDRESSES."  (assure-message-parsed msg t)  (loop    with collection    for type in header-types    for header-list = (get-message-header-all msg type)    when header-list    do    (loop      for header in header-list      for header-obj = (getf header :header)      for address-list = (and header-obj (send header-obj :address-list))      when address-list      do      (dolist (address address-list)(when (and (not (member address collection :test #'mail-address-match))   (not (member address not-these-addresses :test #'mail-address-match)))  (push-end address collection))))    (when (and just-one-p collection)      (return collection))    finally    (return collection)))(defun MAIL-ADDRESS-MATCH (addr1 addr2)   (unless (typep addr1 'mail:address)     (setq addr1 (mail:parse-address addr1)))   (unless (typep addr2 'mail:address)     (setq addr2 (mail:parse-address addr2)))   (mail:address-equal addr1 addr2)  ;; need to handle strings with "*" as wildcard  )-menu "Before"    :string-for-filter-summary "MESSAGES BEFORE DATE"    :filter-summary-default-p t)  "Select message dated before a certain