;;;-*- Mode:Common-Lisp; Package:MAIL; Base:10; Patch-File:T -*-

;;; **********************************************************************
;;; Copyright (c) 1990 Stanford University.
;;; This code was written by James Rice.
;;; Copyright is held by Stanford University except where code has been
;;; modified from TI source code.  In these cases TI code is marked with
;;; a suitable comment.

;;; All Stanford Copyright code is in the public domain.  This code may be
;;; distributed and used without restriction as long as this copyright
;;; notice is included and no fee is charged.  This can be thought of as
;;; being equivalent to the Free Software Foundation's Copyleft policy.

;;; TI source code may only be distributed to users who hold valid TI
;;; software licenses.

;;; The development of this software was assisted by the following grants:
;;; Biomedical Research Technology Program of the National Institutes
;;; of Health under grant RR-00785
;;; Information Systems Technologies office of the Defense Advanced
;;; Research Projects Agency under contract N00039-86-C0033.

;;; **********************************************************************

(defvar *canonicalize-header-addresses* t
  "If non-NIL then expand host names in headers of messages being sent to their primary name.")

;;; TI code.
;;;RDA: Change to canonicalize addresses
(defun SUBMIT-MAIL (msg-stream &key to subject other-headers (background (not *try-mail-now-p*)))
  "Send a mail message -- intended for use by interactive programs rather than servers.
Read message from MSG-STREAM, collect recipients from the header, and attempt to send.
Necessary fields such as From:, Date:, and Message-ID: are generated automatically
MSG-STREAM may be a stream or a string.
BACKGROUND means don't send message now; just queue it for background delivery.
TO may be a list of recipients (strings or address objects). In this case, MSG-STREAM is
  assumed to contain only text and is not scanned for headers.  Proper headers will be
  generated automatically.
SUBJECT is a string to use for the subject field when TO is supplied.
OTHER-HEADERS is a list of strings containing other headers to insert when TO is supplied.

Returns nil if delivery was aborted, a list of addresses unsent due to errors, a list
addresses unsent but queued, a list of all addresses to which delivery was attempted, and
a list of the final headers."
  
  (fs:force-user-to-login)
  (let* ((message (allocate-message :date-received (get-universal-time) :tick-received (time)))
	 header-list address-list fcc-list
	 line eof bad-header-line
	 from date message-id resent-p from-address problems)
    
    
    (when (stringp msg-stream)
      (setq msg-stream (make-string-input-stream msg-stream)))
    (cond (to
	   ;; Process supplied address list, generating headers
	   (dolist (address to)
	     (setq address-list (nconc address-list (parse-all-addresses address))))
	   (when subject
	     (push (make-instance 'basic-header :type :subject :body (string subject))
		   header-list))
	   (push (make-instance 'address-header :type :to :address-list address-list)
		 header-list)
	   (setq address-list nil)
	   (loop
	     for string in other-headers
	     for header = (parse-header string nil nil *canonicalize-header-addresses*)	;RDA
	     when (not (bad-header-p header))
	     do (push header header-list)
	     when (member (send header :type)
			  '(:resent-from :resent-to :resent-cc :resent-bcc :resent-date :resent-message-id))
	     do (setq resent-p t)))
	  (t
	   ;;Extract headers and destination addresses from stream
	   (loop with (header headers-end)
		 until (or headers-end eof)
		 do
		 (multiple-value-setq (line eof) (send msg-stream :line-in))
		 until (or (and eof (= (length line) 0))
			   (string-blank-p line))
		 do
		 (unless (header-line-p line)
		   (setq bad-header-line line)
		   (return))
		 (multiple-value-setq (header headers-end)
		   (parse-header msg-stream line nil *canonicalize-header-addresses*))	;RDA
		 (when (bad-header-p header)
		   (setq bad-header-line (send header :string-for-message))
		   (return))
		 (push header header-list)
		 ;; Determine if this is a resent message
		 (when (member (send header :type)
			       '(:resent-from :resent-to :resent-cc :resent-bcc :resent-date :resent-message-id))
		   (setq resent-p t))
		 finally
		 (setq header-list (nreverse header-list)))))
    ;; Collect addresses; add date, from, and message-id
    (loop
      for header in header-list
      for type = (send header :type)
      do				
      (cond ((eq type :fcc)
	     (push-end (send header :body) fcc-list))
	    ((not resent-p)
	     (case type
	       (:from (setq from header))
	       (:date (setq date header))
	       (:message-id (setq message-id header))
	       ((:to :cc :bcc)
		;; Rats - Must copy the address-list so header is still printable for later
		(setq address-list (nconc address-list (copy-list (send header :address-list)))))))
	    (t
	     (case type
	       (:resent-from (setq from header))
	       (:resent-date (setq date header))
	       (:resent-message-id (setq message-id header))
	       ((:resent-to :resent-cc :resent-bcc)
		;; Rats - Must copy the address-list so header is still printable for later
		(setq address-list (nconc address-list (copy-list (send header :address-list)))))))))
    ;; Supply required headers
    (unless from
      (setq from (make-instance 'address-header
				:type (if resent-p :resent-from :from)
				:address-list (list (default-from-address))))
      (push from header-list))
    (setq from-address (first (send from :send-if-handles :address-list)))
    (unless date
      (push (make-instance 'basic-header
			   :type (if resent-p :resent-date :date)
			   :body (rfc822-date-string (send message :date-received)))
	    header-list))
    (when (or (not (address-p from-address))
	      (not (address-equal from-address (default-sender-address))))
      (push (make-instance 'address-header
			   :type (if resent-p :resent-sender :sender)
			   :address-list (list (default-sender-address)))
	    header-list))
    (unless message-id
      (setq message-id (send message :message-id-string nil nil))
      (setq message-id (make-instance 'basic-header
				      :type (if resent-p :resent-message-id :message-id)
				      :body message-id))
      (push message-id header-list))
    ;; Store all headers into the message
    (loop for header in header-list
	  for type = (send header :type)
	  ;; drop headers with empty body or not supposed to send
	  unless (or (send header :empty-body-p)
		     (member type (the list *headers-not-copied-to-final-message*)))
	  do (send message :append-line (send header :string-for-message)))
    (send message :append-line "")		;blank line to delimit headers
    
    (when bad-header-line
      (setq problems t)
      (format t "~&Bad header line; end of headers assumed:  ~S" bad-header-line)
      (send message :append-line bad-header-line))

    (cond ((not (address-p from-address))
	   (setq problems t)
	   (format t "~&There is a problem with your From: field."))
	  ((not (send from-address :verify))
	   (setq problems t)
	   (format t "~&~16A -- Cannot verify your From: field -- ~A"
		   from-address (send from-address :verification-report-string))))

    ;; Process addresses
    (when (null address-list)
      (format t "~2%No recipient addresses;  message not sent.")
      (deallocate-message message)
      (return-from submit-mail))
    (dolist (address address-list)
      (if (not (group-address-p address))
	  (send message :add-recipient address)
	(dolist (address (send address :address-list))
	  (send message :add-recipient address))))
    
    (send message :set-return-path (default-return-path-address))
    ;; Get the message text
    (loop do
	  (multiple-value-setq (line eof) (send msg-stream :line-in))
	  when (or (not eof) (not (zerop (length line))))
	  do
	  (send message :append-line line)
	  until eof)
    (unless (or (not problems)
		(let ((*query-io* *standard-output*))
		  (y-or-n-p "~&~%Send message anyway?")))
      (deallocate-message message)
      (return-from submit-mail))
    (let ((sent (send message :deliver background)))
      (cond ((not sent)
	     (deallocate-message message)
	     nil)
	    (t
	     (let ((queued (send message :address-list))
		   (original (send message :original-address-list))
		   bad)
	       ;; Need a better way to determine the following -- like instance vars on the message.
	       (dolist (address (send message :disposed-address-list))
		 (when (member (send address :delivery-status) '(:rejected :verify-error))
		   (push address bad)))
	       (when (send message :delivery-complete-p)
		 (deallocate-message message))
	       (values t
		       bad
		       queued
		       original
		       header-list)))))))

(defvar *forward-unknown-addresses* t
  "If non-NIL then forward messages being sent with unkown addresses to
   a primary mail server unless this machine is a mail server or
   USE-PRIMARY-MAIL-SERVER is :NEVER")

;;; RDA: Almost always forward unknown addresses to a server.
(defmethod (MESSAGE :TRANSLATE-ADDRESSES) (&key expand forward strip-local verify canonical)
  
  (unless expanded-p
    (setq expanded-p t)
    (let ((all-ok t)
	  translation expansion mailing-lists)
      (declare (list expansion mailing-lists))
      (when expand 
	(dolist (address address-list)
	  (setq translation (send address :expand-mailing-list))
	  (when (consp translation)
	    (push address mailing-lists)
	    (setq expansion (nconc translation expansion))))
	;; Note that mailing lists come last (which the following loop is dependent on)
	(setq address-list (nconc address-list expansion)))
      (loop 
	with address-that-expanded
	for address-tail on address-list
	for address = (first address-tail)
	do
	(cond ((member address mailing-lists :test #'eq)
	       ;; This address was a mailing list; delete original and check its members
	       (setq address-that-expanded address)
	       (send self :dispose-address address :expanded))
	      (t
		(setq translation (send address :translate
					:forward forward :strip-local strip-local :canonical canonical))
		(when (neq address translation)
		  ;; Replace address with its expansion
		  (setf (first address-tail) translation)
		  (setq address translation))
		;Verify if told to, but assume that mailing list members always need verification
		(cond ((or (and (not verify)
				(not address-that-expanded))
			   (send address :verify))
		       ;; address is ok, leave on list
		       )
		      (t
			;; Verify failed, if interactive maybe forward to server (unless this machine *is* a server)
			 (if (and *interactive-delivery-in-progress*
				 (or (neq (use-primary-mail-servers) :never)))	;RDA
			    ;; Keep address, make note of forwarding
			    (send address :set-delivery-status :forward-unknown)
			  ;; Drop address, make note if address was a mailing list member.
			  (setq all-ok nil)
			  (if address-that-expanded
			      (send self :dispose-address address :expansion-error address-that-expanded
				    (send address :verification-report-string))
			    (send self :dispose-address address :verify-error nil
				  (send address :verification-report-string)))))))))
      all-ok)))


zwei:
(defcom zwei:COM-SEND-MAIL
	"Send mail and exit mail mode."
	()
  (declare (special yw-zwei:*silent-mail-delivery*))
  (let (subject)
    (multiple-value-bind (sent error-list queued-list all-addresses header-list)
	(mail:submit-mail (zwei:interval-stream
			    (interval-first-bp *interval*)
			    (interval-last-bp *interval*)
			    nil t ;;; JPR.  Allow fonts to allow diagram
			          ;;; lines and such.
			  )
	)
      (when sent
	(loop
	  with fcc-paths
	  for header in header-list
	  do
	  (case (send header :type)
	    (:fcc
	     (push-end (send header :body) fcc-paths))
	    (:subject
	     (setq subject (send header :body))))
	  finally
	  (when fcc-paths
	    ;; Constuct a message object from the template and insert the actual headers used while sending
	    (let ((msg (read-message (interval-stream *interval*))))
	      (with-message-read-only-suppressed (msg)
		(delete-interval (interval-first-bp msg) (message-headers-end-bp msg))
		(dolist (header header-list)
		  (insert-moving (message-headers-end-bp msg) (send header :string-for-message))
		  (insert-moving (message-headers-end-bp msg) #\Newline)))
	      (dolist (path fcc-paths)
		(fcc-message-to-mail-file msg path)))))
	
	;; Append subject to name of template buffer
	(when (and subject (not (zerop (length subject))))
	  (let ((name (buffer-name *interval*)))
	    (when (and (char= #\* (char name 0))
		       (char= #\* (char name (1- (length name)))))
	      (send *interval* :rename (format nil "~A  ~S" name subject)))))
	
	;; Save status of delivery
	(push-end (list all-addresses error-list queued-list)  (get *interval* :mail-delivery-status))
	
	(let* ((template-type (get *interval* :mail-template-type))
	       (template *interval*)
	       (mail-buffer (get *interval* :buffer-of-mail-command))
	       (msg (or (get template :message-object-list) (get template :message-object))))
	  ;; If :mail-template-type is :reply, set the answered attribute of the message(es)
	  (when (eq template-type :reply)
	    (cond ((consp msg)
		   (dolist (m msg)
		     (add-message-attribute :answered m)))
		  (t
		   (add-message-attribute :answered msg))))
	  ;;; Fix put in here by JPR
	  (if (and (boundp 'yw-zwei:*silent-mail-delivery*)
		   yw-zwei:*silent-mail-delivery*
	      )
	      (if (equal yw-zwei:*silent-mail-delivery* :minibuffer)
		  (format *query-io* "~%Done.")
		  nil
	      )
	      (format t "~2%Done.")
	  )
	  (check-for-typeout-window-typeout t)
	  (send *window* :prepare-for-redisplay)
	  (when (null error-list)
	    (not-modified *interval*)
	    (if (or (null mail-buffer)
		    (get mail-buffer :killed))
		;; Not invoked from a mail buffer, just select previous buffer
		;; SPR#5421:  ensure that there is some other buffer to select   \/\/
		(when (previous-buffer *interval*)
		  (send (previous-buffer *interval*) :select))
	      ;; Reselect the mail buffer, the message, and bury this template
	      (make-mail-buffer-current mail-buffer
					(get template :saved-window-configuration)
					nil)
	      (when (messagep msg)
		(select-message msg mail-buffer)
		(delete-message-attribute :unseen msg)))
	    (hide-mail-buffer template)
	    (format *query-io* "~&Press ~A to reselect the mail template buffer."
		    (key-for-command 'com-list-mail-buffers *zmacs-comtab* nil nil #\C-X))
	    ;; If invoked from another window, return to it.
	    (let ((window (get template :return-to-window-after-send)))
	      (when (and window (send window :active-p))
		(send window :select))))
	  (push template *sent-message-list*)
	  (setq *unsent-message-list* (deleq template *unsent-message-list*))))))
  dis-text)



;-------------------------------------------------------------------------------

;;; Diagram line things.


zwei:
(DEFMETHOD (zwei:INTERVAL-STREAM-WITH-FONTS :WRITE-CHAR) (CH)
  (LET-IF NO-UNDO-SAVING ((*BATCH-UNDO-SAVE* T))
     (COND ((EQ *FONT-FLAG* T)
	    ;; Character after a ^F.
	    (SETQ *FONT-FLAG* NIL)
	    (COND ((CHAR= CH #\)
		   (LET ((BP (INSERT (CREATE-BP *LINE* *INDEX*)
				     (IN-CURRENT-FONT CH **FONT**))))
		     (SETQ *LINE* (BP-LINE BP)
			   *INDEX* (BP-INDEX BP))))
		  ((CHAR= CH #\#)
		   (SETQ *FONT-FLAG* 'DIAG-1))
		  ((CHAR= CH #\*)
		   (OR (ZEROP (ARRAY-LEADER *FONT-STACK* 0))
		       (SETQ **FONT** (VECTOR-POP *FONT-STACK*))))
		  (T
		   (INTERVAL-WITH-FONTS-IO-PUSH-FONT)
		   (SETQ **FONT** (- (CHAR-CODE CH) (CHAR-CODE #\0))))))
	   ((NULL *FONT-FLAG*)
	    ;; Character in normal text state.
	    (COND ((CHAR= CH #\)
		   (SETQ *FONT-FLAG* T))
		  (T
		   (LET ((BP (INSERT (CREATE-BP *LINE* *INDEX*)
				     (IN-CURRENT-FONT CH **FONT**))))
		     (SETQ *LINE* (BP-LINE BP)
			   *INDEX* (BP-INDEX BP))))))
	   ((EQ *FONT-FLAG* 'DIAG-1)
	    ;; Character after a ^F#
	    (SETQ *FONT-FLAG* 'DIAG-2
		  *STOP-INDEX* 0))
	   ((EQ *FONT-FLAG* 'DIAG-2)
	    (IF (CHAR= CH #\SPACE)
		(SETQ *FONT-FLAG* (MAKE-ARRAY 12 :ELEMENT-TYPE 'STRING-CHAR :LEADER-LIST '(0)))
		(SETQ *STOP-INDEX* (+ (* *STOP-INDEX* 12)
				      (- (CHAR-CODE CH) (CHAR-CODE #\0))))))
	   ((STRINGP *FONT-FLAG*)
	    (IF (CHAR= CH #\NEWLINE)
		(SETQ *INDEX* NIL
		      *FONT-FLAG* (MAKE-INSTANCE (READ-FROM-STRING *FONT-FLAG* T)
						 :NUMBER-OF-LINES *STOP-INDEX*))
		(VECTOR-PUSH-EXTEND CH *FONT-FLAG*)))
	   ((TYPEP *FONT-FLAG* 'RESTORABLE-LINE-DIAGRAM-MIXIN)
	    (BLOCK NIL
	      (OR *INDEX*
		       (COND ((< (SETQ *STOP-INDEX* (1- *STOP-INDEX*))
				 0)
			      (SETQ *INDEX* 0
				    *FONT-FLAG* (CHAR= CH #\))
			      (RETURN (VALUES)))
			     (T
			      (SETQ *INDEX* (CREATE-LINE 'ART-STRING 0 NIL))
			      (INSERT-LINE-WITH-LEADER *INDEX* *LINE*))))
	      (COND ((CHAR= CH #\NEWLINE)
		     ;;; JPR.  Note: some mail systems will insert random
		     ;;; newlines in diagram lines if they get long, which
		     ;;; they do.  If you can't read the form from the string
		     ;;; then the newline we just found must be a bogus one.
		     ;;; We ignore it here so the chars get copied into *index*
		     ;;; on top of where the newline would have been.
		     (if (catch-error (read-from-string *index* nil nil) nil)
			 (progn (SETF (GETF (LINE-PLIST *INDEX*) :DIAGRAM)
				      *FONT-FLAG*)
				(SEND *FONT-FLAG* :ADD-LINE *INDEX* *INDEX*)
				(SETF (LINE-LENGTH *INDEX*) 0)
				(SETQ *INDEX* NIL)
			 )
			 nil ;;; ignore this char, since it breaks things.
		     )
		    )
		    (T
		     (VECTOR-PUSH-EXTEND CH *INDEX*)))
	      NIL))
	   (T
	    (FERROR NIL "*FONT-FLAG* has a value not understood here")))))


zwei:
(DEFMETHOD (zwei:image-display-list-mixin :TEXT) (wind args)
  ;; ( Font X Y String )
  ;;; JPR.  Fix this so we make sure that we print out a string.  If things
  ;;; get confused then we want to know.  This will happen in general unless
  ;;; a fix is made to (zwei:DOX-DIAGRAM :CONTENTS).
  (SEND wind :string-out-explicit (string (fourth args));String ;;;JPR make sure
        (SECOND args) (THIRD args)         ;x,y
        nil nil
        (INTERN (FIRST args) 'fonts)       ;Font
        w:alu-ior))


zwei:
(defun zwei:princ-except-strings (thing)
"Princs something to *standard-output* unless it's a string, and then it
Prin1s it.  This is because diagram line :text types need to make sure that they
quotify the strings they are printing out.
"
  (if (consp thing)
      (progn (format t "(")
	     (loop for x in thing do (princ-except-strings x) (princ " "))
	     (format t ")")
      )
      (if (stringp thing)
	  (format t "~S" thing)
	  (format t "~A" thing)
      )
  )
)

zwei:
(DEFMETHOD (zwei:DOX-DIAGRAM :CONTENTS) (LINE)
  (COND ((SEND SELF :FIRST-LINE-P LINE)
	 ;;; JPR.  Fix here to make sure that strings are quotified properly.
	 (with-output-to-string (*standard-output*)
	   (let ((*print-pretty* nil))
	        (princ-except-strings (SEND self :DISPLAY-LIST)))))
	(T "")))


;-------------------------------------------------------------------------------

;;; TI Code.  Copied from Buffer.Lisp
yw-zwei:
(defcom zwei:COM-LIST-MAIL-BUFFERS
	"Print an organized list of all mail buffers."
	()
  (let* ((max-size (min *c-x-c-m-buffer-name-column-width*
			(max 16 (- (funcall *standard-output*
					    :size-in-characters) 48))))
	 (column2 (min (max (+ (find-maximum-buffer-name-length max-size) 3)
			    *c-x-c-m-minimum-buffer-name-column-width*)
		       (+ max-size 2)))
	 modified-flag new-flag trunc-flag)
    (format t
	    "~&Mail Buffers:~vTFile Version:~vTLength:~vTMajor Mode:~2%"
	    column2 (+ column2 16) (+ column2 32))
    ;;; JPR added these two lines.  These functions side effect the message
    ;;; lists and calling them now should make sure that we've done the
    ;;; clean-up before anything gets displayed.
    (Unsent-Messages)
    (Sent-Messages)

    (dolist (buffer (history-list (send *window* :buffer-history)))
      (when (mail-file-buffer-p buffer)
	(let ((file-id (buffer-file-id buffer)))
	  (write-char (cond ((eq file-id t)
			     (setq new-flag t) #\+)
			    ;+ means new file, never written out
			    ((buffer-modified-p buffer)
			     (setq modified-flag t) #\*)
			    ;* means has unsaved changes.
			    (t #\Space))		;blank if unmodified.
	       *standard-output*)
	  (write-char #\Space *standard-output*)
	  (multiple-value-bind (name flag)
	      (name-for-display buffer max-size)
	    (when flag (setq trunc-flag t))
	    (let ((major-mode (buffer-major-mode buffer)))
	      (send *standard-output* :item 'zwei:mail-buffer buffer
		    "~A~vT~@[~A~]~vT~D Message~:P~vT(~A)"
		    name
		    column2 (buffer-version-string buffer)
		    (+ column2 16) (total-messages buffer)
		    (+ column2 32) (symbol-value major-mode)))))
	(terpri *standard-output*)
	(dolist (seq (buffer-subsequences buffer))
	  (multiple-value-bind (name flag)
	      (name-for-display seq (- max-size 2))
	    (when flag (setq trunc-flag t))
	    (send *standard-output* :item 'zwei:mail-buffer seq
		  "    ~A~vT~D Message~:P"
		  name
		  (+ column2 16) (total-messages seq))
	    (terpri *standard-output*)))))
    (let ((first t))
      (dolist (buffer (unsent-messages))
	(when first
	  (format t "~&~%Unsent Mail Templates:~%~%")
	  (setq first nil))
	(write-char (if (buffer-modified-p buffer) #\* #\Space)
		    *standard-output*)
	(write-char #\Space *standard-output*)
	(multiple-value-bind (name flag)
	    (name-for-display buffer max-size)
	  (when flag (setq trunc-flag t))
	  (send *standard-output* :item 'zwei:mail-buffer buffer
		"~A~vT~D Line~:P"
		name
		(+ column2 16) (count-lines-buffer buffer)))
	(terpri *standard-output*)))
    ;;; The following form added by JPR.
    (let ((first t))
      (dolist (buffer (yw-read-messages))
	(when first
	  (format t "~&~%YW Read Templates:~%~%")
	  (setq first nil))
	(write-char (if (buffer-modified-p buffer) #\* #\Space)
		    *standard-output*)
	(write-char #\Space *standard-output*)
	(multiple-value-bind (name flag)
	    (name-for-display buffer max-size)
	  (when flag (setq trunc-flag t))
	  (send *standard-output* :item 'zwei:mail-buffer buffer
		"~A~vT~D Line~:P"
		name
		(+ column2 16) (count-lines-buffer buffer)))
	(terpri *standard-output*)))
    (let ((first t))
      (dolist (buffer (sent-messages))
	(when first
	  (format t "~&~%Sent Mail Templates:~%~%")
	  (setq first nil))
	(write-char (if (buffer-modified-p buffer) #\* #\Space)
		    *standard-output*)
	(write-char #\Space *standard-output*)
	(multiple-value-bind (name flag)
	    (name-for-display buffer max-size)
	  (when flag (setq trunc-flag t))
	  (send *standard-output* :item 'zwei:mail-buffer buffer
		"~A~vT~D Line~:P"
		name
		(+ column2 16) (count-lines-buffer buffer)))
	(terpri *standard-output*)))
    
    (terpri *standard-output*)	;extra TERPRI to show you that it's finished.
    (when new-flag (princ "+ means new file.  " *standard-output*))
    (when modified-flag (princ "* means buffer modified.  " *standard-output*))
    (when trunc-flag (princ " means name truncated." *standard-output*))
    (when (or new-flag modified-flag trunc-flag) (terpri *standard-output*))
    dis-none))


;;; TI code copied from Mail-daemon;
mail:
(defun mail:parse-header-string (string &optional errorp canonicalize-addresses)
  (let ((type (header-line-type string)))
    (cond ((null type)
	   (make-instance 'basic-header
			  :type :bad-header
			  :body (copy-seq string)))
	  ((member type (the list *address-header-types*) :test #'eq)
	   ;;; Let added by JPR.
	   (let ((yw:*save-addresses-in-database-p*
		  (member
		   type yw:*header-field-keys-to-parse-for-address-database*)))
	   (let ((address-list
		   (parse-all-addresses
		     string (header-line-body-index string) nil errorp
		     (if (member type (the list *mailbox-header-types*)
				 :test #'eq)
			 :mailbox
			 :address))))
	     (when canonicalize-addresses
	       (setq address-list
		     (loop
		       for addr in address-list
		       collect (send addr :canonical-address))))
	     
	     (make-instance 'address-header
			    :type type
			    :address-list address-list))))
	  (t
	   (make-instance 'basic-header
			  :type type
			  :body (header-line-body-string string))))))


yw-zwei:
(defun mail:get-basic-address (local-part domain &optional comments)
  (let ((name (ucl:first-if-list local-part)))
       (if (not domain)
	   (let ((address (map-to-alias name)))
	        (if address
		    (let ((result (My-Parse-All-Addresses address)))
			 (if (consp address)
			     (mail:get-group-address
			       name (remove-duplicates (flatten result))
			     )
			     (if (consp result)
				 (first result)
				 (get-basic-address-1
				   local-part domain comments
				 )
			     )
			 )
		    )
		    (get-basic-address-1 local-part domain comments)
		)
	   )
	   (get-basic-address-1 local-part domain comments)
       )
  )
)

yw-zwei:
(defun mail:get-address-object (&rest address-descriptor)
  (declare (arglist flavor-type &rest init-plist))
  (declare (special yw:*owning-cache-entry* yw:*owning-mailstream*))
  (let ((created-p nil))
       (let ((address
	       (or (gethash address-descriptor mail:*address-hash-table*)
		   (let ((new
			   (setf (gethash (copy-tree address-descriptor)
					  mail:*address-hash-table*)
				 (apply #'make-instance (car address-descriptor)
					(cdr address-descriptor)))))
		        (setq created-p t)
			new
		   )
	       )
	      )
	    )
	    (if yw:*save-addresses-in-database-p*
		(let ((upcased (yw-zwei:Maybe-Upcase address-descriptor)))
		     (let ((comment-location (member :Comments upcased)))
		          (if comment-location
			      ;; store in D/B without comments.  This is
			      ;; because IMAP doesn't give us comments.  We
			      ;; want to be able to supersede an addres created
			      ;; as the result of an IMAP envelope by one
			      ;; parsed by Mail:.
			      (setf (second comment-location) nil)
			      nil
			  )
		     )
		     (yw-get-address-object-internal-for-comments
		       address address-descriptor upcased
		     )
		)
		nil
	     )
	     (values address created-p)
       )
  )
)

(defun yw-zwei:yw-get-address-object-internal-for-comments
       (address address-descriptor upcased)
  (declare (special yw:*owning-cache-entry* yw:*owning-mailstream*
		    yw:*fixing-up-bogus-address*
	   )
  )
  (if (and (boundp 'yw:*fixing-up-bogus-address*)
	   (boundp 'yw:*owning-cache-entry*)
      )
      (yw:Flush-Display-Cache-For
	(yw:cache-msg# yw:*owning-cache-entry*)
	yw:*owning-mailstream* t
      )
      nil
  )
  (let ((db-value
	  (gethash upcased yw:*address-database*)
	)
       )
       (cond ((or (not db-value)
		  (boundp 'yw:*force-into-address-database*)
	      )
	      (setq yw:*address-database-changed* t)
	      (remhash address-descriptor
		       yw:*address-database*
	      )
	      (remhash upcased
		       yw:*address-database*
	      )
	      (setf (gethash upcased yw:*address-database*)
		    address
	      )
	     )
	     ((and (send address :Comments)
		   ;; allow supersede of non-comment
		   ;; addresses.
		   (not (send db-value :Comments))
	      )
	      (setq yw:*address-database-changed* t)
	      (setf (gethash upcased yw:*address-database*)
		    address
	      )
	      (if (and yw:*use-comments-as-names-in-non-named-addresses*
		       (boundp 'yw:*owning-cache-entry*)
		  )
		  ;; we know which message it came from.
		  (yw:Flush-Display-Cache-For
		    (yw:cache-msg# yw:*owning-cache-entry*)
		    yw:*owning-mailstream* t
		  )
		  nil
	      )
	     )
	     (t nil)
       )
  )
)

(yw:defadvise mail:get-named-address (:Check-For-Timed-Addresses)
	   (name route local-part domain &optional comments)
  (if (or (not yw:*remove-dates-as-message-names-p*)
	  (not (imap:safe-parse-date name 0))
      )
      :Do-It
      (let ((yw:*fixing-up-bogus-address* t))
	   (declare (special yw:*fixing-up-bogus-address*))
	   (if route
	       (mail:get-route-address route local-part domain comments)
	       (mail:get-basic-address local-part domain comments)
	   )
      )
  )
)

;-------------------------------------------------------------------------------

(defun sys:function-parent (function-spec &aux def tem)
    "Returns NIL or the name of another definition which has the same source code.
The second value is the type of that definition (which can be NIL).
This is used for things like internal functions, methods automatically
created by a defflavor, and macros automatically created by a defstruct."
  (declare (values name type))
  (cond ((and (fdefinedp function-spec)
	      (setq tem (sys:get-debug-info-field
			  (sys:get-debug-info-struct 
			    (setq def (fdefinition function-spec)))
			  :function-parent))
	      ;; Don't get confused by circular function-parent pointers.
	      (not (equal tem function-spec)))
	 (values (car tem) (cadr tem)))
	((and (consp def) (eq (car def) 'sys:macro) (symbolp (cdr def))	;for DEFSTRUCT
	      (setq def (get (cdr def) 'sys:macroexpander-function-parent)))
	 (funcall def function-spec))
	((consp function-spec)
	 (funcall (get (car function-spec) 'sys:function-spec-handler)
		  'sys:function-parent function-spec))
	;;; Added by JPR to allow function parents for things other than
	;;; functions and for things for which you don't/can't put in a function
	;;; parent definition.
	((si:function-spec-get function-spec 'sys:function-parent))))