LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031592. :SYSTEM-TYPE :LOGICAL :VERSION 11. :TYPE "LISP" :NAME "MAILER" :DIRECTORY ("REL3-SOURCE" "MAIL-DAEMON") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758715931. :AUTHOR "REL3" :LENGTH-IN-BYTES 40315. :LENGTH-IN-BLOCKS 40. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                         ;;;-*- Mode:Common-Lisp; Package:MAIL; 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.;;; MAILER -- mail queueing, retries, routing, scheduling...(add-initialization "Mailer logout" '(mailer-logout) :logout)(add-initialization "Mailer warm boot" '(mailer-warm-boot) '(:once :warm))(add-initialization "Kill mail daemon" '(reset-mail-daemon nil :clear-resources t) '(:before-cold :full-gc))(add-initialization "Mailer cold boot" '(mailer-cold-boot) '(:once :cold))(defun MAILER-COLD-BOOT ()  (setq *mailing-list-host* nil)  (setq *inbox-probe-list* nil)  (setq *user-mail-address* nil)  (setq *mail-user-personal-name* nil))(defun MAILER-WARM-BOOT ()  (unless *mailing-list-host*    (setq *mailing-list-host* si:local-host))  (reset-mail-daemon :boot))(defun MAILER-LOGOUT ()  ;; This has caused problems -- login-setq should be used to undo if desired.  ;;(setq *inbox-probe-list* nil)  ;;(setq *user-mail-address* nil)  ;;(setq *mail-user-personal-name* nil)  )(defun MAILER-ERROR (catagory format-string &rest format-args)  (tv:notify nil "~?~%To debug this, set MAIL:*DEBUG-MAILER* to T." format-string format-args)  (log-event catagory "~?" format-string format-args))(defun RESET-MAIL-DAEMON (&optional enable &key (read-queue t) (log-pathname *mailer-log-pathname*)  check-routing clear-resources)  "Start or stop the mail delivery process which handles queued mail andprobes for new mail in the user's inboxes.  If ENABLE is T, the daemonis started and the mail queue is initialized from the saved copy on diskunless READ-QUEUE is nil.  If ENABLE is NIL, the deamon is killed.  IfCLEAR-RESOURCES is T, all stored objects (address objects, messageobject, ect.)  are flushed.  This is done automatically before a fullGC."    (unless *mail-queue*    (setq *mail-queue* (make-instance 'mail-queue))    (setq read-queue t))  (when *mail-daemon*     (send *mail-daemon* :kill)    (setq *mail-daemon* nil))  (when clear-resources    (clear-resources)    (send *mail-queue* :disable)    (send *mail-queue* :reuse))  (cond ((not enable) (send *mail-queue* :disable) nil)(t (unless (eq enable :boot)   ;; Being enabled interactively -- touch the file system to force an error if dismounted.   (probe-file (mailer-directory))) (send *mail-queue* :enable) (setq *mail-daemon*       (process-run-function '(:name "Mail Daemon"     :restart-after-reset t     :priority -5     :restart-after-boot t)     #'mailer-top-level enable read-queue check-routing log-pathname)))))(defun FILE-SYSTEM-USABLE-P (&optional (min-free-space 100))  (and (variable-boundp fs:disk-configuration)       ;;with-maximum-paranoia...       (let ((free (and (variable-boundp fs:put-usage-array)(variable-boundp fs:put-free)(arrayp fs:put-usage-array)(integerp fs:put-free)(aref fs:put-usage-array fs:put-free)))) ;;If can't figure out the free space, say it's OK (or (not (numberp free))     (> free min-free-space)))))(defun WAIT-TILL-DELIVERY-OK ()    (process-wait "Waiting for file system" #'(lambda ()      (and (not si:cold-booting)   (file-system-usable-p 20)))))(defun MAILER-TOP-LEVEL (&optional (mode :boot) (read-queue t) check-routing log-pathname)    (when (eq mode :boot)    ;; After boot, wait 10 minutes for the world to settle down    (process-sleep (* 60 60 10) "Pause"))    (let ((user-id "Mailer")(*log-session* (incf *log-session*))(deliver t)(probe t)(new-items-only nil)(route-check check-routing)(last-route-check (get-universal-time))(last-delivery (get-universal-time))(last-probe (get-universal-time))utime)    (wait-till-delivery-ok)    (condition-call (condition)(when (eq mode :boot)  (when (directory "LM:MAILER;*.QUEUE")    (tv:notify nil "~&The MAILER directory on this machine contains queued messages in Release 2 format.~~%Use the function MAIL:CONVERT-REL2-MAILER-FILES to convert these files to Release 3 format.~~%Otherwise, the queued messages cannot be delivered while running a Release 3 band.")))      ((handle-condition-p condition)       ))    (condition-call-if (not *debug-mailer*) (condition)(progn  (when (and log-pathname *log-enabled*)   (force-log-output)   (setq *log-output* (make-instance 'log-stream :pathname log-pathname))   (log-event :mail-queue ">>>>Mail Daemon started.  Mode: ~A, Read queue: ~A." mode read-queue)) (when read-queue   (send *mail-queue* :reuse)   ;; Initialize with queue for local host at the front to speed local delivery.   (send *mail-queue* :set-host-queue-list (list (make-host-queue :contact si:local-host)))   (let ((dir (mailer-directory)))     (unless (probe-file (send dir :directory-pathname-as-file))       (fs:create-directory dir))     (send *mail-queue* :restore (fs:directory-list (send dir :new-type :work) :sorted)))   (setq check-routing nil)))      ((handle-condition-p condition)       (mailer-error :mail-queue "Error in MAILER-TOP-LEVEL initialization: ~A" condition)))    (loop      (condition-call-if (not *debug-mailer*) (condition)  (block top-loop    (when deliver      (send (mailer-directory) :expunge)      (when route-check(send *mail-queue* :check-routing)(setq last-route-check (get-universal-time)))      (log-debug :delivery "Begin queue delivery.")      (send *mail-queue* :deliver new-items-only)      (log-debug :delivery "Queue delivery complete.")      (force-log-output)      (unless new-items-only(setq last-delivery (get-universal-time))))    (when probe      ;; Probe inboxes.  Don't get stuck here; give up after 2 minutes.      (with-timeout ((* 2 60 60))(probe-inboxes))      (setq last-probe (get-universal-time)))    (force-log-output))((handle-condition-p condition) (mailer-error :mail-queue "Mailer error in top level loop.~%~A" condition)))      (process-wait "Mailer Sleep" #'(lambda (wakeup-time)       (or *wakeup-mailer*   (>= (get-universal-time) wakeup-time)))    (max (+ (get-universal-time) (* 5 60));Never loop faster than 5 minutes (min (+ last-delivery *mail-background-sleep-time*)      (+ last-probe  *inbox-probe-sleep-time*))))      (setq utime (get-universal-time))      (wait-till-delivery-ok)      (setq deliver (or *wakeup-mailer*(>= utime (+ last-delivery *mail-background-sleep-time*))))      (setq new-items-only (eq *wakeup-mailer* :new-item))      (setq probe (or *wakeup-mailer*      (>= utime (+ last-probe  *inbox-probe-sleep-time*))))      (setq route-check (>= utime (+ last-route-check *check-routing-interval*)))      (setq *wakeup-mailer* nil))));;;;;; QUEUE related methods and functions;;;(defmethod (MAIL-QUEUE :ENABLE) ()  (setq enabled-p t))(defmethod (MAIL-QUEUE :DISABLE) ()  (setq enabled-p nil))(defmethod (MAIL-QUEUE :RESTORE) (directory-list)  (loop with errors and messagefor item in directory-listfor path = (car item)when (pathnamep path)do(condition-call-if (not *debug-mailer*) (condition)    (with-open-file (work-in path)      (setq message (allocate-message))      (send message :restore work-in path)      (send self :add-message message nil))  ((handle-condition-p condition)   (push (format nil "While reading work file ~A~%~A" path (send condition :report-string)) errors)))finally(when errors  (mailer-error :mail-queue "Mailer error~P occured while reading the mail queue.~{~2%~A~}"(length errors) errors))))(defmethod (MAIL-QUEUE :ADD-MESSAGE) (message &optional (save t))    (unless (send message :delivery-complete-p)    (log-event :mail-queue "Adding message ~A to queue for ~{~A~^,  ~}" message (send message :address-list))    (cond ((send message :loop-detected-p)   (log-debug :mail-queue "Loop detected.  Returning message to sender.")   (dolist (address (send message :address-list))     (send message :dispose-address address :loop-detected nil   "Message looping on the network; too many Received: lines.")))  (t   (unless (send message :expanded-p)     (send message :translate-addresses :expand t :forward t))))    (when (and save (eq self *mail-queue*))      (send message :save))    (with-lock (lock)      (push-end message message-list))    (when (send message :address-list)      (let (contact-alist);; Build an alist of ((contact1 addrA addrB) (contact2 addrC ...) ...)(loop  for address in (send message :address-list)  for contact = (send address :host-for-queue (and *interactive-delivery-in-progress* (neq self *mail-queue*)))  for item = (assoc contact contact-alist :test #'eq)  when item do (push-end address item)  else do (push (list contact address) contact-alist))(log-debug :mail-queue "Host/Address routing for ~S: ~{~%~S~}" message contact-alist);; Add message to the host queue for each contact;; Turn (contact addr ...) into (message addr ...) an put in proper host-queue(loop  for item in contact-alist  for contact = (car item)  do (setf (car item) message)  for host-queue = (find contact host-queue-list :key #'host-queue-contact :test #'eq)  when host-queue do  (with-lock ((host-queue-lock host-queue))    (push-end item (host-queue-message-alist host-queue)))  (setf (host-queue-new-item-p host-queue) t)  else do   (with-lock (lock)    (push-end (make-host-queue :contact contact :message-alist (list item) :new-item-p t)      host-queue-list))  when (and *interactive-delivery-in-progress* (eq self *mail-queue*))  do  (dolist (address (cdr item))    (send address :set-delivery-status :queued contact nil)))))))(defmethod (MAIL-QUEUE :VALIDATE-MESSAGE-LIST) ()    ;; Verify that message file exist for each message  (when (eq *mail-queue* self)    (dolist (message message-list)      (unless (make-message-input-stream message t)(let ((queue-path (send message :queue-path)))  (if queue-path      (log-event :mail-queue "Cannot open message file for ~A -- message removed from queue." queue-path)    (log-event :mail-queue "No queue path for ~S -- message removed from queue." message)))(send self :dispose-message message)))))(defmethod (MAIL-QUEUE :DELIVER) (&optional new-items-only)  "Attempt delivery of all messages waiting in this queue."    (send self :validate-message-list)  (dolist (host-queue host-queue-list)    (let ((contact (host-queue-contact host-queue)))      ;; Errors should be handled by clients, but want to make      ;; sure we try each host if an error occurs in here.      (condition-call-if (not *debug-mailer*) (condition)  (block do-host    (when (and (host-queue-message-alist host-queue)       (or (null new-items-only)   (host-queue-new-item-p host-queue)))      (setf (host-queue-new-item-p host-queue) nil)      (if (eq self *mail-queue*)  (run-delivery-process host-queue)(deliver-host-queue host-queue)))    ;; Loop over each message for host to see if delivery complete    (dolist (message-item (host-queue-message-alist host-queue))      (let ((host-message (car message-item))    (host-address-list (cdr message-item)));; Check if all recipients of this message for this host are delivered.(when (null host-address-list)  (host-queue-delete-message host-queue host-message));; Check if entire message has been delivered as well.(if (send host-message :delivery-complete-p)    (send self :dispose-message host-message)    ;; Still work to be done, see if needs saving    (when (eq self *mail-queue*)      (send host-message :update)));; Check if nothing left for this host (just leave the host queue for later re-use?);;(when (null (host-queue-message-alist host-queue));;(setq host-queue-list (delete host-queue (the list host-queue-list) :test #'eq))))))((handle-condition-p condition) (mailer-error :delivery "Mailer error while sending mail to ~A~%~A" contact condition) (setf (host-queue-last-error host-queue) condition))))        (force-log-output))    (when (eq self *mail-queue*)    ;; Process error returns in one batch    (loop      for message in message-list      do      (send message :return-errors)      (if (send message :delivery-complete-p)  (send self :dispose-message message)(send message :update)))))(defun DELIVER-HOST-QUEUE (host-queue)    (log-debug :delivery "Delivery for host-queue: ~A.  ~D Messages pending."  (host-queue-contact host-queue) (length (host-queue-message-alist host-queue)))  (when (host-queue-message-alist host-queue)    (let ((contact (host-queue-contact host-queue)))      (setf (host-queue-last-attempt host-queue) (get-universal-time))      (cond ((eq contact :server)     (setq contact (primary-mail-servers))     (when (and *interactive-delivery-in-progress*(eq (use-primary-mail-servers) :always))       (format t "~&Forwarding to primary mail server.")))    ((eq contact :uucp)     (setq contact (uucp-gateway-hosts))))      (when (stringp contact)(setq contact (si:parse-host contact nil)))      (let (result)(cond ((typep contact 'net:host)       (setq result (send contact :mail-to-user :deliver host-queue))       (when (errorp result) (host-access-error contact host-queue result)))      ((consp contact)       (loop for a-contact in contact for host = (si:parse-host a-contact nil) do (when (typep host 'net:host)   (setq result (send host :mail-to-user :deliver host-queue))   (when (errorp result)     (host-access-error host host-queue result))   (when (null (host-queue-message-alist host-queue))     (return))))))))))(defun RUN-DELIVERY-PROCESS (host-queue)    (let ((process (allocate-resource 'delivery-process))(contact (host-queue-contact host-queue))abort status)    (unwind-protect(progn  (using-xstring (whostate 50)    (setf (host-queue-delivery-in-progress-p host-queue) t)    (send process :preset #'delivery-process host-queue)    (process-enable process)    (setq abort t)    (setq *delivery-process* process)    (format whostate "Deliver to ~A" (if (typep contact 'net:host) (send contact :name) contact))    ;; Wait until delivery complete    (setq status  ;; Give up if 15 minutes idle time or 30 minutes total time even if not idle  (process-wait whostate#'(lambda (process host-queue give-up)    (cond ((not (host-queue-delivery-in-progress-p host-queue))   t)  ((> (or (send process :idle-time) 0)      (* 15 60))   :idle)  ((> (time) give-up)   :hung)  (t nil)))process host-queue (time-increment (time) (* 30 60 60)))))  (setf (host-queue-delivery-in-progress-p host-queue) nil)  (cond ((eq status :hung) (send process :kill) (log-event :delivery "Delivery process ~S to host ~S appears hung.  Killed it."    process (host-queue-contact host-queue)))((eq status :idle) (send process :kill) (log-event :delivery "Delivery process ~S to host ~S idle too long.  Killed it."    process (host-queue-contact host-queue))))  (setq abort nil))      (when abort(send process :kill))      (deallocate-resource 'delivery-process process)      (setq *delivery-process* nil))))(defun DELIVERY-PROCESS (host-queue)    (unwind-protect       (let ((user-id "Mailer")    (*log-session* (incf *log-session*)))(deliver-host-queue host-queue))    (setf (host-queue-delivery-in-progress-p host-queue) nil)    (send si:current-process :kill)))(defun HOST-QUEUE-DELETE-MESSAGE (host-queue message)  (with-lock ((host-queue-lock host-queue))    (setf (host-queue-message-alist host-queue)  (delete message (the list (host-queue-message-alist host-queue))  :test #'eq :key #'car))))(defun HOST-ACCESS-ERROR (host host-queue condition)  (setf (host-queue-last-error host-queue) condition)  (when *interactive-delivery-in-progress*    (format t "~&Error accessing host ~A: ~A" host condition))  ;;(dolist (address address-list)  ;;(send address :set-delivery-status :deferred host (send stream :report-string)))  )(defun GET-HOST-QUEUE (contact &optional (mail-queue *mail-queue*) create-p)  (or (find contact (send mail-queue :host-queue-list) :key #'host-queue-contact)      (when create-p(let ((host-queue (make-host-queue :contact contact)))  (send mail-queue :set-host-queue-list(nconc (send mail-queue :host-queue-list)       (list host-queue)))  host-queue))))(defmethod (MAIL-QUEUE :DISPOSE-MESSAGE) (message)  (send message :flush)  (with-lock (lock)    (setq message-list (delete message (the list message-list) :test #'eq)))  (dolist (host-queue host-queue-list)    (host-queue-delete-message host-queue message)))(defmethod (MAIL-QUEUE :CHECK-ROUTING) ()    (when    ;; Loop thru the host queues checking if each address    ;; still wants to go to the host it is queued for.    (block do-check      (dolist (host-queue host-queue-list)(let ((contact (host-queue-contact host-queue)))  (dolist (message-item (host-queue-message-alist host-queue))    (dolist (address (cdr message-item))      (unless (eq contact (send address :host-for-queue))(return-from do-check t)))))))    ;; At least one address wants to go to a different host.    ;; Clear the host queues and rebuild (ick).    (let ((messages message-list))      (with-lock (lock)(setq host-queue-list nil)(setq message-list nil))      (dolist (message messages)(send self :add-message message nil)))))(defsignal MAILER-DISABLED-ERROR (error mailer-error mailer-disabled) ()  "Attempt to use the mailer while it is disabled.")(defun ENQUEUE-MESSAGE (message &optional (translate t))  ;; Assumes addresses have been verified and deemed "acceptable"  ;; and any stripping or canonicalization has been done.  ;; Mailing lists and forwarding are handled if TRANSLATE is true.    (let ((do-reset nil))    (error-restart (mailer-disabled "Reset the mail daemon and queue message.")      (when do-reset(reset-mail-daemon t))      (when (not (send *mail-queue* :enabled-p))(if (not *interactive-delivery-in-progress*)    (return-from enqueue-message (make-condition 'mailer-disabled "Cannot queue message.  Mailer is disabled."))  (setq do-reset t)  (ferror 'mailer-disabled  "Mailer is disabled; cannot queue message.  Use (MAIL:RESET-MAIL-DAEMON T) to enable.")))))  ;; Maybe should postpose translation and set translated-p to nil  (when translate    (send message :translate-addresses :expand t :forward t))  ;; Don't do this... ties up the server for too long if a big mailing list is expanded.  ;;(send message :direct-delivery)  (send *mail-queue* :add-message message)  (setq *wakeup-mailer* :new-item))(defun PARSE-MAIL-DOMAIN (domain &optional namespace-ok)    ;;? Still need to try this?  parse-host seems to handle logical hosts these days?  ;;(fs:get-pathname-host host t)  (let (host)    (unless (null domain)      (cond ((stringp domain)     (setq host (or (si:parse-host domain t)    (and namespace-ok (name:find-known-namespace domain))))     (unless host       (loop with substring for local-domain in (local-mail-domains) for index = (search local-domain domain :from-end t :test #'equalp) when (and index (> index 1)   (eql (char domain (1- index)) #\.)) do (setq substring (xsubstring domain 0 (1- index))) (setq host (or (si:parse-host substring t)(and namespace-ok     (name:find-known-namespace substring)))) (deallocate-xstring substring) (when host   (return)))))    ((typep domain 'si:basic-host)     (setq host domain))))    host))(defun PRINT-ADDRESS-DISPOSITION (stream address disposition arg report)    (case disposition    (:delivered     ;; arg is host that accepted     (setf (get address :last-delivery-host) arg)     (format stream "~&~16A -- Delivered to host ~A"     address (short-host-string arg)))    (:rejected     ;; arg is host that rejected     (setf (get address :last-delivery-host) arg)     (format stream "~&~16A -- Rejected by host ~A: ~A"     address (short-host-string arg) report))    (:translated      (when arg       ;; arg is new address or a string       (format stream "~&~16A -- Translated to ~A"       address arg)))    (:forward-unknown     (format stream "~&~16A -- Unknown.  Fowarding to a primary server." address))    (:expansion-error     ;; arg is address that expanded into a mailing list     (format stream "~&~16A -- ~A  (from mailing list ~:@(~A~))"     address report arg))    (:deferred     (format stream "~&~16A -- Deferred.  ~A" address report))    (:queued     (format stream "~&~16A -- Queued for ~A" address     (cond ((eq arg :uucp)    "UUCP gateway host.")   ((eq arg :server)    "a primary mail server.")   (t    (short-host-string arg)))))    (:smtp-error     (format stream "~&~16A -- SMTP error with ~A: ~A" address (short-host-string arg) report))    ((:expanded :translated)     )    (:otherwise     (if report (format stream "~&~16A -- ~A" address report)       (format stream "~&~16A -- Status unknown. ~@[~A~]" address disposition)))))(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 automaticallyMSG-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 listaddresses unsent but queued, a list of all addresses to which delivery was attempted, anda 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)     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)) (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 (car (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)))))))(defun PROBE-INBOXES ()    (condition-call-if (not *debug-mailer*) (condition)      (loop       with creation-date       for inbox-item in *inbox-probe-list*       for path = (car inbox-item)       when path       do       (catch 'probe-inbox-attempt (let ((fs:*generic-login-function* 'avoid-password-query))   (with-open-file (inbox-in path :direction :probe :error nil)     (unless (or (null inbox-in) (errorp inbox-in))       (setq creation-date (send inbox-in :creation-date))       ;; Check if file has changed or did not previously exist       (when (or (not (numberp (second inbox-item))) (> creation-date (second inbox-item))) ;; Update time (setf (second inbox-item) creation-date) (tv:notify nil "New mail in ~A" path)))))))    ((handle-condition-p condition)     condition)))        (defun AVOID-PASSWORD-QUERY (&rest ignore)  "Used as an alternate login function to avoid password prompts in background stream."  (declare (ignore ignore))  (throw 'probe-inbox-attempt nil))(defun ADD-MAIL-INBOX-PROBE (pathname)  "Add a pathname to the list of files to be probed for new mail."  (setq pathname (fs:parse-namestring pathname))  (setq pathname (send pathname :new-version :newest))  (unless (assoc pathname *inbox-probe-list*)    (push-end (list pathname nil) *inbox-probe-list*)))(defun REMOVE-MAIL-INBOX-PROBE (pathname)  "Remove a  pathname from the list of files to be probed for new mail."  (setq pathname (fs:parse-namestring pathname))  (setq pathname (send pathname :new-version :newest))  (let ((inbox (assoc pathname *inbox-probe-list*)))    (when inbox      (setq *inbox-probe-list* (delete inbox *inbox-probe-list*)))))(defun PRINT-MAIL-QUEUE (&optional (host-queues t) messages)  "Print the current state of the mail queue."    (when (null *mail-queue*)    (if (y-or-n-p "~&GAK!  MAIL:*MAIL-QUEUE* is NIL!  Shall I reset the mail daemon?")(reset-mail-daemon t)      (return-from print-mail-queue)))  (format t "~&The Mailer is ~A." (if (send *mail-queue* :enabled-p)      "enabled" "disabled"))  (if (null *mail-daemon*)      (when (y-or-n-p "~2&The mail daemon is not running.  Shall I reset it?")(reset-mail-daemon t))    (format t "~&Mail daemon whostate: ~28T~A" (process-whostate *mail-daemon*)))  (let ((proc *delivery-process*))    (when proc      (format t "~&Delivery whostate: ~28T~A" (process-whostate proc))))  (format t "~&Reject mail connections: ~28T~A" (reject-mail-connection-p))  (format t "~&Total messages in queue: ~28T~D" (length (send *mail-queue* :message-list)))  (when messages    (if (null (send *mail-queue* :message-list))(format t "~&~%No messages pending.")      (format t "~&~%Messages in queue:")      (dolist (msg (send *mail-queue* :message-list))(format t "~&~%Return path: ~18T~A" (send (send msg :return-path)  :string-for-message))(format t "~&Address list: ~18T~{~A~^, ~}" (send msg :address-list))(format t "~&Date queued: ~18T~A" (time:print-universal-time (send msg :date-received) nil nil :|DD MMM YY|))(format t "~&Queue path: ~18T~A" (send msg :queue-path)))))  (when (and host-queues (send *mail-queue* :host-queue-list))    (let ((first t))      (dolist (host-queue (send *mail-queue* :host-queue-list))(when (host-queue-message-alist host-queue)  (when first    (format t "~&~%Destination hosts with messages pending:")    (setq first nil))  (format t "~&~%Contact: ~18T~A" (host-queue-contact host-queue))  (format t "~&Last error: ~18T~A" (host-queue-last-error host-queue))  (format t "~&Last attempt: ~18T")  (if (numberp (host-queue-last-attempt host-queue))      (time:print-universal-time (host-queue-last-attempt host-queue) t nil :|DD MMM YY|)    (princ "Never"))  (format t "~&Messages: ~18T~D" (length (host-queue-message-alist host-queue)))  (format t "~&Recipients: ~18T~D"  (loop    for message-item in (host-queue-message-alist host-queue)    sum (length (cdr message-item))))  (loop with oldestfor message-item in (host-queue-message-alist host-queue)for date = (send (car message-item) :date-received)when (or (null oldest) (< date oldest))do (setq oldest date)finally(when oldest  (let ((interval (- (get-universal-time) oldest)))    (format t "~&Oldest message: ~18T")    (time:print-interval-or-never (- interval (mod interval 60)))))))))))(defmethod (LOG-STREAM :AFTER :INIT) (&rest ignore)    (setq pathname (parse-namestring pathname))  (setq pathname (send pathname :new-version :newest))  (setq buffer (make-array buffer-size :element-type 'string-char :fill-pointer 0))  (setq old-buffer (make-array buffer-size :element-type 'string-char :fill-pointer 0))  ;; Create a new version if current version very large  (let (start-new-p)    (with-open-file (log pathname :direction :probe)      (when (streamp log)(let ((size (send log :length)))  (setq start-new-p (and (numberp size) (> size 50000))))))    (when start-new-p      (with-open-file (log pathname :direction :output :if-exists :new-version)log)))  ;; Calculate time to create new version  (multiple-value-bind (nil nil nil day mon year nil nil tz)      (decode-universal-time (get-universal-time))    (setq next-new-version-time (encode-universal-time 0 0 new-version-hour day mon year tz))    ;; If already past, schedule for next crossing    (when (< next-new-version-time (get-universal-time))      (incf next-new-version-time (* 24 60 60)))))(defmethod (LOG-STREAM :NEW-OUTPUT-BUFFER) ()  (let ((string (allocate-xstring 100)))    (values string    0    (array-dimension string 0))))(defmethod (LOG-STREAM :SEND-OUTPUT-BUFFER) (string end)    (let (buffer-start-index buffer-end-index)    (cond (overflow-p   (incf bytes-lost end))  ((and (< buffer-index buffer-size);; Don't let 2 processes hack the index at the same time(without-interrupts  (setq buffer-start-index buffer-index)  (setq buffer-end-index (incf buffer-index end))  (< buffer-end-index buffer-size)))   (copy-array-portion string 0 end buffer buffer-start-index buffer-end-index))  (t   (setq overflow-p t)   (setq bytes-lost end))))  (deallocate-xstring string))(defmethod (LOG-STREAM :DISCARD-OUTPUT-BUFFER) (string)  (deallocate-xstring string))(defmethod (LOG-STREAM :AFTER :FORCE-OUTPUT) ()    ;;May want to defer writing when buffer is small because each append to a file uses one block minimum.    ;;Appending lots of small buffers really eats up disk space.    (when (> buffer-index 0)    (let ((unlock-on-exit nil)  (if-exists-action (if (> (get-universal-time) next-new-version-time) :new-version :append)))      (unwind-protect  (condition-call-if (not *debug-mailer*) (condition)      (block do-output;;Check/set lock and swap buffers without interruption(without-interrupts  (when output-lock    (return-from do-output))  (setq output-lock t)  (setq unlock-on-exit t)  (setq old-buffer(prog1 buffer (setq buffer old-buffer)))  (setq old-buffer-index(prog1 buffer-index (setq buffer-index 0))))(when (and (file-system-usable-p)   user-id (not (equal user-id ""))   (send (send pathname :host) :local-host-p))  (with-open-file (out pathname :direction :output :if-exists if-exists-action       :if-does-not-exist :create :error nil)    (unless (errorp out)      (send out :string-out old-buffer 0 old-buffer-index)      (when overflow-p(format out "~2%>>>> Log buffer overflew.  ~D bytes of logging information lost.~2%" bytes-lost)(setq overflow-p nil))))  ;; Delete excess version if just created a new one.  (when (eq if-exists-action :new-version)    (incf next-new-version-time (* 24 60 60))    (let ((dirlist (fs:directory-list (send pathname :new-version :wild) :sorted :deleted :noerror)))      (when (listp dirlist);; Elimitate the directory entry from list(setq dirlist (delete (assoc nil dirlist) dirlist))(dotimes (x (- (length dirlist) versions-kept))  (let ((path (car (nth x dirlist))))    (send path :delete nil)    ;; Expunge if it is allowed.    (when (send path :undeletable-p)      (send path :expunge :error nil))))))))(setq overflow-p nil))    ((handle-condition-p condition)     condition));; Unwind protect forms(when unlock-on-exit  (setq output-lock nil))))))(defflavor RFC822-ADDRESS    ((type :route-addr)    (phrase)    (local-part '())    (domain '())    (route '())    (mailbox-list '())    (comment ""))   (si:print-readably-mixin si:property-list-mixin)  :outside-accessible-instance-variables  (:accessor-prefix address-)  :gettable-instance-variables  :settable-instance-variables  :initable-instance-variables)(defmethod (RFC822-ADDRESS :CONVERT) ()  (cond (route (get-route-address route local-part domain))(t (get-basic-address local-part domain))))(defmethod (RFC822-ADDRESS :RECONSTRUCTION-INIT-PLIST)()  (list :type type:phrase phrase:local-part local-part:domain domain:route route:mailbox-list mailbox-list:comment comment:property-list si:property-list))(defstruct ENVELOPE  "Information about a message for the mail queue to use"  (host-access-errors)  (request-type)  (date-entered)  (sequence-number)  (pathname)  (message-string)  (return-path)   (address-list)  (retry-notification-limit)  (retry-return-limit))(defun CONVERT-REL2-MAILER-FILES (&optional (path "LM:MAILER;*.QUEUE#>"))    (let ((*package* (find-package "MAIL"))(conversion-count 0))    (setq path (parse-namestring path))    (dolist (queue-path (rest (fs:directory-list path)))      (setq queue-path (send (first queue-path) :new-version :newest))      (when (not (probe-file (send queue-path :new-type "MESSAGE")))(format t "~&No MESSAGE file found for ~A" queue-path)(rename-file queue-path (send queue-path :new-type "OLD-QUEUE"))(return))      (with-open-file (stream queue-path)(let ((message (allocate-message))      (mail-queue-object-list (zlc:read stream nil))      (first t))  (dolist (mail-queue-object mail-queue-object-list)    (dolist (envelope (second mail-queue-object))      (when first(send message :set-return-path      (if (typep (envelope-return-path envelope) 'rfc822-address)  (send (envelope-return-path envelope) :convert)(get-null-address)))(send message :set-date-received (envelope-date-entered envelope))(send message :set-tick-received 0)(send message :set-queue-path (send queue-path :new-type "WORK"))(send message :set-modified-p t))      (dolist (address (envelope-address-list envelope))(when (typep address 'rfc822-address)  (send message :add-recipient (send address :convert))))))  (send message :save)))      (rename-file queue-path (send queue-path :new-type "OLD-QUEUE"))      (format t "~&Converted ~A" queue-path)      (incf conversion-count))    (if (= conversion-count 0)(format t "~&No queued mail in Release 2 format found in ~A" path)      (format t "~&Conversion complete.  Resetting the mail daemon to add files to queue.")      (mail:reset-mail-daemon t))))  (or (eq y 'atom)(and f2 (member y (dont-optimize (flavor-depends-on-all f1)) :test #'eq) t)))    (f2 nil)    ((or (and (setq t1 (getdecl x 'defstruct-description)) (defstruct-description-named-p t1))(getdecl x 'defstruct-named-p))     (if (member y '(structure atom array common) :test #'eq)       t       (and(or (and (setq t2 (getdecl y 'defstruct-description)) (defstruct-description-named-p t2))   (get y 'defstruct-named-p))(do ((symbol x      (and (setq t1 (getdecl symbol 'defstruct-description)) (car (defstruct-description-include t1)))))    ((null symbol)     nil)  (and (eq y symbol) (return t))))))    (t