LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031630. :SYSTEM-TYPE :LOGICAL :VERSION 10. :TYPE "LISP" :NAME "SEND-MAIL" :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 2758716615. :AUTHOR "REL3" :LENGTH-IN-BYTES 31903. :LENGTH-IN-BLOCKS 32. :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.(defminor COM-MAIL-MODE mail-mode "Mail" 1  "Minor mode which can send buffer as a mail message."  ()  (set-comtab *mode-comtab* '(#\End  com-send-mail      #\Abort com-mail-mode-exit      #\Help com-mail-mode-documentation      #\C-M-Y com-yank-message      #\mouse-r-1 com-mail-mode-general-mouse-menu       )      '(("Send Mail" . com-send-mail)("Quit" . com-mail-mode-exit)("Delivery Status" . com-delivery-status)("Yank Message" . com-yank-message)("Yank Current Message" . com-yank-current-message)))  (set-mode-line-list (append (mode-line-list) '("  (END to mail -- ABORT to exit)"))))(defcom COM-YANK-MESSAGE"Yank the message being replied to (or the current message, if not in a reply buffer)into the current buffer.  Text is indented and headers reformatted unless a prefix arg is supplied."(push)  (let ((saved-msg (or (get *interval* :message-object-list)       (get *interval* :message-object)       *msg*))(bp (copy-bp (point) :moves)))    (unless saved-msg      (barf "There is no message to yank."))    (unless (consp saved-msg)      (setq saved-msg (list saved-msg)))    (move-bp (mark) bp)    (with-open-stream (out (interval-stream-into-bp (point)))      (dolist (msg saved-msg)(print-formatted-message msg out (if *numeric-arg-p* nil *yank-message-prefix*) nil (not *numeric-arg-p*) nil *yank-message-headers-include-list*)(terpri out)))    ;; Leave point at end of inserted text    (move-bp (point) bp)    (let ((windows (frame-exposed-windows)))      (when (cdr windows)(make-window-full-screen *window*))); Since we've yanked the message, switch to one-window mode.    dis-text))(defcom COM-YANK-CURRENT-MESSAGE"Yank the the current message of the current mail buffer into the current buffer.Text is indented with *yank-message-prefix* unless a prefix arg is supplied."(push)  (let ((bp (copy-bp (point) :moves)))    (unless *msg*      (barf "There is no message to yank."))    (move-bp (mark) bp)    (with-open-stream (out (interval-stream-into-bp (point)))      (print-formatted-message *msg* out (if *numeric-arg-p* nil *yank-message-prefix*)       nil t nil *yank-message-headers-include-list*))    ;; Leave point at end of inserted text    (move-bp (point) bp))  dis-text)(defcom COM-SEND-MAIL"Send mail and exit mail mode."()    (let (subject)    (multiple-value-bind (sent error-list queued-list all-addresses header-list)(mail:submit-mail (interval-stream (interval-first-bp *interval*)   (interval-last-bp *interval*)))      (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))))  (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(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);; This should be merged with copy-message-to-mail-file somehow(defun FCC-MESSAGE-TO-MAIL-FILE (msg pathname &optional quiet-p)    (let ((abort-flag t)whereto format)    (when (stringp pathname)      (setq pathname (fs:merge-pathname-defaults pathname)))    (unwind-protect(progn  (multiple-value-setq (whereto format) (copy-message-init pathname))  (if (streamp whereto)      (write-message msg format whereto)      (add-message-to-buffer msg whereto))  (setq abort-flag nil)  (unless quiet-p    (format t "~2%Saved message in ~A ~A ~@[in ~A format~]"    (if (streamp whereto) "file" "buffer")    (if (streamp whereto) pathname whereto)    format))  (when (mail-reader-buffer-p whereto)    (when (mail-summary-of whereto)      (update-summary (mail-summary-of whereto)))    (unless quiet-p      (format t "~&Be sure to save the buffer to reflect changes."))))      (when (streamp whereto)(send whereto :close abort-flag)))))(defcom COM-MAIL-MODE-EXIT"Exit mail mode without sending mail"()  (cond ((or (and (boundp '*macro-level*) *macro-level*)     *numeric-arg-p*     (window-mark-p *window*)     (send *standard-output* :exposed-p)) (send *standard-input* :send-if-handles :macro-error) (setq *mark-stays* nil) (setq *numeric-arg-p* nil) (send *window* :prepare-for-redisplay))(t ;; Bury the mail template (let* ((template *interval*)(mail-buffer (get *interval* :buffer-of-mail-command))(msg (get template :message-object))(kill (and nil;disabled   (not (send *interval* :modified-p))   (y-or-n-p "Mail template buffer not modified.  Kill it?")))(window (get *interval* :return-to-window-after-send)))   (if (or (null mail-buffer)   (get mail-buffer :killed))       ;; Not invoked from a mail buffer, just select previous buffer       (send (previous-buffer *interval*) :select)     ;; Reselect the mail buffer     (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)))   (if kill       (send template :kill)     (hide-mail-buffer template nil))   ;; If invoked from another window, return to it.   (when (and window (send window :active-p))     (send window :select)))))  dis-none)(defcom COM-DELIVERY-STATUS"Report results of past attempts to deliver this message."()  (let ((status-list (get *interval* :mail-delivery-status)))    (cond ((null status-list)   (format t "~%This message has never been sent."))  (t   (loop     for status in status-list     for count from 1     do     (format t "~2%Attempt #~D: Delivery to following addresses attempted:" count)     (dolist (addr (first status))       (format t "~%  ~A" (send addr :string-for-message)))     (cond ((and (null (second status)) (null (third status)))    (format t "~2%Message delivered successfully to all recipients."))   (t    (when (second status)      (format t "~2%Delivery to the following addresses failed:")      (dolist (addr (second status))(format t "~%  ~A" (send addr :string-for-message))))    (when (third status)      (format t "~2%Message queued for later delivery to the following addresses:")      (dolist (addr (third status))(format t "~%  ~A" (send addr :string-for-message))))))))))  (format t "~%Done.")  dis-none)(defcom COM-MAIL-TEMPLATE-MENU"Choose from a menu of mail templates.  Create buffer of proper typeand select it."()  (let ((symbol (w:menu-choose *mail-template-item-list* :label "Choose Mail Template")))    (when symbol      (funcall (get-mail-template-function symbol))))  dis-none)(defun MAKE-MAIL-TEMPLATE-BUFFER (buffer-name template-type &optional (selectp t))  (fs:force-user-to-login)  (let* ((name (string-subst-char #\- #\Space buffer-name t)) (buffer (make-instance 'zmacs-buffer :name       (loop  for bufnam = (format nil "*~A-~D*" name (incf *mail-template-counter*)) unless (find-buffer-named bufnam) return bufnam))))    (push buffer *unsent-message-list*)    (send buffer :set-major-mode 'text-mode)    (setf (get buffer :mail-template-type) template-type)    (when (or (eq template-type :reply)      (eq template-type :forward))      (setf (get buffer :message-object) *msg*))    (when selectp       (send buffer :select)      (turn-on-mode 'mail-mode)      (when *mail-mode-hook*(funcall *mail-mode-hook*)))  buffer));;;;;; Mail templates;;;;;; This needs to be moved to a ZWEI file for next release(defmethod (interval-stream :set-point) (bp)  (move-bp (buffer-point **interval**) bp))(define-mail-template DEFAULT-MAIL-TEMPLATE "Mail" :mail  "Send a new mail message."                           (insert-default-header-fields (point))  (insert-header-field  (point) :to nil nil)  (move-bp (mark) (point))  (insert-moving (point) #\return)  (insert-header-field (point) :cc)  (insert-header-field (point) :subject)  (insert-moving (point) #\return)  (move-bp (point) (mark)))(define-mail-template DEFAULT-FORWARD-TEMPLATE "Forward" :forward  "Forward the current message to another user.  With a prefix arg, headers of inserted message arenot reformatted."    (or *msg* (barf "There is no message to forward."))  (insert-default-header-fields (point));Questionable whether to exclude :FCC and :BCC.  (assure-message-parsed *msg*)  (insert-header-field  (point) :to nil nil)  (move-bp (mark) (point))  (insert-moving (point) #\return)  ;;(insert-header-field (point) :subject (get-message-header *msg* :subject :interval))  ;;  MM/Babyl-style forwarding subject.  (let ((from    (get-message-header *msg* :from :interval))(subject (get-message-header *msg* :subject :interval)))    (insert-header-field (point) :subject "[" nil)    (when from      (insert-interval-moving (point) from)      (insert-moving (point) ":  "))    (when subject      (insert-interval-moving (point) subject))    (insert-moving (point) "]"))  (insert-moving (point) #\return)  (insert-moving (point) #\return)  (when (stringp *forwarded-message-begin*)    (insert-moving (point) #\return)    (insert-moving (point) *forwarded-message-begin*)    (insert-moving (point) #\return)    (insert-moving (point) #\return))  ;; insert forwarded message   (with-open-stream (out (interval-stream-into-bp (point)))    (print-formatted-message *msg* out nil nil (not *numeric-arg-p*)))  (move-bp (point) (interval-last-bp *interval*))  (insert-moving (point) #\return)  (when (stringp *forwarded-message-end*)    (insert-moving (point) *forwarded-message-end*)    (insert-moving (point) #\return)    (insert-moving (point) #\return))  (move-bp (point) (mark))  dis-none);;; Note that the reply templates completely ignore Resent-xxx: fields.  This is what;;; MM, Babyl, RMAIL, and berzerkly mail all do -- so let's join the club.(define-mail-template DEFAULT-REPLY-TO-SENDER-TEMPLATE "Reply To Sender" :reply  "Reply only to the sender of the current message."    (or *msg* (barf "There is no message to reply to."))  (assure-message-parsed *msg* t)  (insert-default-header-fields (point))  (let* ((to (collect-message-addresses *msg* '(:reply-to :from :sender) t)) (subject (get-message-header *msg* :subject :interval)))    (if to(insert-address-list (point) :to to)(insert-header-field (point) :to))    (insert-header-field (point) :subject nil nil)    (when subject       (if (not (search (interval-first-bp subject) "RE:" nil nil nil (interval-last-bp subject)))  (insert-moving (point) "Re: "))      (insert-interval-moving (point) subject))    (insert-moving (point) #\return)    (insert-in-reply-to-field *msg*)    (insert-moving (point) #\return)))(define-mail-template DEFAULT-REPLY-TO-ALL-TEMPLATE "Reply To All" :reply  "Reply to all recipients of the current message."    (or *msg* (barf "There is no message to reply to."))  (assure-message-parsed *msg* t)  (insert-default-header-fields (point))  (let* ((to (collect-message-addresses *msg* '(:reply-to :from :sender) t)) (exclude (nconc (copy-list to) *dont-reply-to*)) (cc (collect-message-addresses *msg* *reply-to-all-header-types* nil exclude)) (subject (get-message-header *msg* :subject :interval)))    (when to      (insert-address-list (point) :to to))    (when cc          (insert-address-list (point) :cc cc))    (insert-header-field (point) :subject nil nil)    (when subject       (if (not (search (interval-first-bp subject) "RE:" nil nil nil (interval-last-bp subject)))  (insert-moving (point) "Re: "))      (insert-interval-moving (point) subject))    (insert-moving (point) #\return)    (insert-in-reply-to-field *msg*)    (insert-moving (point) #\return)))(defun INSERT-IN-REPLY-TO-FIELD (msg)   (when *in-reply-to-template*     (insert-header-field (point) :in-reply-to nil nil)     (loop for element in *in-reply-to-template*   doing (cond ((stringp element)(insert-moving (point) element))       ((member element '(:date :from :to :message-id) :test #'eq)(insert-interval-moving (point) (get-message-header msg element :interval "??")))       ((eq element :phrase)(let ((from-addr (first (get-message-header msg :from :address-list))))  (if from-addr      (insert-moving (point) (or (send from-addr :send-if-handles :name) (send from-addr :address-string)))      (insert-interval-moving (point) (get-message-header msg :from :interval "??"))))))   finally (insert-moving (point) #\return))))(define-mail-template DEFAULT-RESEND-TEMPLATE "Resend" :mail  "Send current message again."  (or *msg* (barf "There is no message to resend"))  (insert-default-header-fields (point) :reply-to :bcc :from :fcc)  (with-open-stream (out (interval-stream-into-bp (point)))    (let ((*reformat-headers-body-goal-column* *mail-template-header-body-goal-column*))      (print-formatted-message *msg* out nil :headers)))  (move-bp (point) (interval-last-bp *interval*))  (insert-header-field (point) :resent-from (send (mail:default-from-address) :string-for-message))  (insert-header-field (point) :resent-to nil nil)  (move-bp (mark) (point))  (insert-moving (point) #\return)  (insert-moving (point) #\return)  (with-open-stream (out (interval-stream-into-bp (point)))    (print-formatted-message *msg* out nil :text))  (move-bp (point) (mark)))(define-mail-apply-command FORWARD   (:name "Forward"    :function multi-message-forward-template    :message-arg :once)  "Forward all marked messages to another user.")(defun MULTI-MESSAGE-FORWARD-TEMPLATE ()    (or *msgs* (barf "There are not multiple messages to forward."))    (make-mail-template-buffer "Multi-Forward" :reply t)  (insert-default-header-fields (point));Questionable whether to exclude :FCC and :BCC.  (insert-header-field  (point) :to nil nil)  (move-bp (mark) (point))  (insert-moving (point) #\return)  (insert-header-field (point) :subject)    (dolist (msg *msgs*)    (insert-moving (point) #\return)    (when (stringp *forwarded-message-begin*)      (insert-moving (point) #\return)      (insert-moving (point) *forwarded-message-begin*)      (insert-moving (point) #\return)      (insert-moving (point) #\return))    ;; insert forwarded message     (with-open-stream (out (interval-stream-into-bp (point)))      (print-formatted-message msg out))    (move-bp (point) (interval-last-bp *interval*))    (insert-moving (point) #\return)    (when (stringp *forwarded-message-end*)      (insert-moving (point) *forwarded-message-end*))    (insert-moving (point) #\return))  (move-bp (point) (mark))  (setf (get *interval* :message-object-list) *msgs*)  (send *interval* :not-modified)  dis-text)(define-mail-apply-command REPLY   (:name "Reply"    :function multi-message-reply-template    :message-arg :once)  "Reply to all recipients of all marked messages.")(defun MULTI-MESSAGE-REPLY-TEMPLATE ()    (or *msgs* (barf "There are not multiple messages to reply to."))  (make-mail-template-buffer "Multi-Reply" :reply t)    (assure-message-parsed (car *msgs*) t)  (insert-default-header-fields (point))  (let ((subject (get-message-header (car *msgs*) :subject :interval))(exclude (copy-list *dont-reply-to*))to cc all-to all-cc)    (dolist (msg *msgs*)      (assure-message-parsed msg t)      (setq to (collect-message-addresses msg '(:reply-to :from :sender) t exclude))      (setq exclude (nconc exclude (copy-list to)))      (setq cc (collect-message-addresses msg *reply-to-all-header-types* nil exclude))      (setq exclude (nconc exclude (copy-list cc)))      (setq all-to (nconc all-to to))      (setq all-cc (nconc all-cc cc)))    (when all-to      (insert-address-list (point) :to all-to))    (when cc          (insert-address-list (point) :cc all-cc))    (insert-moving (point) "Subject: ")    (when subject       (if (not (search (interval-first-bp subject) "RE:" nil nil nil (interval-last-bp subject)))  (insert-moving (point) "Re: "))      (insert-interval-moving (point) subject))    (setf (get *interval* :message-object-list) *msgs*)    (insert-moving (point) #\return)    (insert-moving (point) #\return))  dis-text)(defun MAIL-THING (&optional user thing subject other-headers)    (make-mail-template-buffer "Mail" :mail t)  (insert-default-header-fields (point))  (insert-header-field (point) :to user)  (when subject    (insert-header-field (point) :subject subject))  (dolist (header other-headers)    (insert-moving (point) header)    (insert-moving (point) #\Return))  (insert-moving (point) #\Return)  (when thing    (if (streamp thing)(stream-copy-until-eof thing (interval-stream-into-bp (point)))      (insert-thing (point) (if (stringp thing)thing      (format nil "~%~A~%" thing))))))(defun UNSENT-MESSAGES ()  (setq *unsent-message-list*(delete-if #'(lambda (buf) (get buf :killed))   (the list *unsent-message-list*))))(defun SENT-MESSAGES ()  (setq *sent-message-list*(delete-duplicates   (delete-if #'(lambda (buf) (get buf :killed))     (the list *sent-message-list*)))))(defun MAYBE-CONTINUE-UNSENT-MESSAGE (&optional type)    (let ((unsent (unsent-messages)))    (cond ((and unsent(null type)*unsent-message-query-p*(y-or-n-p "Continue editing last unsent message?"))   (setf (get (car unsent) :buffer-of-mail-command) (if (mail-reader-buffer-p *interval*)     (message-sequence-of *interval*)   nil))   (send (car unsent) :select)   t)  (unsent   (format *query-io* "~&There ~:[are~;is~] ~D other unsent message~:P.  Press ~A for a list."   (= (length unsent) 1) (length unsent)   (key-for-command 'com-list-mail-buffers *zmacs-comtab* nil nil #\C-X))   nil)  (t   nil))))(defun GET-MAIL-TEMPLATE-FUNCTION (symbol &optional (errorp t))    (or (get symbol :mail-template-function)      (if errorp  (ferror 'mail-reader-error  "Mail template ~S has no :mail-template-function property" symbol)  nil)))(defun INSERT-ADDRESS-LIST (bp header-type address-list &optional (trailing-cr-p t))    (when header-type    (insert-moving bp (nstring-capitalize (format nil "~A:~VT" header-type *mail-template-header-body-goal-column*))))  (insert-moving bp (send (first address-list) :string-for-message))  (dolist (address (rest address-list))    (insert-moving bp #\,)    (insert-moving bp #\return)    (insert-moving bp "         ")    (insert-moving bp (send address :string-for-message)))  (when trailing-cr-p    (insert-moving bp #\return)))(defun INSERT-HEADER-FIELD (bp header-type &optional contents (trailing-cr-p t))  (insert-moving bp (nstring-capitalize (format nil "~A:~VT" header-type  *mail-template-header-body-goal-column*)))  (when contents    (move-bp bp (insert-thing bp contents)))  (when trailing-cr-p    (insert-moving bp #\return)))(defun INSERT-DEFAULT-HEADER-FIELDS (bp &rest not-these-fields)  "Inserts defaults for From, Reply-To, FCC, and BCC fields unless thefield in question is a member of NOT-THESE-FIELDS."  (declare (list not-these-fields))  (when (and (stringp *default-fcc-string*)     (not (member :fcc not-these-fields :test #'eq)))    (insert-header-field bp :fcc *default-fcc-string*))  (when (and (stringp *default-reply-to-string*)     (not (member :reply-to not-these-fields :test #'eq)))    (insert-header-field bp :reply-to *default-reply-to-string*))  (when (and (stringp *default-bcc-string*)     (not (member :bcc not-these-fields :test #'eq)))    (insert-header-field bp :bcc *default-bcc-string*))  (when (not (member :from not-these-fields :test #'eq))    (insert-header-field bp :from (send (mail:default-from-address) :string-for-message))));;; For easy use as predicates in sequence functions(defun HEADER-TYPEP (header type)  (if (consp type)      (memeq (send header :type) type)      (eq type (send header :type))))    (defun TYPE-HEADERP (type header)  (if (consp type)      (memeq (send header :type) type)      (eq type (send header :type))))(defvar mail-mode-mouse-menu-alist  '(("Mail Commands" :no-select t :font TR12b)    ("Send mail" . com-send-mail)    ("Abort this message" . com-mail-mode-exit)    ("" :no-select t)    ("Zmacs Commands" :no-select t :font TR12b)    ("Arglist" . com-arglist)    ("Edit Definition" . com-edit-definition)    ("List Callers" . com-list-callers)    ("List Sections" . com-list-sections)    ("List Buffers" . com-list-buffers)    ("Kill or Save Buffers" . com-kill-or-save-buffers)    ("Split Screen" . com-split-screen)    ("Compile Region" . com-compile-region)    ("Indent Region" . com-indent-region)    ("Change Default Font" . com-change-default-font)    ("Change Font Region" . com-change-font-region)    ("Uppercase Region" . com-uppercase-region)    ("Lowercase Region" . com-lowercase-region)    ("Indent Rigidly" . com-mouse-indent-rigidly)    ("Indent Under" . com-mouse-indent-under)))(defprop com-mail-mode-general-mouse-menu "General Menu" :mouse-short-documentation); Paranoia.(defcom com-mail-mode-general-mouse-menu "A menu of general mail mode commands + Zmacs commands." ()  (let (command)    (using-resource (menu menu-command-menu mail-mode-mouse-menu-alist)      (send menu :set-label "General Mail Mode Menu")      (send menu :set-geometry t t nil)      (setq command (funcall menu :choose)))    (cond (command   (funcall command))  (t   dis-none))))(defcom com-mail-mode-documentation"Handle help key" ()    (let ((*com-documentation-alist*       (cons '(#\M com-mail-mode-help) *com-documentation-alist*))) (com-documentation))  dis-none)#|(defun BUG ()  "Create A bug report editor frame and go to it from Lisp"  (fs:force-user-to-login)  (let ((sheet (find-or-create-idle-zmacs-window)))    (send sheet :select)    (send sheet :force-kbd-input `(:execute com-bug))))(defcom COM-BUG"Mail a bug report." ()  (bug-report-template))(define-mail-template bug-report-template "Bug" :mail  "This is the bug report template received from META-X Bug."  (turn-on-mode 'overwrite-mode)  (insert-moving (point) "TO      : ")  (move-bp (mark) (point))  (insert-moving (point) #\return)  (insert-moving (point) "CC      : ")  (insert-moving (point) #\return)  (insert-moving (point) "SUBJECT : ")  (insert-moving (point) #\return)  (insert-moving (point) #\return)  (insert-moving (point) "                                         EXPLORER (TM) BUG REPORT")  (dotimes (count 3 nil)    (insert-moving (point) #\return))  (insert-moving (point) "CUSTOMER TRACKING ID:  ")  (insert-moving (point) #\return)  (insert-moving (point) "SUBMITTER NAME:  ")  (when (and (not (equal fs:user-personal-name-first-name-first ""))     (not (null fs:user-personal-name-first-name-first)))    (insert-moving (point) (format nil "~a"  fs:user-personal-name-first-name-first)))  (insert-moving (point) #\return)  (insert-moving (point) "LOCATION:  ")  (when (and (not (equal (global:short-site-name) ""))     (not (null (global:short-site-name))))    (insert-moving (point) (format nil "~a" (global:short-site-name))))  (dotimes (count 3 nil)    (insert-moving (point) #\return))  (insert-moving (point) "                                                        ______________________________")  (insert-moving (point) #\return)  (insert-moving (point) "ADDRESS:  __________________________________            |  TI Internal Use Only      | ")  (insert-moving (point) #\return)  (insert-moving (point) "          __________________________________            | BUG NUMBER: _________      | ")  (insert-moving (point) #\return)  (insert-moving (point) "          __________________________________            | Received: ___/___/___      | ")  (insert-moving (point) #\return)  (insert-moving (point) "                                                        | Entered: ___/___/___       | ")  (insert-moving (point) #\return)  (insert-moving (point) "                                                        ------------------------------ ")  (insert-moving (point) #\return)  (insert-moving (point) "PHONE:  (___)___-____")  (insert-moving (point) #\return)  (insert-moving (point) #\return)  (insert-moving (point) (format nil "LOCAL NAME OR ID:  ~a"  si:local-host))  (dotimes (count 2 nil)    (insert-moving (point) #\return))  (insert-moving (point) "System Software Configuration (give version number and patch level):")  (dotimes (count 2 nil)    (insert-moving (point) #\return))  (insert-moving (point) "   FILE Band: __________ LOD Band: __________ MCR Band: __________ BOOT Band: __________")  (dotimes (count 2 nil)    (insert-moving (point) #\return))  (insert-moving (point) "         Diag Band: __________     GDOS Band: __________    EXPT Band __________")  (dotimes (count 2 nil)    (insert-moving (point) #\return))  (insert-moving (point) "   TI & 3rd Party Software Installed: _________________________________")  (dotimes (count 3 nil)    (insert-moving (point) #\return))  (insert-moving (point) "           TYPE OF PROBLEM (CHECK ONE)")  (insert-moving (point) #\return)  (insert-moving (point) #\return)  (insert-moving (point) "              ___ = DOCUMENTATION DEFICIENCY.  SEE DOCUMENT: _______________________")  (insert-moving (point) #\return)  (insert-moving (point) "              ___ = SOFTWARE DESIGN REQUEST")  (insert-moving (point) #\return)  (insert-moving (point) "              ___ = SOFTWARE BUG")  (insert-moving (point) #\return)  (insert-moving (point) "              ___ = HARDWARE DESIGN REQUEST")  (insert-moving (point) #\return)  (insert-moving (point) "              ___ = HARDWARE BUG")  (insert-moving (point) #\return)  (insert-moving (point) "              ___ = OTHER.  EXPLAIN: _______________________________________________")  (insert-moving (point) #\return)  (insert-moving (point) #\return)  (insert-moving (point) "           PRIORITY OF PROBLEM:  (H)igh (M)edium (L)ow:  __")  (dotimes (count 4 nil)    (insert-moving (point) #\return))  (insert-moving (point) (format nil "DESCRIPTION OF PROBLEM:  (ATTACH SUPPORTING DOCUMENTS, EXPLORER BUG REPORT FILES ~%                         OR ANY ADDITIONAL SHEETS)"))  (dotimes (count 14 nil)    (insert-moving (point) #\return))  (insert-moving (point) "           WORK AROUND? (YES/NO): ___  IF YES, BRIEFLY DESCRIBE IT:")  (dotimes (count 5 nil)    (insert-moving (point) #\return))  (insert-moving (point) "ARE THERE ANY ATTACHMENTS TO THE BUG REPORT? (YES/NO): ___ NUMBER OF PAGES: ___")  (insert-moving (point) #\return)  (insert-moving (point) "           DESCRIPTION OF ATTACHMENTS:  ")  (dotimes (count 4 nil)    (insert-moving (point) #\return))  (let ((system-description (si:system-version-info)))    (loop with line-start = 0  for start = 0 then (+ comma-pos 2)  as prev-comma-pos = nil then comma-pos  as comma-pos = (position ", " system-description start)  when (> (- (or comma-pos (string-length system-description )) line-start) 72.)  unless (null prev-comma-pos)  do (aset #\cr system-description (1+ prev-comma-pos))  (setq line-start (+ prev-comma-pos 2))  (setq comma-pos prev-comma-pos)  until (null comma-pos))    (insert-moving (point) (format nil "~a" system-description)))  (insert-moving (point) #\return)  (insert-moving (point) (format nil "~a" (mail:get-revv)))  (dotimes (count 3 nil)    (insert-moving (point) #\return))  (insert-moving (point) "                     ******************************************")  (insert-moving (point) #\return)  (insert-moving (point) "                     *              RETURN TO:                *")  (insert-moving (point) #\return)  (insert-moving (point) "                     *                                        *")  (insert-moving (point) #\return)  (insert-moving (point) "                     *       EXPLORER BUG REPORTS             *")  (insert-moving (point) #\return)  (insert-moving (point) "                     *       c/o Explorer Project Manager     *")  (insert-moving (point) #\return)  (insert-moving (point) "                     *       TEXAS INSTRUMENTS, M/S 2201      *")  (insert-moving (point) #\return)  (insert-moving (point) "                     *       P.O. Box 2909                    *")  (insert-moving (point) #\return)  (insert-moving (point) "                     *       Austin, Texas  78769             *")  (insert-moving (point) #\return)  (insert-moving (point) "                     ******************************************")  (move-bp (point) (mark)));bug-report-template|#     (when old-inbox-p       (setq backup-truename (send in-stream :truename)))     (setq status (send buffer :read-mail-file file-format in-stream))))      (cond ((neq status :eof)     (utter t "~&~%Inbox not completely read.  Status = ~A" status))    (t     (when backup-truename       (pushnew backup-truename (get buffer :old-inbox-truenames)))     (when (not old-inbox-p)       (pushnew pathname (get buffer :inboxes-read)))     (when delete-after-read-p       (close in-stream)       (let ((outcome (send pathname :delete nil))) (if (and (errorp outcome)  (not (condition-typep outcome 'fs:open-deleted-file))  (not (condition-typep outcome 'fs:file-not-found)))     (utter t "~&~%Warning: Could not delete inbox ~A -- ~A~%This may cause duplicate messages later."    pathname outcome)   (if (send pathname :undel