LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031597. :SYSTEM-TYPE :LOGICAL :VERSION 9. :TYPE "LISP" :NAME "NAME" :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 2758715992. :AUTHOR "REL3" :LENGTH-IN-BYTES 7815. :LENGTH-IN-BLOCKS 8. :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.;;; HOST names, USER names, MAILING LIST names, GATEWAY names,;;; PERSONAL names, DEFAULT names, NAMESPACE names, names, Names, NAMES!!!(defvar *PRIMARY-MAIL-SERVERS* :unbound  "Overrides site option for this machine. List of host names to use as mail server.");;;(defvar *PRIMARY-MAIL-SERVERS* '("DSG");;;  "Overrides site option for this machine. List of host names to use as mail server.")(defun PRIMARY-MAIL-SERVERS ()  (if (boundp '*primary-mail-servers*)      *primary-mail-servers*    (get-site-option :primary-mail-servers)))(defun PRIMARY-MAIL-SERVER-P (host)  (let ((server-list (primary-mail-servers)))    (dolist (name server-list)      (when (eq host (si:parse-host name t))(return t)))))(defvar *USE-PRIMARY-MAIL-SERVERS* :unbound  "Overrides site option for this machine.  Determines when to use a primary mail server.  Possible values are :ALWAYS, :NEVER, and :AFTER-FIRST-ATTEMPT");;;(defvar *USE-PRIMARY-MAIL-SERVERS* :always;;;  "Overrides site option for this machine.  Determines when to use a primary mail server.  ;;;Possible values are :ALWAYS, :NEVER, and :AFTER-FIRST-ATTEMPT")(defun USE-PRIMARY-MAIL-SERVERS ()  (let ((server-list (primary-mail-servers)))    (and (consp server-list);If no servers defined, return nil (not;If this machine is a server, return nil   (dolist (name server-list)     (when (eq si:local-host (si:parse-host name t))       (return t)))) (if (boundp '*use-primary-mail-servers*);OK, return defined value     *use-primary-mail-servers*   (get-site-option :use-primary-mail-servers)))))(defvar *UUCP-GATEWAY-HOSTS* :unbound  "Overrides site option for this machine.  Names of hosts that can forward UUCP mail.")(defun UUCP-GATEWAY-HOSTS ()  (if (boundp '*uucp-gateway-hosts*)      *uucp-gateway-hosts*    (get-site-option :uucp-gateway-hosts)))(defvar *DEFAULT-MAIL-HOST* :unbound  "Overrides site option for this machine.  Host name to use in addresses that do not specify a host.")(defun DEFAULT-MAIL-HOST ()  (or     (if (boundp '*default-mail-host*)*default-mail-host*      (get-site-option :default-mail-host))    (send fs:user-login-machine :name)))(defun REJECT-MAIL ()  (or *reject-mail-connections*      (send si:local-host :get-host-attribute :reject-mail)))(defun MAIL-GATEWAY-HOST (host)  (parse-mail-domain (send host :get-host-attribute :mail-gateway-host)))(defun LOCAL-MAIL-DOMAINS ()  (get-site-option :local-mail-domains))(defun TOP-LEVEL-MAIL-DOMAIN-SERVERS ()  (get-site-option :top-level-mail-domain-servers))(defun DEFAULT-FROM-ADDRESS (&optional errorp)    ;;Would like to use fs:user-personal-name-first-name-first as a "fallback" when the personal  ;;name is not specified in some other way, but this variable gets mangled for unknown  ;;reasons, so it's use has been removed    (fs:force-user-to-login)  (let* ((addr-string (or *user-mail-address*  (name:lookup-attribute-value user-id :user :mail-address))) (personal-name *mail-user-personal-name*) user-supplied-p address temp-string)        (cond ((or (null addr-string) (equal addr-string ""))   (setq temp-string (xstring-append nil user-id "@" (send fs:user-login-machine :name)))   (setq address (parse-address temp-string 0 nil errorp :mailbox))   (deallocate-xstring temp-string))  (t   (setq user-supplied-p t)   (setq address (parse-address addr-string 0 nil errorp :mailbox))))    (when (and (basic-address-p address)       personal-name       (stringp personal-name)       (not (equal personal-name ""))       (not (string-search-set '(#\< #\> #\@ #\, #\; #\:) personal-name)))      (setq temp-string (xstring-append nil personal-name " <" (send address :string-for-message) ">"))      (setq address (parse-address temp-string 0 nil errorp :mailbox))      (deallocate-xstring temp-string))    (values      (send address :canonical-address)      user-supplied-p)))(defun DEFAULT-RETURN-PATH-ADDRESS (&optional errorp)    (fs:force-user-to-login)  (let ((addr-string (and (not *return-path-always-local*)  (or *user-mail-address*      (name:lookup-attribute-value user-id :user :mail-address))))(temp-string nil))    (unless (and addr-string (not (equal addr-string "")))      (setq temp-string (xstring-append nil user-id "@" (send si:local-host :name))))    (prog1       (parse-address (or temp-string addr-string) 0 nil errorp :route-address)      (when temp-string(deallocate-xstring temp-string)))))(defun DEFAULT-SENDER-ADDRESS (&optional errorp)  (fs:force-user-to-login)  (let ((sender (xstring-append nil user-id "@" (send si:local-host :name))))    (prog1 (parse-address sender 0 nil errorp :mailbox)   (deallocate-xstring sender))))(defun MAILER-DAEMON-ADDRESS ()  (send     (get-named-address "Mail Delivery Subsystem" nil '("Mailer") (send si:local-host :name))    :canonical-address))(defun POSTMASTER-ADDRESS ()    (let ((string (or *postmaster-address*    (get-site-option :postmaster))))    (if (null string)(mailer-daemon-address)      (send (parse-address string 0 nil nil :mailbox):new-address :type :named-address :name "Postmaster General"))))(defun EXPAND-NS-MAILING-LIST (name-string &optional namespace verify-only)    (let ((name-list (ns-lookup-safely name-string :mailing-list :address-list :namespace namespace)))    (if (and name-list verify-only)t(when name-list  (mapcar #'parse-address name-list)))))(defun EXPAND-LOCAL-MAILING-LIST (list &optional verify-only)    ;; A name like "foo" will look for MAILING-LISTS;FOO.MLIST   ;; A name like "one.two.three" will look for MAILING-LISTS.ONE.TWO;THREE.MLIST  (when (consp list)    (with-open-file (list-in (fs:make-pathname       :host (or *mailing-list-host* si:local-host)       :directory (cons *mailing-list-directory*(butlast list))       :name (car (last list))       :type "MLIST"       :version :newest)     :error nil)      (cond ((errorp list-in)     nil)    (verify-only     t)    (t     (loop       for line = (read-line list-in nil nil)       while line       unless (or (string-blank-p line)  (member (char line 0) '(#\; #\! #\#)))       collect (parse-address line 0 nil nil nil t)))))))(defun NS-USER-MAIL-ADDRESS (name-string &optional namespace)  (ns-lookup-safely name-string :user :mail-address :namespace namespace))(defun NS-LOOKUP-SAFELY (object-name &rest args)  (declare (arglist object-name object-class attribute-name    &optional &key namespace chase-aliases (merge-aliases t) local))    (let ((value nil)(ns-search-failed nil))    (condition-case ()(setq value (apply #'name:lookup-attribute-value object-name args))      (name:domain-search-failure       (setq ns-search-failed t)))    (when (and (null value)       ns-search-failed       (find #\. (the string object-name)))      (using-xstring (undotted-name (length object-name))(xstring-append undotted-name object-name)(string-subst-char #\_ #\. undotted-name nil)(condition-case ()    (setq value (apply #'name:lookup-attribute-value undotted-name args))  (name:domain-search-failure nil))))    value))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