LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031590. :SYSTEM-TYPE :LOGICAL :VERSION 6. :TYPE "LISP" :NAME "HEADER" :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 2758715903. :AUTHOR "REL3" :LENGTH-IN-BYTES 8257. :LENGTH-IN-BLOCKS 9. :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.;;;;;; MAIL HEADERS;;;(defun PARSE-HEADER (header &optional first-line errorp canonicalize-addresses)  "Parse one header from HEADER (a string or stream) and return a headerobject.  If a blank line or EOF terminates the header, a second value ofT is returned.  FIRST-LINE can be a string to use as the first line;continuation lines are then read from HEADER."    (if (stringp header)      (parse-header-string header errorp canonicalize-addresses)    (let (line eof)      (using-xstring (header-string 100);; Get the first line either from header or supplied string.(if first-line    (setq header-string (xstring-append header-string first-line))  (multiple-value-setq (line eof) (send header :line-in))  (setq header-string (xstring-append header-string line)))(loop  for peek = (peek-char nil header nil nil)  do  (when (null peek)    (setq eof t)    (return))  (when (not (member peek *white-space-characters*))    (return))  ;; Pobably continuation  (multiple-value-setq (line eof) (send header :line-in))  (when (string-blank-p line)    ;; Nope, a blank line -- indicate end of headers    (setq eof t)    (return))  ;; Append continuation line  (setq header-string (xstring-append header-string #\Return line)))(values (parse-header-string header-string errorp canonicalize-addresses) eof)))));;; Currently only parses address headers -- the rest are just treated as text.;;; Would be potentialy useful to fully parse the following types of fields:;;; message-id, received, dates, and in-reply-to (though the content of this field;;; is so random these days it may not be worth it.)(defun 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 ((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))))))(defmethod (HEADER :BEFORE :STRING) ()  (unless string    ;; Initialize the instance var    (send self :string-for-message)))(defmethod (BASIC-HEADER :STRING-FOR-MESSAGE) ()  "Return a string to represent self in a message header section."  (or string      (if (eq type :bad-header)  (setq string (or body ""))(setq string (string-append (string-capitalize (string type)) ": " (or body "")))))    #|      ;; It would be nice to force date strings to the RFC822 standard format... but      ;; the lispm time functions lose the timezone and this would force all dates      ;; into the current time zone.      ;;(xstring-append (string-capitalize (string type)) ": " (print-rfc822-date (get header :universal-time) nil))  |#  )(defmethod (ADDRESS-HEADER :STRING-FOR-MESSAGE) ()  (or string      (let ((header-string (allocate-xstring 50)))(setq header-string (xstring-append header-string (string-capitalize (string type)) ": "))(loop  with first = t  with indent-column = (+ 2 (length (string type)))  with fold-column = (if (numberp *fold-address-header-column*) *fold-address-header-column* 100)  with column = indent-column  for addr in address-list  for addr-string = (send addr :string-for-message)  when (> (length addr-string) 0)  do  (unless first    (setq header-string (xstring-append header-string ", ")))  (incf column (length addr-string))  (when (and (not first) (> column fold-column))    (setq header-string (xstring-append header-string #\Return))    (dotimes (x indent-column)      (setq header-string (xstring-append header-string #\Space)))    (setq column (+ indent-column (length addr-string))))  (setq header-string (xstring-append header-string addr-string))  (setq first nil))(setq string header-string))))(defmethod (BASIC-HEADER :EMPTY-BODY-P) ()  (or (null body)      (equal body "")))(defmethod (ADDRESS-HEADER :EMPTY-BODY-P) ()  (null address-list))#|(defmethod (RFC822-HEADER :PARSE-MSG-ID) (&aux Message-id)  "Returns addr-spec"  (when (eq parse-type #\<)        (or (setf message-id (parse-rfc822-address in-stream :basic-address t))(ferror 'parse-error "Parse error, Address specification required for message ID"))        (send self :get-next-token)    (or (eq parse-type #\>)(ferror 'parse-error "Parse error, Invalid message ID"))    (send self :get-next-token)    message-id))|#  (defun HEADER-LINE-P (line)       "If LINE begins with a valid-looking RFC822 header field, return the index the end of the header nameand the index of the  \":\", otherwise nil."    ;; This is ASCII dependant; but RFC822 is defined in terms of ASCII.  ;; Fortunately the LISPM char set is compatible with ASCII in the range of characters  ;; considered here.    (loop    with len = (length line)    with header-name-end    for i from 0     when (>= i len) return nil    for ch = (aref line i)    do    (cond ((char-equal ch #\:)   (if (= i 0)       ;; No good if colon in column 1        (return nil)     ;;Good header, return indexes     (return (or header-name-end i) i)))  ((< 32 (char-code ch) 127)   (when header-name-end     ;; After seeing whitespace, only more whitespace or : allowed.     (return nil)))  ((or (char-equal ch #\Space) (char-equal ch #\Tab))   (when (= i 0)     ;; Whitespace at beginning of line     (return nil))   (when (null header-name-end)     ;; End of header name, look for colon     (setq header-name-end i)))  (t   (return nil)))))(defun HEADER-LINE-TYPE-P (name line)    (let ((end-index (header-line-p line)))    (if (and end-index (string-equal name line :end1 end-index :end2 (length name)))end-indexnil)))(defun HEADER-LINE-BODY-STRING (line &optional (copy-p t))    (let (colon-index body-start)    (multiple-value-setq (nil colon-index) (header-line-p line))    (setq body-start (and colon-index  (string-search-not-set *white-space-characters* line (+ 1 colon-index))))    (if (and body-start colon-index)(if copy-p    (subseq line body-start)  (nsubstring line body-start))      "")))(defun HEADER-LINE-BODY-INDEX (line)    (let (colon-index body-start)    (multiple-value-setq (nil colon-index) (header-line-p line))    (setq body-start (and colon-index  (string-search-not-set *white-space-characters* line (+ 1 colon-index))))    (or body-start(length line))))(defun HEADER-LINE-TYPE (line)    (let ((end-index (header-line-p line)))    (when end-index      (using-xstring (string end-index)(setf (fill-pointer string) end-index)(copy-array-portion line 0 end-index string 0 end-index)(intern (nstring-upcase string) *utility-package*)))))(defun RFC822-DATE-STRING (universal-time &optional timezone)  (multiple-value-bind (sec min hour day month year weekday dst tz)      (time:decode-universal-time universal-time timezone)    (format nil "~A, ~D ~A ~D  ~2,48D:~2,48D:~2,48D ~A"    (time:day-of-the-week-string weekday :short)    day    (time:month-string month :short)    (rem year 100)    hour    min    sec    (time:timezone-string tz dst))))ot allow  ;; one to provide a "de-initializer" function  (send message-object :reuse)  (deallocate-resource 'message message-object))(defsubst ALLOCATE-MESSAGE (&rest message-init-plist)  ;; Just for consistency  (apply #'allocate-resource 'message message-init-plist));;;;;; MAIL QUEUE;;;(defflavor MAIL-QUEUE   ((message-list);List of messages waiting to be sent    (host-queue-list);List of host queues with messages waiting    (enabled-p)    (lock nil));Lock for modification   ()  :gettable-instance-variables  :settable-instance-variables)(defmethod (MAIL-QUEUE :REUSE) ()  (setq message-list nil)  (setq host-queue-list nil))(defresource TEMP-MAIL-QUEUE ()  :constructor (make-instance 'mail-queue)  :initializer (send object :reuse)  :matcher (true)  :initial-copies 1)(defstruct HOST-QUEUE  "A queue of messages/addresses for a particular host."  contact;The host to receive messages in this 