LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031608. :SYSTEM-TYPE :LOGICAL :VERSION 13. :TYPE "LISP" :NAME "COMMAND" :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 2758716293. :AUTHOR "REL3" :LENGTH-IN-BYTES 85591. :LENGTH-IN-BLOCKS 84. :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.(eval-when (load)   (set-comtab *zmacs-control-x-comtab*  '(#\C-M com-list-mail-buffers    #\M com-mail))     (set-comtab *zmacs-comtab*  '(#\C-M-M com-enter-mail-reader)  '(("Read Mail" . com-read-mail)    ("List Mail Buffers" . com-list-mail-buffers)    ("Mail Summary" . com-mail-summary)    ("Mail Buffer" . com-mail-buffer)    ("Mail" . com-mail)    ("Mail Template" . com-mail-template-menu)    ("Mail Mode" . com-mail-mode)    ("Read Mail Mode" . com-read-mail-mode))))(eval-when (load)  (setq *read-mail-control-x-comtab* (set-comtab 'read-mail-control-x-comtab'(#\C-E com-expunge-mail-buffer  #\C-S com-save-mail-file  #\C-W com-write-mail-file  #\B   com-select-buffer-from-mail  #\K   com-kill-mail-buffer  #\C-R com-revert-mail-buffer  #\Scom-sort-messages  #\2   com-two-windows-from-mail  #\R   :undefined;? what's the right way to undefine a key?  )))  (set-comtab-indirection *read-mail-control-x-comtab* *zmacs-control-x-comtab*))(eval-when (load)  (setq *read-mail-comtab-list* '(("Help" . com-read-mail-help)  ("List Reminders" . com-list-reminders)  ("Change Inboxes" . com-change-inboxes)  ("Delete Keyword From All Messages" . com-delete-keyword-from-all-messages)  ("Reply To All" . com-reply-to-all)  ("Reply To Sender" . com-reply-to-sender)  ("Resend Message" . com-resend-message)  ("Mail Template Menu" .  com-mail-template-menu)  ("Change Message Attributes" . com-change-message-attributes)  ("Redisplay Mail Summary" . com-revert-mail-summary)  ("Set Mail File Owner" . com-set-mail-file-owner)  ("Set Mail File Format" . com-set-mail-file-format)  ("Change File Options" . com-change-file-options)  ("Babyl Mode" . com-babyl-mode)  ("Next Message" . com-next-message)  ("Previous Message" . com-previous-message)  ("Next Undeleted" . com-next-undeleted-message)  ("Previous Undeleted" . com-previous-undeleted-message)  ("Next Unseen" . com-next-unseen)  ("Previous Unseen" . com-previous-unseen)  ("View Message" . com-view-message)  ("Next Message with Keyword" . com-next-message-with-keyword)  ("Previous Message with Keyword" . com-previous-message-with-keyword)  ("Change Keywords" . com-change-message-keywords)  ("Copy Message" . com-copy-message-to-mail-file)  ("Copy Message To Text File" . com-copy-message-to-text-file)  ;;("Delete Messages with Keywords" . com-delete-messages-with-keywords)  ("Delete Message" . com-delete-message)  ("Delete Message Move Backward" . com-delete-message-backward)  ("Expunge Mail Buffer" . com-expunge-mail-buffer)  ("Forward Message" . com-forward-message)  ("Jump To Message" . com-jump-to-message)  ("List Messages" . com-list-messages)  ("Answered" .  com-toggle-answered-message)  ("Remind" . com-toggle-reminder-message)  ("Unseen" . com-toggle-unseen-message)  ("Apply Mail Command" . com-apply-mail-command)  ("Print Message" . com-print-message)  ("Get New Mail" . com-get-new-mail)  ("Save Mail File" . com-save-mail-file)  ("Undelete Message" . com-undelete-message)  ("Write Mail File" . com-write-mail-file)  ("Sort Messages" . com-sort-messages)  ("Exit Mail Reader" . com-exit-mail-reader)  ("Abort Mail Reader" . com-abort-mail-reader)  ("Two Mail Windows" . com-two-mail-windows)  ("One Mail Window" . com-one-mail-window)  ("Toggle Window Configuration" . com-toggle-mail-window-configuration)  ("Toggle Reminder Message" . com-toggle-reminder-message)  ("Toggle Answered Message" . com-toggle-answered-message)  ("Toggle Unseen Message" . com-toggle-unseen-message)  ("First Message" . com-first-message)  ("Last Message" . com-last-message)  ("Other Mail Buffer" . com-other-mail-buffer)  ("Next Message Screen" . com-next-message-screen)  ("Previous Message Screen" . com-previous-message-screen)  ("Change Message Keywords" . com-change-message-keywords)  ("Reformat Message Headers" . com-reformat-message-headers)  ("Edit Message" . com-edit-message)  ("Incremental Search All Messages" . com-mail-incremental-search)  ("Mark Message For Apply" . com-mail-mark-for-apply)  ("Execute Message Operations" . com-mail-execute)  ("Apply Command to Marked Messages" . com-apply-mail-command)  ("Print Message" . com-print-message)  ("Mail Menu" . com-mail-menu)  ("Message Menu" . com-message-menu)  ("Sort Messages" . com-sort-messages)  )))(eval-when (load)  (setq *read-mail-comtab* (set-comtab 'read-mail-comtab       '(#\1 com-numbers #\2 com-numbers #\3 com-numbers #\4 com-numbers #\5 com-numbers #\6 com-numbers #\7 com-numbers #\8 com-numbers #\9 com-numbers #\0 com-numbers #\- com-negate-numeric-arg #\? com-mail-documentation #\A com-mail-mark-for-apply #\B com-list-mail-buffers #\C com-copy-message-to-mail-file #\D com-delete-message #\E com-edit-message #\F com-forward-message   #\G com-get-new-mail #\H com-reformat-message-headers #\I com-read-mail #\J com-jump-to-message #\K com-change-message-keywords #\M com-mail #\N com-next-undeleted-message #\O com-other-mail-buffer #\P com-previous-undeleted-message #\Q com-exit-mail-reader #\R com-reply-to-message #\S com-save-mail-file #\C-Sh-P com-print-message #\U com-undelete-message #\V com-view-message #\W com-write-mail-file #\X com-mail-execute #\Z com-total-messages #\= com-filter-messages #\< com-first-message #\> com-last-message #\* com-toggle-unseen-message #\! com-toggle-reminder-message #\C-C com-copy-message-to-text-file #\C-D com-delete-message-backward #\C-W com-toggle-mail-window-configuration #\C-N com-mail-down-real-line #\C-P com-mail-up-real-line #\M-N com-next-message #\M-P com-previous-message #\M-S com-mail-incremental-search #\M-R com-mail-reverse-incremental-search #\C-M-N com-next-unseen #\C-M-P com-previous-unseen #\S-N com-next-message-with-keyword #\S-P com-previous-message-with-keyword #\Help com-mail-documentation #\Rubout com-previous-message-screen #\Space com-next-message-screen #\End com-exit-mail-reader #\Abort com-abort-mail-reader #\mouse-L-1 com-mouse-select-or-mark #\Mouse-R-1 com-mail-menu #\Mouse-M-1 com-message-menu )       *read-mail-comtab-list*))  (set-comtab *read-mail-comtab* (list #\c-x (make-extended-command *read-mail-control-x-comtab*)))  (set-comtab-indirection *read-mail-comtab* *zmacs-comtab*))(defmajor com-read-mail-mode read-mail-mode "Read-Mail"  "Major mode for reading mail files." ()    (setq *comtab* *read-mail-comtab*)    (set-mouse-documentation)    (set-mode-line-list    '("ZMACS (" *mode-name-list* ") "      *zmacs-buffer-name* *zmacs-buffer-version-string*      " (" (*msg* "Message " *message-number* "/" *message-count*  *message-deleted* *message-unseen* *message-reminder* *message-answered* *message-filed*  *message-print* *message-apply*  *message-keywords-check* *message-keywords*)      ") "      (*macro-level* "  Macro-level: " *macro-level*)      *more-above-below* *mail-file-modified-p*      ))  )(defcom COM-READ-MAIL"Input a specified mail file into a separate mail file buffer."()  (let ((pathname (read-defaulted-pathname "Read mail file:" (default-other-mail-file) nil :newest :new-ok)))    (setq pathname (fs:merge-pathname-defaults pathname))    (setq *default-other-mail-file* pathname)    (get-mail-file pathname))  dis-none)(defcom COM-MAIL-SUMMARY"Prompt for mail file pathname and edit it in Read-Mail mode using the summary buffer."()  (let ((*user-mail-reading-mode* :summary))    (com-read-mail)))(defcom COM-MAIL-BUFFER"Prompt for mail file pathname and edit it in Read-Mail mode using the message buffer."()  (let ((*user-mail-reading-mode* :message))    (com-read-mail)))(defcom COM-ENTER-MAIL-READER"Find default mail file buffer or read in the default mail file."()  (get-mail-file)  dis-text)(defun GET-MAIL-FILE (&optional mail-file)    (fs:force-user-to-login)  (cond ((stringp mail-file) (setq mail-file (parse-namestring mail-file)))((null mail-file) (setq mail-file (default-mail-file))))  (let ((buffer (find-file-buffer mail-file)))    (cond (buffer   (make-mail-buffer-current buffer)   (when *always-check-inboxes*     (com-get-new-mail)))  (t      (setq buffer (find-mail-file mail-file t nil t))   (when buffer     (let ((inboxes (get-mail-option buffer :mail))   (owner (get-mail-option buffer :owner)))       (cond ((and inboxes owner   (not (lisp:search user-id owner :test #'string-equal)))      (format *query-io* "~&This mail file belongs to ~A.  Not reading inboxes." owner))     (inboxes      (when (or (fs:pathname-equal (buffer-pathname buffer) (default-mail-file))(y-or-n-p "This is not your default mail file.  Read inboxes anyway?"))(format *query-io* "~&Checking inboxes.")(let ((*numeric-arg-p* :digits)      (*numeric-arg* -1))  (com-get-new-mail))))));;  Find-mail-file and make-mail-buffer-current both already do this. ;;(make-mail-buffer-current buffer (default-mail-window-configuration))     (case (buffer-mail-file-format buffer)       (:unix(unless *inhibit-mail-file-format-warnings*  (format t  "~&This is a UNIX format mail file.  If you add keywords, inboxes, or other BABYL options, theycannot be saved back to the file.  You can convert this file to BABYL format usingM-X Set Mail File Format.~%")))       (:tops(unless *inhibit-mail-file-format-warnings*  (format t  "~&This is a TOPS format mail file.  It can be read but not written back to disk.You can convert this file to BABYL format using M-X Set Mail File Format.~%"))))     (format *query-io* "~&Press HELP M for Mail Reader help."))))    buffer))(defcom COM-SET-MAIL-FILE-FORMAT"Change the mail file format of the current mail buffer.  Takes effect next time file is saved."()  (in-mail-context (:require-buffer t)    (let* ((buffer (mail-file-buffer-of *mail-buffer*))   (format (mail-file-format-query *writable-mail-file-formats*   "Change ~A to what mail file format? " buffer)))      (case format(:unix (format t "~&Note: In Unix format, message keywords, inboxes, and other information which may becontained in this buffer cannot be saved in the mail file.  The contents of allmessages will remain intact.") (setf (buffer-mail-file-format buffer) format))(:tops (beep) (format t "~&TOPS mail file format can be read but not written.  Format not changed."))(:otherwise (setf (buffer-mail-file-format buffer) format)))      (mung-node buffer))    (values dis-none dis-none)))(defcom COM-SET-MAIL-FILE-OWNER"Change the owner of the current mail file."()  (setf (get-mail-option (mail-file-buffer-of *mail-buffer*) :owner)(let ((*mini-buffer-dont-record* t))  (typein-line-readline "New owner for this mail file:")))  dis-none)(defcom COM-EXIT-MAIL-READER"Return to mail file buffer or default viewing mode or completely exit mail reader."()  (in-mail-context (:require-buffer t)    (when (and *msg* (mail-buffer-window *mail-buffer*))      (delete-message-attribute :unseen *msg*))    (cond ((two-mail-reader-windows-p *mail-buffer*)   (cond ((mail-file-buffer-p *mail-buffer*)  (setf (get *mail-buffer* :prev-mail-window-configuration) :both)  (exit-mail-reader t)) (t  (make-mail-buffer-current (mail-file-buffer-of *mail-buffer*) :both))))  ((and (mail-summary-p *interval*)(eq (default-mail-window-configuration) :message))   (make-mail-buffer-current *mail-buffer* :message))  ((and (message-sequence-p *interval*)(eq (default-mail-window-configuration) :summary))   (make-mail-buffer-current *mail-buffer* :summary))  ((not (mail-file-buffer-p *mail-buffer*))   (make-mail-buffer-current (mail-file-buffer-of *mail-buffer*)))  (t   (setf (get *mail-buffer* :prev-mail-window-configuration) (if (message-sequence-p *interval*)     :message :summary))   (exit-mail-reader)))        (values dis-text dis-text)))(defun EXIT-MAIL-READER (&optional clean-up-windows (execute t) (maybe-save t))    (when (and execute (> (total-messages *mail-buffer*) 0))    (com-mail-execute))  (when maybe-save    (maybe-save-mail-buffer-in-background (mail-file-buffer-of *mail-buffer*)))  (when clean-up-windows    (clean-up-mail-windows-for-exit))  (when (mail-file-buffer-p *mail-buffer*)    (dolist (buffer (buffer-subsequences *mail-buffer*))      (hide-mail-buffer buffer)))  (hide-mail-buffer (mail-file-buffer-of *mail-buffer*) nil)  (send (history-latest-element (send *window* :buffer-history)) :select))(defcom COM-ABORT-MAIL-READER"Exit mail reader immediately without saving mail file.If a macro is in progress, a region exists, a prefix arg is in progress, or typeout is exposed, clean up don't exit."()  (in-mail-context (:require-buffer t)    (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   (exit-mail-reader t nil nil)   ;; Return to defaults   (setf (get (mail-file-buffer-of *mail-buffer*) :prev-mail-window-configuration) nil)   (setf (get (mail-file-buffer-of *mail-buffer*) :prev-selected-message-sequence) nil)))    ;;Avoid running in-mail-context epilog    (return-from com-abort-mail-reader dis-text)))(defcom COM-GET-NEW-MAIL"Get new mail from the inbox(es) associated with this mail file and select the first new message.With positive prefix arg, prompt for file name to read mail from -- it will not be deleted.With negative prefix arg, re-read old inboxes too."()  (in-mail-context (:require-buffer t)          (get-new-mail (current-mail-file-buffer)    nil    (if (and *numeric-arg-p* (>= *numeric-arg* 0))(let* ((*mini-buffer-dont-record* t)       (file (read-defaulted-pathname "Read inbox file:"      (default-other-mail-file))))  (setq *default-other-mail-file* file)  file))    (and *numeric-arg-p* (minusp *numeric-arg*)))      (values dis-text dis-text)))(defun GET-NEW-MAIL (buffer &optional quietly inbox-path force-read-old-inboxes)    (when (stringp inbox-path)    (setq inbox-path (fs:merge-pathname-defaults inbox-path)))    (let ((append-p (append-new-mail-p buffer))(old-last (last-message buffer))new-msgs)    (setq new-msgs  (if inbox-path      (read-inbox inbox-path buffer)    (read-inboxes buffer force-read-old-inboxes)))        (cond ((> new-msgs 0)   (unless quietly     (format *query-io* "~&~D new message~:P read." new-msgs))   ;; Select first new message   (cond ((or (not append-p) (null old-last))  ;; Prepended (or buffer was empty); go to first message  (select-message 0 buffer)) ((not (null old-last))  ;; Appended; go to the message following the "old" last message  (select-message old-last buffer)  (select-next-message buffer)))   (if (mail-summary-of buffer)       (update-summary (mail-summary-of buffer))))  (t    (unless quietly     (format *query-io* "~&No new mail."))   (values dis-none dis-none)))))(defcom COM-SAVE-MAIL-FILE"Save the mail file buffer to disk.  With any prefix arg, perform the save in background."()  (in-mail-context (:require-buffer t)    (let ((file-buffer (current-mail-file-buffer)))      (cond ((and (not (symbolp (buffer-file-id file-buffer)))  (not (buffer-needs-saving-p file-buffer)))     (format *query-io* "~&(No changes need to be written.)")     (values dis-none dis-none))    (t;     (if *numeric-arg-p* ; (maybe-save-mail-buffer-in-background (mail-file-buffer-of *mail-buffer*) :always);       (write-mail-file-buffer nil file-buffer))     ;;  Just do save-buffer, which will end up calling write-mail-file-buffer anyway.     ;;  This way, we always go through the same function, which also checks file-ids.     (save-buffer file-buffer)     (values dis-none dis-none))))))(defcom COM-WRITE-MAIL-FILE"Write the mail buffer into another file."()  (in-mail-context (:require-buffer t)        (let ((file-buffer (current-mail-file-buffer))  (*mini-buffer-dont-record* t))      (write-mail-file-buffer (read-defaulted-pathname (format nil "Write buffer ~A to file:" (buffer-name file-buffer)) (pathname-defaults *pathname-defaults* file-buffer) nil :newest :write)file-buffer)))  (values dis-none dis-none));;; This exits only to change the default prompt(defcom COM-KILL-MAIL-BUFFER"Kill a specified buffer."()  (let* ((*mini-buffer-dont-record* t) (buffer (read-buffer-name "Buffer to kill (RETURN to kill current buffer):"   (cond ((null *mail-buffer*) *interval*) ((filter-summary-p *interval*) (mail-file-buffer-of *interval*)) (t *mail-buffer*)))))    ;; If the buffer is associated with a file and contains changes, offer to write it out.    (and (buffer-needs-saving-p buffer) (or (consp (buffer-file-id buffer))     (not (bp-= (interval-first-bp buffer) (interval-last-bp buffer)))) (fquery `(:select t    :beep t    :type :readline    :choices ,format:yes-or-no-p-choices) "Buffer ~A has been modified, save it first? " (buffer-name buffer)) (save-buffer buffer))    ;; If buffer is current, select something else before killing.    (loop for new-buffer = buffer then (read-buffer-name "Killing the current buffer, select which other buffer?" (previous-buffer *interval* *mail-buffer*) 'maybe)  while (or (eq new-buffer *interval*) (eq new-buffer *mail-buffer*))  finally  (send new-buffer :select)  (must-redisplay *window* dis-text))    ;; Anybody who refers to this buffer should be redirected.    (send buffer :kill))  dis-none);;; This exits only to change the default prompt(defcom COM-SELECT-BUFFER-FROM-MAIL"Select the specified buffer.Does a completing read of the buffer name in the echo area.With a numeric argument, allows you to create a new buffer."()  (send (read-buffer-name "Select buffer:"  (previous-buffer *interval* *mail-buffer*)  (if *numeric-arg-p* t 'maybe)):select)  dis-text);;; This exits only to change the default prompt(defcom COM-REVERT-MAIL-BUFFER "Revert the mail file buffer from latest copy on disk.  Changes made since last save are lost."()  (let* ((*mini-buffer-dont-record* t) (buffer (read-buffer-name "Buffer to revert:"   (cond ((null *mail-buffer*) *interval*) ((filter-summary-p *interval*) (mail-file-buffer-of *interval*)) (t *mail-buffer*)))))    (revert-buffer buffer)    (if (mail-reader-buffer-p buffer)(make-mail-buffer-current *mail-buffer*)      (must-redisplay-buffer buffer dis-text))    (values dis-none dis-none)))(defcom COM-REVERT-MAIL-SUMMARY        "Recreate the summary of the current mail buffer from scratch.Use after modifying option variables which affect the summary display or if the summary becomes mangled."()  (in-mail-context (:require-buffer t)    (let ((old-summary (mail-summary-of *mail-buffer*)))      (when old-summary(send old-summary :kill))      (mail-summary-of *mail-buffer* t)      (make-buffer-current *mail-buffer*))    (values dis-none dis-text)))(defcom COM-TWO-WINDOWS-FROM-MAIL"Select two windows showing the mail buffer and some other ZMACS buffer."()  (let ((*mail-buffer-selection-mode* :in-progress))    (switch-windows)    (send (previous-buffer *interval* *mail-buffer*) :select))  dis-text)(defcom COM-TWO-MAIL-WINDOWS"Display the current mail buffer using two windows; one for summary and one for message buffer."()  (in-mail-context (:require-buffer t)    (two-mail-reader-windows *mail-buffer*)    (values dis-text dis-text)))(defcom COM-ONE-MAIL-WINDOW"Delete other windows and expand the current window to full screen.With a prefix arg, the current window (where the cursor is) is always used.Otherwise, it is controlled by the value of ZWEI:*ONE-WINDOW-DEFAULT*.It can be :TOP (select the uppermost window), :BOTTOM (the lowermost),:CURRENT (keep only the window the cursor is now in),or :OTHER (keep the uppermost window other than the one the cursor is in).The default is :CURRENT."()  (in-mail-context (:require-buffer t)    (make-mail-buffer-current *mail-buffer*      (if (message-sequence-p *interval*)  :message:summary)      nil)    (values dis-none dis-none)))(defcom COM-TOGGLE-MAIL-WINDOW-CONFIGURATION"Switch between one and two window mode."()  (if (> (length (frame-exposed-windows)) 1)      (com-one-mail-window)    (com-two-mail-windows)))(defcom COM-TOGGLE-REMINDER-MESSAGE"Toggle the Remind attribute of message.  With prefix arg, toggle remind attribute of <arg> messages." ()  (in-mail-context (:require-message t :require-buffer t)    (numeric-arg-loop (n lastp)      (cond ((message-attribute-p :remind *msg*)     (delete-message-attribute :remind *msg*))    (t     (add-message-attribute :remind *msg*)))      (unless lastp(setq *msg* (select-next-message-search :undeleted *mail-buffer* (signum n))))      (unless *msg*(return)))    (values dis-text dis-text)))(defcom COM-TOGGLE-ANSWERED-MESSAGE"Toggle the Answered attribute of message.  With prefix arg, toggle remind attribute of <arg> messages."()  (in-mail-context (:require-message t)    (numeric-arg-loop (n lastp)      (cond ((message-attribute-p :answered *msg*)     (delete-message-attribute :answered *msg*))    (t     (add-message-attribute :answered *msg*)))      (unless lastp(setq *msg* (select-next-message-search :undeleted *mail-buffer* (signum n))))      (unless *msg*(return)))    (values dis-text dis-text)))(defcom COM-TOGGLE-UNSEEN-MESSAGE"Toggle the Unseen attribute of message.With prefix arg, toggle unseen attribute of <arg> messages."()  (in-mail-context (:require-message t)    (numeric-arg-loop (n lastp)      (cond ((message-attribute-p :unseen *msg*)     (delete-message-attribute :unseen *msg*))    (t     (add-message-attribute :unseen *msg*)))      (unless lastp(setq *msg* (select-next-message-search :undeleted *mail-buffer* (signum n))))      (unless *msg*(return)))    (values dis-text dis-text)))(defcom COM-CHANGE-MESSAGE-ATTRIBUTES"Change attributes assigned to message."()  (in-mail-context (:require-message t)    (let ((attributes (read-mail-attributes "Enter attributes (separated by commas):" (message-attributes *msg*))))      (dolist (attr attributes)(when (not (memeq attr *mail-attribute-list*))  (if (not (y-or-n-p "Adding new attribute ~:@(~A~).  OK?" attr))      (setq attributes (remove attr attributes))    (push-end attr *mail-attribute-list*)    (push-end (cons (string attr) attr)  *mail-attribute-completion-alist*))))      (numeric-arg-loop (n lastp);; Following is ugle but ensures summary is updated properly -- need a set-message-attributes function.(dolist (attr (message-attributes *msg*))  (delete-message-attribute attr *msg*))(dolist (attr attributes)  (add-message-attribute attr *msg*))(unless lastp  (setq *msg* (select-next-message-search :undeleted *mail-buffer* (signum n))))(unless *msg*  (return))))    (values dis-text dis-text)))(defcom COM-FIRST-MESSAGE"Select first message in this mail buffer."(push -r)  (in-mail-context (:require-buffer t)    (select-message 0 *mail-buffer*)    (values dis-text dis-bps)))(defcom COM-LAST-MESSAGE"Select last message in this mail buffer"(push r)  (in-mail-context (:require-buffer t)    (select-message (last-message *mail-buffer*) *mail-buffer*)    (values dis-text dis-bps)))(defcom COM-TOTAL-MESSAGES"The number of messages in the buffer, suitable for a prefix argument." ()  (setq *numeric-arg* (total-messages (mail-file-buffer-of *interval*)))  (setq *numeric-arg-p* :digits)  :argument)(defcom COM-NEXT-MESSAGE"Select next message, even if deleted.With prefix arg, move forward <arg> messages."(r)  (in-mail-context (:require-buffer t)    (or      (select-next-message *mail-buffer* *numeric-arg*)      (format *query-io* "~&Last message."))    (values dis-text dis-bps)))(defcom COM-PREVIOUS-MESSAGE"Select previous message, even if deleted.With prefix arg, move backward <arg> messages."(-r)  (in-mail-context (:require-buffer t)    (or      (select-next-message *mail-buffer* (- *numeric-arg*))      (format *query-io* "~&First message."))    (values dis-text dis-bps)))(defcom COM-NEXT-UNSEEN"Display the next unseen message.  With prefix arg, move forward <arg> unseen messages."(r)  (in-mail-context (:require-buffer t)    (select-next-message-search :unseen *mail-buffer* *numeric-arg*)    (values dis-text dis-bps)))(defcom COM-PREVIOUS-UNSEEN"Display the previous unseen message.With prefix arg, move backward <arg> unseen messages."(-r)  (in-mail-context (:require-buffer t)    (select-next-message-search :unseen *mail-buffer* (- *numeric-arg*))    (values dis-text dis-bps)))(defvar *last-keywords-searched-for* nil "List of keywords from last search.");;  Exists for argument order, must be function because passed as functional argument.(defun message-has-one-of-keywords-p (keywords msg)   (keyword-or-filter msg keywords))(defcom COM-NEXT-MESSAGE-WITH-KEYWORD"Display the next message with a given keyword or keywords."(r)  (in-mail-context (:require-buffer t)    (let* ((*mini-buffer-dont-record* t)   (keywords (read-mail-keywords "Keywords to search for (separated by commas):" *last-keywords-searched-for*)))      (setq *last-keywords-searched-for* keywords)      (select-next-message-search keywords *mail-buffer* *numeric-arg* #'message-has-one-of-keywords-p)      (values dis-text dis-bps))))(defcom COM-PREVIOUS-MESSAGE-WITH-KEYWORD"Select previous message with a given keyword or keywords."(-r)  (in-mail-context (:require-buffer t)    (let* ((*mini-buffer-dont-record* t)   (keywords (read-mail-keywords "Keywords to search for (separated by commas):" *last-keywords-searched-for*)))      (setq *last-keywords-searched-for* keywords)      (select-next-message-search keywords *mail-buffer* (- *numeric-arg*) #'message-has-one-of-keywords-p)      (values dis-text dis-bps))))(defcom COM-NEXT-UNDELETED-MESSAGE"Select next undeleted message.With prefix arg, move forward <arg> undeleted messages."(r)  (in-mail-context (:require-buffer t)    (or      (select-next-message-search :undeleted *mail-buffer* *numeric-arg*)      (if (eq (last-message *mail-buffer*) (current-message *mail-buffer*))  (format *query-io* "~&Last message.")(format *query-io* "~&Last undeleted message.")))    (values dis-text dis-bps)))(defcom COM-PREVIOUS-UNDELETED-MESSAGE"Select previous undeleted message.With prefix arg, move backward <arg> undeleted messages."(-r)  (in-mail-context (:require-buffer t)    (or      (select-next-message-search :undeleted *mail-buffer* (- *numeric-arg*))      (if (zerop (current-message-index *mail-buffer*))  (format *query-io* "~&First message.")(format *query-io* "~&First undeleted message.")))    (values dis-text dis-bps)))(defcom COM-MAIL-DOWN-REAL-LINE"Move down vertically to next real line, keeping summary and message buffers in sync.Moves as far as possible horizontally toward the goal column for successivecommands.  The goal column is normally the column you start at,but the command C-X C-N sets a semipermanent goal column."(km r)  (in-mail-context ()    (down-real-line *numeric-arg*)    (when (mail-summary-p *interval*)      ;; Inside summary -- sync message sequence to new summary point      (multiple-value-setq (*mail-buffer* *msg*) (sync-mail-buffers nil)))    (values dis-bps dis-bps)))(defcom COM-MAIL-UP-REAL-LINE"Move up vertically to previous real line, keeping summary and message buffers in sync.Moves as far as possible horizontally toward the goal column for successivecommands.  The goal column is normally the column you start at,but the command C-X C-N sets a semipermanent goal column."(km -r)  (in-mail-context ()    (down-real-line (- *numeric-arg*))    (when (mail-summary-p *interval*)      ;; Inside summary -- sync message sequence to new summary point.        (multiple-value-setq (*mail-buffer* *msg*) (sync-mail-buffers nil))      (when (not (getf (line-plist (bp-line (point))) :summary-message))(return-from com-mail-up-real-line dis-bps)))    (values dis-bps dis-bps)))(defcom COM-JUMP-TO-MESSAGE"Jump to message buffer and display the selected message (or the message number specified by a prefix arg).If already in message buffer, prompt for message number unless already specified by prefix arg."(push)  (in-mail-context (:require-buffer t)    (let* ((in-summary (mail-summary-p *interval*))   (msg-num (cond (*numeric-arg-p* *numeric-arg*)  (in-summary (current-message-number *mail-buffer*))  (t (let ((*mini-buffer-dont-record* t))       (typein-line-read "Jump to message number: " nil t))))))            (unless (and (integerp msg-num) (>= msg-num 1))(barf "Message number must be a positive integer"))      (decf msg-num)      (if (< msg-num (total-messages *mail-buffer*))  (select-message msg-num *mail-buffer*)(select-message (last-message *mail-buffer*) *mail-buffer*))      (when (and in-summary (null (mail-buffer-window *mail-buffer*)))(make-mail-buffer-current *mail-buffer* :message)))    (values dis-text dis-bps)))(defcom COM-OTHER-MAIL-BUFFER"Other mail buffer.  Switch between summary and message buffer for the selected message."()  (in-mail-context (:require-buffer t)    (multiple-value-bind (summary-window message-window)(two-mail-reader-windows-p *mail-buffer*)      (cond ((mail-summary-p *interval*)     (if message-window (make-window-current message-window) (make-mail-buffer-current *mail-buffer* :message)))    (t     (when *msg*       (delete-message-attribute :unseen *msg*))     (if summary-window (make-window-current summary-window) (make-mail-buffer-current *mail-buffer* :summary)))))    (values dis-text dis-text)))(defcom COM-NEXT-MESSAGE-SCREEN"Show next screen of message buffer if it is visible -- otherwise select next message in summary."(r)  (in-mail-context (:require-buffer t)    (cond ((mail-summary-p *interval*)   (let ((msg-buffer-window (mail-buffer-window *mail-buffer*)))     (cond (msg-buffer-window    ;; Within summary but message buffer IS visible.  Scroll current message if already being displayed.    ;; Otherwise do nothing and let message become selected first.    (when (eq *msg* (message-displayed-by-buffer *mail-buffer*))      (recenter-window-relative msg-buffer-window (if *numeric-arg-p*      *numeric-arg*    (- (window-n-plines msg-buffer-window)       *next-screen-context-lines*))))    (values dis-text dis-none))   ;; within summary but its message buffer not visible -- just move down.   (t    (if (getf (line-plist (bp-line (point))) :filter-summary-filter)(com-mail-down-real-line)      (or (select-next-message-search :undeleted *mail-buffer* *numeric-arg*)  (com-mail-down-real-line)))    (values dis-none dis-bps)))))  (t   ;; must be in the message buffer   (recenter-window-relative *window* (if *numeric-arg-p*  *numeric-arg*(- (window-n-plines *window*)   *next-screen-context-lines*)))   (values dis-text dis-none)))))(defcom COM-PREVIOUS-MESSAGE-SCREEN"Show previous screen of message buffer if it is visible -- otherwise select next message in summary."(-r)  (in-mail-context (:require-buffer t)    (cond ((mail-summary-p *interval*)   (let ((msg-buffer-window (mail-buffer-window *mail-buffer*)))     (cond (msg-buffer-window    ;; within summary but message buffer visible    (when (eq *msg* (message-displayed-by-buffer *mail-buffer*))      (recenter-window-relative msg-buffer-window (if *numeric-arg-p*      (- *numeric-arg*)    (- *next-screen-context-lines*       (window-n-plines msg-buffer-window)))))    (values dis-text dis-none))   ;; within summary its message buffer not visible   (t    (if (getf (line-plist (bp-line (point))) :filter-summary-filter)(com-mail-up-real-line)      (setq *msg* (select-next-message-search :undeleted *mail-buffer* (- *numeric-arg*)))      (cond ((null *msg*)     (com-mail-up-real-line)     (return-from com-previous-message-screen dis-bps))    (t     (delete-message-attribute :apply *msg*)     (delete-message-attribute :print *msg*))))    (values dis-none dis-bps)))))  (t   ;; must be in the message buffer   (recenter-window-relative *window* (if *numeric-arg-p*  (- *numeric-arg*)(- *next-screen-context-lines*   (window-n-plines *window*))))   (values dis-text dis-none)))))(defcom COM-VIEW-MESSAGE"View message in separate window."()  (in-mail-context (:require-message t)    ;; In 2 window mode, just allow current message to     ;; become the selected one, which requires no action here.    (cond ((two-mail-reader-windows-p *mail-buffer*)   (values dis-text dis-none))  (t   (with-open-stream (stream (interval-stream *msg*))     (view-stream stream))   (delete-message-attribute :unseen *msg*)   (values dis-none dis-none)))))(defcom COM-CHANGE-MESSAGE-KEYWORDS"Change keywords assigned to message.If invoked from the keyboard prompt for keywords in minibuffer, with completion.If invoked from the Message Menu, choose keywords from a menu."()  (in-mail-context (:require-buffer t :require-message t)    (if (typep (w:window-owning-mouse) 'zmacs-window)(change-message-keywords (list *msg*))      ;; Assume in suggestions pane      (let ((*mail-mouse-command* t))(change-message-keywords (list *msg*))))    (values dis-text dis-text)))(defun CHANGE-MESSAGE-KEYWORDS (msg-list &optional (operation :set))    (let* ((choices (if *choose-from-all-mail-keywords-p*      *all-mail-keywords*    (get-mail-option (mail-file-buffer-of *mail-buffer*) :labels))) (do-it-p t) (*mini-buffer-dont-record* t) defaults prompt new-keywords)    (case operation      (:add       (setq prompt "Keywords to add"))      (:delete       (setq prompt "Keywords to delete"))      (t       (setq prompt "Keywords")       (setq defaults (message-keywords (car msg-list)))))    (cond (*mail-mouse-command*   (multiple-value-setq (new-keywords do-it-p)     (choose-mail-keywords choices (string-append "Choose " prompt) defaults)))  (t   (setq new-keywords (read-mail-keywords (format nil "Enter ~A (separated by commas):" prompt) defaults))   (when new-keywords      (dolist (keyword new-keywords)       (unless (or (memeq keyword *all-mail-keywords*)   (y-or-n-p "Adding new keyword ~:@(~A~).  OK?" keyword)) (setq new-keywords (remove keyword new-keywords)))))))    (when do-it-p      (setq *previous-mail-keywords* (copy-list new-keywords))      (case operation(:add (when new-keywords   (dolist (msg msg-list)     (set-message-keywords (delete-duplicates (append (message-keywords msg) new-keywords)) msg))))(:delete (when new-keywords   (dolist (msg msg-list)     (set-message-keywords (set-difference (message-keywords msg) new-keywords) msg))))(t (dolist (msg msg-list)   (set-message-keywords new-keywords msg)))))))(define-mail-apply-command SET-KEYWORDS   (:name "Set Keywords"    :function change-message-keywords    :message-arg :message-list)   "Change keywords of all marked messages.")(define-mail-apply-command ADD-KEYWORDS   (:name "Add Keywords"    :function change-message-keywords    :message-arg :message-list    :args (:add))   "Add certain keywords to all marked messages.")(define-mail-apply-command DELETE-KEYWORDS   (:name "Delete Keywords"    :function change-message-keywords    :message-arg :message-list    :args (:delete))   "Delete certain keywords from all marked messages.")(defcom COM-DELETE-KEYWORD-FROM-ALL-MESSAGES"Remove all traces of certain keywords from all messages and their associated buffer."()  (in-mail-context (:require-buffer t)    (unless (get-mail-option (mail-file-buffer-of *mail-buffer*) :labels)      (barf "No keywords in this buffer."))    (let (keywords  (*mini-buffer-dont-record* t)  (do-it-p t))      (cond (*mail-mouse-command*     (multiple-value-setq       (keywords do-it-p)       (choose-mail-keywords (get-mail-option (mail-file-buffer-of *mail-buffer*) :labels)     "Choose keywords to delete" nil '(:do-it))))    (t     (setq keywords   (read-mail-keywords "Enter keywords to delete (separated by commas):"))))      (when do-it-p(delete-keyword-from-all-messages keywords (mail-file-buffer-of *mail-buffer*))))))(defcom COM-DELETE-MESSAGE"Delete message and move to next.With prefix arg, delete forward <arg> messages."(r)  (in-mail-context (:require-message t :require-buffer t)    (numeric-arg-loop (n lastp)      (add-message-attribute :deleted *msg*)      (unless (setq *msg* (select-next-message-search :undeleted *mail-buffer* (signum n)))(if (eq (last-message *mail-buffer*) (current-message *mail-buffer*))    (format *query-io* "~&Last message.")  (format *query-io* "~&Last undeleted message."))(return)))    (values dis-text dis-text)))      (defcom COM-DELETE-MESSAGE-BACKWARD"Delete message and move to previous.With prefix arg, delete backward <arg> messages."(-r)  (in-mail-context (:require-message t :require-buffer t)    (numeric-arg-loop (n)      (add-message-attribute :deleted *msg*)      (unless (setq *msg* (select-next-message-search :undeleted *mail-buffer* (- (signum *numeric-arg*))))(if (eq (last-message *mail-buffer*) (current-message *mail-buffer*))    (format *query-io* "~&First message.")  (format *query-io* "~&First undeleted message."))(return)))    (values dis-text dis-text)))(defcom COM-UNDELETE-MESSAGE"Undelete the selected message or an adjacent deleted message.  Also remove marks for Print and Apply.With prefix arg, undelete <arg> messages.With no arg, hunt around for an adjacent undeleted message."(-r)  (in-mail-context (:require-message t :require-buffer t)    (cond ((null *numeric-arg-p*)   (let* ((next (next-message *mail-buffer*))  (move (and (not (message-marked-p *msg*))     (if (and next (message-marked-p next)) 1 -1))))     (when move       (setq *msg* (select-next-message *mail-buffer* move)))     (when *msg*       (delete-message-marks *msg*))))  (t   (numeric-arg-loop (n lastp)     (delete-message-attribute :deleted *msg*)     (unless lastp       (setq *msg* (select-next-message *mail-buffer* (signum n))))     (unless *msg*       (return)))))    (values dis-text dis-text)))(defcom COM-EXPUNGE-MAIL-BUFFER"Expunge deleted messages from the current buffer."()  (in-mail-context (:require-buffer t)    (let* ((buffer (current-mail-file-buffer))   (prev-total (total-messages buffer)))      (expunge-mail-buffer buffer)      (format *query-io* "~D message~:P expunged." (- prev-total (total-messages buffer))))    (values dis-text dis-text)))(defcom COM-REFORMAT-MESSAGE-HEADERS"Reformat message headers.  With prefix arg of 1, show the original headers.With prefix arg of 0, reformat from original even if a saved copy of  reformatted header exists."()  (in-mail-context (:require-message t)    (cond ((not *numeric-arg-p*)   (reformat-message-headers *msg*))  ((eql *numeric-arg* 1)   (deformat-message-headers *msg*))  ((eql *numeric-arg* 0)   (reformat-message-headers *msg* t))  (t   (numeric-arg-loop (n lastp)     (deformat-message-headers *msg*)     (unless lastp       (setq *msg* (select-next-message-search :undeleted *mail-buffer* (signum *numeric-arg*))))     (unless *msg*       (return)))))    (values dis-text dis-bps)))(defcom COM-EDIT-MESSAGE "Edit message in a separate buffer.  END accepts all changes;  ABORT leaves message unmodified."()  (in-mail-context (:require-message t :require-buffer t)    (delete-message-attribute :unseen *msg*)    (let ((buffer (make-instance 'zmacs-buffer :name (loop for i from 1       for name = (format nil "*Edit-Message* ~A (~D)" (message-name *msg*) i)       unless (find-buffer-named name)       return name))))      (setf (send buffer :saved-major-mode) 'text-mode)      (setf (get buffer :message-object) *msg*)      (setf (get buffer :mail-buffer) *mail-buffer*)      (insert-interval (interval-last-bp buffer) *msg*)      (discard-undo-information buffer)      (make-buffer-current buffer)      (turn-on-mode 'edit-message-mode)      (not-modified buffer))    (values dis-none dis-none)))(defminor COM-EDIT-MESSAGE-MODE EDIT-MESSAGE-MODE "Edit-Message" 1  "Minor mode for editing a mail message.  END put the changes into effect; ABORT discards the changes."  ()   (set-comtab *mode-comtab*  '(#\End  com-edit-message-end    #\Abort com-edit-message-abort)  '(("Edit Message End" . com-edit-message-end)    ("Edit Message Abort" . com-edit-message-abort)))  (set-mode-line-list (append (mode-line-list) '("  (END to accept, ABORT to discard changes)"))))(defcom COM-EDIT-MESSAGE-END"Replace contents of edited message with those of the current buffer."()    (let ((msg (get *interval* :message-object)))    (unless msg      (barf "Buffer is not associated with any message."))    ;; Yes, it seems wasteful to make another copy but it ensures that BPs, line plists, etc. are not contaminated    (with-message-read-only-suppressed (msg)      (delete-interval msg)      (insert-interval (interval-last-bp msg) *interval*)      (update-message-info msg)      (setf (get msg :saved-reformatted-headers) nil)      (mung-message msg)      (setf (message-parsed-p msg) nil)      (setf (message-summary-parsed-p msg) nil)      (update-message-summary msg))    (let ((old-buffer (get *interval* :mail-buffer))  (edit-buffer *interval*))      (when (or (null old-buffer)(get old-buffer :killed))(setq old-buffer (previous-buffer edit-buffer)))      (when old-buffer(select-message msg old-buffer)(send old-buffer :select)(send edit-buffer :kill))))  dis-text)(defcom COM-EDIT-MESSAGE-ABORT"Abort edit of message and leave the original message unchanged."()  (let ((old-buffer (get *interval* :mail-buffer))(msg (get *interval* :message-object))(edit-buffer *interval*))    (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   (when (or (null old-buffer)     (get old-buffer :killed))     (setq old-buffer (previous-buffer edit-buffer)))   (when old-buffer     (cond ((or (not (buffer-modified-p edit-buffer))(y-or-n-p "Buffer is modified. Kill it anyway?"))    (select-message msg old-buffer)    (send old-buffer :select)    (send edit-buffer :kill))   (t    (select-message msg old-buffer)    (send old-buffer :select)))))))  dis-text)(defcom COM-MAIL-REVERSE-INCREMENTAL-SEARCH"Reverse incremental search thru all messages in the current mail buffer."()  (let ((*numeric-arg* (- *numeric-arg*)))    (com-mail-incremental-search)))(defcom COM-MAIL-INCREMENTAL-SEARCH"Incremental search thru all messages in the current mail buffer."()  (in-mail-context (:require-buffer t :require-message t)    (let ((need-to-switch-back? nil))      (unwind-protect; This may be overkill if incremental-search never throws.  (progn    ;;  Searching needs to be done in the message buffer.    (when (mail-summary-p *interval*)      (com-other-mail-buffer)      (setq need-to-switch-back? t))    ;;don't reformat headers while searching    (let ((*reformat-headers-automatically* nil))      (incremental-search (< *numeric-arg* 0))))(when need-to-switch-back?  (com-other-mail-buffer))))    (values dis-text dis-bps)))(defprop read-mail-mode mail-search MAJOR-MODE-INCREMENTAL-SEARCH-FUNCTION)(defun MAIL-SEARCH (bp string &optional reversep fixup-p lines-to-search limit-bp)    (if (and (neq *current-command* 'com-mail-incremental-search)   (neq *current-command* 'com-mail-reverse-incremental-search))      (multiple-value-bind (rtn-bp time-out)  (search bp string reversep fixup-p lines-to-search limit-bp)(return-from mail-search rtn-bp time-out))    (let ((buffer *interval*)  msg saved-msg)      (unless (and (message-sequence-p buffer)   (setq msg (bp-message bp)))(return-from mail-search nil))      (unless (eq msg (current-message buffer))(make-message-current msg buffer))      (setq saved-msg msg)      (loop(multiple-value-bind (rtn-bp time-out)    (search bp string reversep fixup-p lines-to-search limit-bp)  (when rtn-bp     (must-redisplay-mail-buffer buffer dis-text dis-bps)    (return-from mail-search rtn-bp time-out))  (setq msg (select-next-message-search :undeleted *mail-buffer* (if reversep -1 1)))  (unless msg    (select-message saved-msg buffer)    (must-redisplay-mail-buffer buffer dis-text dis-bps)    (return-from mail-search nil))  (make-message-current msg buffer)  (setq bp (if reversep (interval-last-bp msg) (interval-first-bp msg)))  (setq limit-bp nil))))))       (defcom COM-COPY-MESSAGE-TO-MAIL-FILE"Copy message to a specified mail file.  If the file is in memory as a mail buffer, copy into the buffer.With a prefix arg, copy the next <arg> undeleted messages."()  (in-mail-context (:require-message t :require-buffer t)    (copy-message-to-mail-file      (loop repeat (abs *numeric-arg*)    as *msg* = *msg* then (select-next-message-search :undeleted *mail-buffer* (signum *numeric-arg*))    until (null *msg*)    collecting *msg*)      "Copy message~P to mail file:")    (values dis-text dis-text)))(defun COPY-MESSAGE-TO-MAIL-FILE (message-list prompt)  (let* ((*mini-buffer-dont-record* t) (pathname (read-defaulted-pathname (format nil prompt (length message-list))    (default-other-mail-file))) (abort-flag :abort) whereto format)    (setq *default-other-mail-file* pathname)    (unwind-protect(progn  (multiple-value-setq (whereto format)    (copy-message-init pathname))  (format *query-io* "~&Copied ")  (loop for msg in message-listas firstp = t then nildoing(if (streamp whereto)    (write-message msg format whereto)  (let ((copy (copy-message-object msg)))    (delete-message-attribute :apply copy); In case of apply-command usage.    (add-message-to-buffer copy whereto)))(add-message-attribute :filed msg)(when *delete-message-after-copy*  (add-message-attribute :deleted msg))(format *query-io* "~:[, ~;~]~D"firstp(1+ (message-index msg *mail-buffer*))))  (setq abort-flag nil)  (when (mail-reader-buffer-p whereto)    (when (mail-summary-of whereto)      (update-summary (mail-summary-of whereto)))    (format *query-io* "~&Be sure to save the other buffer to reflect changes.")))      (when (streamp whereto)(close whereto :abort abort-flag)))    (format *query-io* " to ~A ~A~@[ in ~A format~]."    (if (streamp whereto) "file" "buffer")    (if (streamp whereto) pathname whereto)    format)))(define-mail-apply-command copy-message   (:name "Copy Message"    :function copy-message-to-mail-file    :message-arg :message-list    :args ("Copy message~P to mail file:"))   "Copy all marked messages to a mail file.")(defcom COM-COPY-MESSAGE-TO-TEXT-FILE        "Copy message to a specified text file in a form suitable for printing. Text mail files cannot be read back into a mail buffer. With a numericargument, copy the next N undeleted messages."()  (in-mail-context (:require-message t :require-buffer t)    (let ((*default-mail-file-format* :text))      (copy-message-to-mail-file(loop repeat (abs *numeric-arg*)      as *msg* = *msg* then (select-next-message-search :undeleted *mail-buffer* (signum *numeric-arg*))      until (null *msg*)      collecting *msg*)"Copy message~P to text file:")      (values dis-text dis-text))))(defcom COM-FILTER-MESSAGES"Filter messages with specified characteristics into a separate buffer.With a prefix argument filter only the messages in the current buffer (e.g.  to apply afilter to a filter buffer), otherwise filter all messages in current mail file."()  (in-mail-context (:require-buffer t)    (multiple-value-bind (filter current-only)(if (or *mail-mouse-command*;; Check if invoked from suggestions(not (typep (w:window-owning-mouse) 'zmacs-window)))    (choose-mail-filter)  (read-mail-filter-from-mini-buffer))      (when filter(let ((buffer (make-mail-buffer-from-filterfilter(if current-only    *mail-buffer*  (mail-file-buffer-of *mail-buffer*)))))  (cond ((> (total-messages buffer) 0) (send buffer :activate) (when (mail-summary-of buffer)   (update-summary (mail-summary-of buffer))) (make-mail-buffer-current buffer) (format *query-io* "~&Press ~A to return to all messages." (key-for-command 'com-exit-mail-reader *comtab* nil nil #\Q)))(t (send buffer :kill) (barf "No messages pass this filter."))))))    (values dis-text dis-text)))(defcom COM-CHANGE-INBOXES"Add and/or delete inboxes associated with this mail file."()  (in-mail-context (:require-buffer t)    (let* ((buffer (current-mail-file-buffer))   (orig-inboxes (get-mail-option buffer :mail))   (inboxes (copy-list orig-inboxes))   (*new-inbox-choice* nil)   new-inbox)      (declare (special *new-inbox-choice*))            (multiple-value-bind (chosen-inboxes do-something)  (if (null inboxes)      (values nil (setq *new-inbox-choice* t))    (w:multiple-menu-choose      inboxes      :highlighted-items inboxes      :label (format nil "Select inboxes for ~A" (buffer-pathname buffer))      :menu-margin-choices      '(("Do It" :eval (progn (setq *new-inbox-choice* nil) (funcall self :highlighted-values)) :documentation "Keep highlighted inboxes.  Unhighlighted ones will be removed.")("New Inbox" :eval (progn (setq *new-inbox-choice* t) (funcall self :highlighted-values)) :documentation "Keep highlighted inboxes and prompt for a new inbox pathname to add."))))(when do-something  (when *new-inbox-choice*    (setq new-inbox  (let ((*mini-buffer-dont-record* t))    (read-defaulted-pathname "New inbox pathname:"     (send (buffer-pathname buffer) :new-pathname   :name "MAIL"   :canonical-type :text   :version :newest))))    (condition-case (condition)(setq new-inbox (parse-namestring new-inbox))      (fs:pathname-error       (format *query-io* "~&Warning: The new inbox is not a parsable pathname: ~A"       (send condition :report-string))))    (unless (or (member new-inbox chosen-inboxes :test #'fs:pathname-equal)(fs:pathname-equal new-inbox (buffer-pathname buffer))); Don't let file be own inbox.      (when (and (pathnamep new-inbox)  mail:*probe-for-new-mail-p*)(mail:add-mail-inbox-probe new-inbox)))    (push-end new-inbox chosen-inboxes))  (setf (get-mail-option buffer :mail) chosen-inboxes)  (setf (node-tick buffer) *tick*)  (dolist (inbox orig-inboxes)    (when (and (pathnamep inbox)       (not (memeq inbox chosen-inboxes)))      (mail:remove-mail-inbox-probe inbox))))))    (values dis-none dis-none)))(defcom COM-CHANGE-FILE-OPTIONS"Change the options associated with a babyl file:  owner, append/prepend, and header reformation."()  (in-mail-context (:require-buffer t)    (let* ((buffer (current-mail-file-buffer));   (inboxes (copy-list (get-mail-option buffer :mail)))   (owner   (get-mail-option buffer :owner))   (append  (get-mail-option buffer :append))   (reform  (not (get-mail-option buffer :no-reformation))))      (declare (special inboxes owner append reform))      (w:choose-variable-values '(; (inboxes "Inboxes" ?); Wants to call com-change-inboxes, but I don't know how.  (owner   "Owner"   :string)  (append  "Append New Mail"  :assoc (("Append" . 1) ("Prepend" . 2)))  (reform  "Reformat Headers" :boolean)):label "File Options":margin-choices tv:default-finishing-choices);      (when (not (equal inboxes (get-mail-option buffer :mail)));(setf (get-mail-option buffer :mail) inboxes))      (when (neq owner (get-mail-option buffer :owner))(setf (get-mail-option buffer :owner) owner))      (when (not (eql append (get-mail-option buffer :append)))(setf (get-mail-option buffer :append) append))      (setf (get-mail-option buffer :no-reformation) (not reform)))    (values dis-none dis-none)))(defcom COM-MAIL"Send a new mail message."()  (unless (maybe-continue-unsent-message)    (let ((current-buffer *interval*))      (funcall (get-mail-template-function *mail-template*))      (setf (get *interval* :buffer-of-mail-command)    (if (mail-reader-buffer-p current-buffer)(message-sequence-of current-buffer)nil))))  dis-none)(defcom COM-REPLY-TO-MESSAGE"Reply to sender.  If prefix arg = 1, reply to all.  If prefix arg = 2, use two window reply.Prefix argument of 3 means yank current message into reply buffer with reformatted header.Prefix argument of 4 means yank message but with the original header."()  (in-mail-context (:require-buffer t :require-message t)    (unless (maybe-continue-unsent-message :reply)      (let ((config (current-mail-window-configuration)))(funcall (get-mail-template-function (if (and *numeric-arg-p* (eql *numeric-arg* 1)) *reply-template-1*       *reply-template*)))(setf (get *interval* :buffer-of-mail-command) *mail-buffer*)(setf (get *interval* :saved-window-configuration) config)(when (or (and *two-window-reply*       (not (or (eql *numeric-arg* 3); When yanking original, don't split.(eql *numeric-arg* 4))))  (eql *numeric-arg* 2))  (two-window-reply *interval* *mail-buffer*));; Insert replied to message(when (and *numeric-arg-p* (< 2 *numeric-arg* 5))  (with-open-stream (stream (interval-stream-into-bp (interval-last-bp *interval*)))    (print-formatted-message *msg* stream *yank-message-prefix* nil     (eql *numeric-arg* 3)     nil *yank-message-headers-include-list*))  (move-bp (buffer-point *interval*) (interval-last-bp *interval*)))))    (values dis-text dis-bps)))(defun TWO-WINDOW-REPLY (template-buffer mail-buffer)    (multiple-value-bind (top bottom)      (two-windows-by-fraction 0.50)    (make-window-current top)    (make-mail-buffer-current mail-buffer :message)    (make-window-current bottom)    (send template-buffer :select)    (select-window)))(defcom COM-REPLY-TO-ALL"Reply to sender and all recipients of current message."()  (in-mail-context (:require-message t :require-buffer t)    (unless (maybe-continue-unsent-message :reply)      (funcall (get-mail-template-function *reply-to-all-template*))      (setf (get *interval* :buffer-of-mail-command) *mail-buffer*)      (when *two-window-reply*(two-window-reply *interval* *mail-buffer*)))    (values dis-none dis-none)))(defcom COM-REPLY-TO-SENDER"Reply to the sender of current message."()  (in-mail-context (:require-message t :require-buffer t)    (unless (maybe-continue-unsent-message :reply)      (funcall (get-mail-template-function *reply-to-sender-template*))      (setf (get *interval* :buffer-of-mail-command) *mail-buffer*)      (when *two-window-reply*(two-window-reply *interval* *mail-buffer*)))    (values dis-none dis-none)))(defcom COM-FORWARD-MESSAGE        "Forward current message to other users. With prefix arg, do not clean up headers of message being forwarded."()  (in-mail-context (:require-message t)    (unless (maybe-continue-unsent-message :forward)      (funcall (get-mail-template-function *forward-template*))      (setf (get *interval* :buffer-of-mail-command) *mail-buffer*))    (values dis-none dis-none)))(defcom COM-RESEND-MESSAGE"Resend current message to other users."()  (in-mail-context (:require-message t)    (unless (maybe-continue-unsent-message :forward)      (funcall (get-mail-template-function *resend-template*))      (setf (get *interval* :buffer-of-mail-command) *mail-buffer*))    (values dis-none dis-none)))(defcom COM-MAIL-DOCUMENTATION"Provide help for mail in addition to standard ZMACS help."()  (let ((*com-documentation-alist* (cons '(#\M com-read-mail-help) *com-documentation-alist*)))    (com-documentation))  dis-none)(defcom COM-MAIL-MARK-FOR-APPLY"Mark message for command application.With prefix arg, mark <arg> messages.Use the Mail Execute command (X) after marking messages to choose function to apply."()  (in-mail-context (:require-message t)    (numeric-arg-loop (n lastp)      (add-message-attribute :apply *msg*)      (setq *msg* (select-next-message-search :undeleted *mail-buffer* (signum n)))      (unless *msg*(return)))    (values dis-none dis-text)))(defcom COM-MAIL-EXECUTE"Execute operation on messages marked to Delete, Print, or Apply."()  (in-mail-context (:require-buffer t)    (send *standard-input* :clear-input);because X is so close to Space and we use y-or-n-p    (let* ((real-query-io *query-io*)   (*query-io* *standard-output*)   (mail-buffer (if (filter-summary-p *interval*)    (mail-file-buffer-of *interval*)  *mail-buffer*))   print-list apply-list expunge-list pause-before-exit)      (domsgs (msg mail-buffer)(when (message-attribute-p :apply msg)  (push msg apply-list))(when (message-attribute-p :print msg)  (push msg print-list))(when (message-attribute-p :deleted msg)  (push msg expunge-list)))      (when apply-list(setq apply-list (nreverse (the list apply-list)))(format t "~%Messages to be processed by command:~%")(typeout-message-list apply-list mail-buffer)(when (y-or-n-p "Apply command?")  (let ((*query-io* real-query-io))    (apply-mail-command apply-list))  (dolist (msg apply-list)    (delete-message-attribute :apply msg)))(terpri))      (when print-list(setq print-list (nreverse (the list print-list)))(format t "~%Messages to be printed:~%")(typeout-message-list print-list mail-buffer)(when (y-or-n-p "Print?")  (setq pause-before-exit t)  (print-message-list print-list)  (dolist (msg print-list)    (delete-message-attribute :print msg)))(terpri))      (when expunge-list(setq pause-before-exit nil)(setq expunge-list (nreverse (the list expunge-list)))(Format t "~%Messages to be expunged:~%")(typeout-message-list expunge-list mail-buffer)(when (y-or-n-p "Expunge?")  (expunge-mail-buffer (if (or (mail-file-buffer-p mail-buffer)       (y-or-n-p "Expunge from all buffers? (N means just current filter.)"))   (mail-file-buffer-of mail-buffer) mail-buffer))))      (if pause-before-exit  (format t "~2%Done.")(send *window* :prepare-for-redisplay)))    (values dis-text dis-text)))(defun TYPEOUT-MESSAGE-LIST (msg-list buffer)  (terpri)  (let ((*print-base* #10r10))    (send *standard-output* :item-list nil  (mapcar #'(lambda (msg)      (format nil "~4@A: ~A" (1+ (message-index msg buffer)) (message-name msg)))  msg-list))    (terpri)))(defun GET-MAIL-APPLY-COMMAND (id)  (or (get id :mail-apply-command)      (ferror 'mail-reader-error      "~S is a malformed Mail Apply Command.  It does not have a :MAIL-APPLY-COMMAND property." id)))(defcom COM-APPLY-MAIL-COMMAND"Choose command to apply to marked messages from menu."()  (in-mail-context (:require-buffer t :require-message t)    (let (apply-list)      (domsgs (msg *mail-buffer*)(when (message-attribute-p :apply msg)  (push msg apply-list)))      (unless apply-list(barf "No messages marked for apply."))      (apply-mail-command apply-list)      (dolist (msg apply-list)(delete-message-attribute :apply msg)))    (values dis-text dis-text)))(defun APPLY-MAIL-COMMAND (msg-list)    (let (command)    (cond (*mail-mouse-command*   (multiple-value-bind (cmd item)       (w:menu-choose *mail-apply-command-item-list*      :label "Choose command to apply"      :pop-up t      :default-item        (assoc *default-mail-apply-command* *mail-apply-command-item-list* :test #'equalp))     (when cmd       (setq command cmd)       (setq *default-mail-apply-command* (car item)))))  (t   (let* ((*mini-buffer-default-string* *default-mail-apply-command*)  (*mini-buffer-dont-record* t)  (cmd    (completing-read-from-mini-buffer      (format nil "Command to apply:~@[ (Default: ~A)~]" *default-mail-apply-command*)      *mail-apply-command-completion-alist* nil)))     (cond ((and (stringp cmd) (zerop (length cmd)))    (setq command (cdr (assoc *default-mail-apply-command*      *mail-apply-command-completion-alist* :test #'string-equal))))   ((consp cmd)    (setq *default-mail-apply-command* (car cmd))    (setq command (cdr cmd)))))))    (when command      (send (get-mail-apply-command command) :execute msg-list))))(defcom COM-PRINT-MESSAGE"Mark message for printing.With prefix arg, mark <arg> messages.Use the Mail Execute command (X) after marking messages to start printing."()  (in-mail-context (:require-message t)    (numeric-arg-loop (n lastp)      (add-message-attribute :print *msg*)      (unless lastp(setq *msg* (select-next-message-search :undeleted *mail-buffer* (signum n))))      (unless *msg*(return)))    (values dis-none dis-text)))(define-mail-apply-command PRINT (:name "Print"  :function print-message-list  :message-arg :message-list)  "Print marked messages to hardcopy device.")(defun PRINT-MESSAGE-LIST (msg-list)     (let* ((*mini-buffer-default-string* (or *default-print-message-printer* (get-default-printer))) (*mini-buffer-dont-record* t) (printer (completing-read-from-mini-buffer    (format nil "Printer name: (Default is ~S)" *mini-buffer-default-string*)    (list-printers))))    (if (stringp printer); Will be element of alist or an empty string.(setq printer *mini-buffer-default-string*)      (setq printer (first printer)); Name from alist element.      (setq *default-print-message-printer* printer))    (loop for msg in msg-list  collect (make-string-input-stream (string #\clear-screen)) into streams; Start on new page.  collect (interval-stream msg) into streams  finally (with-open-stream (in-stream (apply #'make-concatenated-stream      (make-index-page msg-list)      streams))    (ticl:print-stream in-stream :printer-name printer)))));;; ;;;  Make an index page for the print-out by making summary lines.  The summary lines are;;;  made with the usual template but with the field-widths cut down by 10 to avoid line;;;  overflows at the printer;  this is simple-minded but works.  Doesn't deallocate the;;;  summary lines;  this bothers me but I can't see how to do it, given that we're;;;  returning a concatenated-stream and don't have control over its use.  I could make my;;;  own stream, copying read-from-string-stream, but is it worth it?(defun make-index-page (msg-list)   (loop for msg in msg-list as summary-line = (let ((*mail-summary-template* (loop for item in *mail-summary-template*collecting (if (numberp item)       (max (- item 10.) 5)       item))))     (make-summary-line msg (message-index msg *mail-buffer*)));   (or (first (message-summary-lines msg));       (make-summary-line msg (message-index msg *mail-buffer*))) collecting (make-string-input-stream (string #\return)) into streams collecting (make-string-input-stream summary-line) into streams finally (let ((header-string (format nil "--- Messages from file ~A ---~%    ~\\date\\~%"      (buffer-pathname (mail-file-buffer-of *mail-buffer*))      (time:get-universal-time))))   (return (apply #'make-concatenated-stream (make-string-input-stream header-string) streams)))))(define-mail-apply-command KILL-RING-SAVE   (:name "Kill Ring Save"    :function kill-ring-save-message-list    :message-arg :message-list)  "Save all marked messages onto the kill ring.")(defun KILL-RING-SAVE-MESSAGE-LIST (msg-list)    (let ((first (car msg-list)))    (when first      (let ((*last-command-type* nil))(kill-ring-save-interval first))      (let ((*last-command-type* 'kill))(dolist (msg msg-list)  (kill-ring-save-interval msg))))))(define-mail-apply-command FILTER   (:name "Filter"    :function filter-marked-messages    :message-arg :once)  "Collect marked messages into a separate buffer.")  (defun FILTER-MARKED-MESSAGES ()  (let ((buffer (make-mail-buffer-from-filter (get-mail-filter 'marked) *mail-buffer*)))    (when buffer      (send buffer :activate)      (when (mail-summary-of buffer)(update-summary (mail-summary-of buffer)))      (make-mail-buffer-current buffer)      (format *query-io* "~&Press ~A to return to all messages."      (key-for-command 'com-exit-mail-reader *comtab* nil nil #\Q)))))(define-mail-apply-command OTHER   (:name "Other"    :function other-apply-command    :message-arg :message-list)   "Apply an arbitrary function to each of the marked messages -- use at own risk.")(defun other-apply-command (msg-list)   (let ((function (read-function-name "Function to apply" nil t)))     (loop for msg in msg-list   doing (funcall function msg))))(defprop com-mail-menu "Mail Menu" :mouse-short-documentation)(defparameter mail-menu-alist      '(("Mail Commands" :no-select t :font tr12b)("Save Mail File" . com-save-mail-file)("Get New Mail" . com-get-new-mail)("Send Mail" . com-mail)("List Mail Buffers" . com-list-mail-buffers)("Expunge Messages" . com-expunge-mail-buffer)("Filter Messages" . com-filter-messages)("Apply Command" . com-apply-mail-command)("Other Mail Buffer" . com-other-mail-buffer)("Two Mail Windows" . com-two-mail-windows)("One Mail Window" . com-one-mail-window)("Delete Keywords" . com-delete-keyword-from-all-messages)("Change Inboxes" . com-change-inboxes)("Change File Options" . com-change-file-options)("Sort Messages" . com-sort-messages)("Exit Mail Reader" . com-exit-mail-reader)("" :no-select t)("Zmacs Commands" :no-select t :font tr12b)("List Buffers" . com-list-buffers)("Kill or Save Buffers" . com-kill-or-save-buffers)("Split Screen" . com-split-screen)))(defcom COM-MAIL-MENU "A menu of general mail commands for dealing with mail files, buffers, windows, and inboxes." ()  (let (command(summary-window (two-mail-reader-windows-p *mail-buffer*)))    ;;  Because clicking on the lower window makes it *window*, and doing select-window    ;;  leaves things confused.  For example, the summary lines will box even though the    ;;  active blinker is in the lower window.    (when summary-window      (make-window-current summary-window))    (select-window)    (using-resource (menu menu-command-menu mail-menu-alist)      (send menu :set-label " Mail Command Menu ")      (send menu :set-geometry t t nil)      (setq command (funcall menu :choose)))    ;;Ensure that ZMACS window is selected correctly after the menu    (select-window)    (if command(let ((*mail-mouse-command* t))  (funcall command))dis-none)))(defprop com-message-menu "Message Menu" :mouse-short-documentation)(defparameter UNDELETED-MESSAGE-MENU-ALIST      '(("Copy" . com-copy-message-to-mail-file)("Edit" . com-edit-message)("Keywords" . com-change-message-keywords)("Apply (mark)" . com-mail-mark-for-apply)("Print (mark)" . com-print-message)("View" . com-view-message)("Forward" . com-forward-message)("Reply" . com-reply-to-message)("Template Menu" . com-mail-template-menu)("Reformat" . com-reformat-message-headers)("Delete" . com-delete-message)))(defparameter DELETED-MESSAGE-MENU-ALIST      '(("Copy" . com-copy-message-to-mail-file)("Edit" . com-edit-message)("Keywords" . com-change-message-keywords)("Apply (mark)" . com-mail-mark-for-apply)("Print (mark)" . com-print-message)("View" . com-view-message)("Forward" . com-forward-message)("Reply" . com-reply-to-message)("Template Menu" . com-mail-template-menu)("Reformat" . com-reformat-message-headers)("Undelete" . com-undelete-message)))(defcom COM-MESSAGE-MENU"A menu of message commands to operate on the message clicked on."()  (in-mail-context (:require-buffer t :require-message t)    (if (typep (w:window-owning-mouse) 'zmacs-window)(multiple-value-bind (msg buffer)    (message-under-mouse)  (message-menu msg buffer))      (message-menu *msg* *mail-buffer*))))(defun MESSAGE-MENU (msg buffer)  (let (command)    (select-window)    (select-message msg buffer)    (must-redisplay-mail-buffer buffer dis-text dis-bps)    (redisplay-all-windows t)    (using-resource (menu menu-command-menu (if (message-marked-p msg)deleted-message-menu-alist      undeleted-message-menu-alist))      (send menu :set-label (format nil "Message Command for #~d" (current-message-number buffer)))      (send menu :set-geometry t t nil)      (setq command (funcall menu :choose)))    ;;Ensure that ZMACS window is selected correctly after the menu    (select-window)    (cond (command   (let ((*mail-mouse-command* t))     (funcall command)))  (:else   (values dis-none dis-none)))))(defun MESSAGE-UNDER-MOUSE (&optional (errorp t))  "Return the message object and mail buffer that the mouse is pointing to."    (let ((buffer (bp-top-level-node (mouse-bp *window*)))(bp (mouse-bp *window*))msg)        (cond ((mail-summary-p buffer)   (setq msg (getf (line-plist (bp-line bp)) :summary-message))   (if msg       (values msg (message-sequence-of buffer))       (and errorp (barf "Line does not describe a message."))))  ((message-sequence-p buffer)   (setq msg (message-displayed-by-buffer buffer))   (if msg       (values msg buffer)       (and errorp (barf "No current message."))))  (t   (and errorp (barf "Not within a mail buffer."))))))(defprop com-mouse-select-or-mark "Select message" :mouse-short-documentation)(defcom COM-MOUSE-SELECT-OR-MARK "Select message under mouse or do mouse region marking." ()  (in-mail-context (:require-buffer t)    (com-mouse-mark-region)    (when (mail-summary-p *interval*)      ;; Inside summary -- sync message sequence to new summary point      (sync-mail-buffers nil))    (values dis-text dis-bps)))(defun header-text-msg-sort-function-forward (header)  #'(lambda (m1 m2)      (assure-message-parsed m1)      (assure-message-parsed m2)      (let ((h1 (get-message-header m1 header :interval))    (h2 (get-message-header m2 header :interval)))(and h1 h2     (string-lessp (string-interval h1)   (string-interval h2))))))(setf (get :from-forward 'sort-predicate) (header-text-msg-sort-function-forward :from))(setf (get :to-forward 'sort-predicate) (header-text-msg-sort-function-forward :to))(setf (get :subject-forward 'sort-predicate) (header-text-msg-sort-function-forward :subject))(defun header-text-msg-sort-function-backward (header)  #'(lambda (m1 m2)      (assure-message-parsed m1)      (assure-message-parsed m2)      (let ((h1 (get-message-header m1 header :interval))    (h2 (get-message-header m2 header :interval)))(and h1 h2     (string-greaterp (string-interval h1)      (string-interval h2))))))(setf (get :from-backward 'sort-predicate) (header-text-msg-sort-function-backward :from))(setf (get :to-backward 'sort-predicate) (header-text-msg-sort-function-backward :to))(setf (get :subject-backward 'sort-predicate) (header-text-msg-sort-function-backward :subject))(defun date-sort-msg-function-forward (m1 m2)   (assure-message-parsed m1)   (assure-message-parsed m2)   (let ((d1 (get-message-header m1 :date :universal-time)) (d2 (get-message-header m2 :date :universal-time)))     (if (and d1 d2) (< d1 d2) nil)))(defprop :date-forward date-sort-msg-function-forward sort-predicate)(defun date-sort-msg-function-backward (m1 m2)   (assure-message-parsed m1)   (assure-message-parsed m2)   (let ((d1 (get-message-header m1 :date :universal-time)) (d2 (get-message-header m2 :date :universal-time)))     (if (and d1 d2) (> d1 d2) nil)))(defprop :date-backward date-sort-msg-function-backward sort-predicate)(defun size-sort-msg-function-forward (m1 m2)   (summary-assure-message-parsed m1)   (summary-assure-message-parsed m2)   (< (send m1 :get :char-count)      (send m2 :get :char-count)))(defprop :size-forward size-sort-msg-function-forward sort-predicate)(defun size-sort-msg-function-backward (m1 m2)   (summary-assure-message-parsed m1)   (summary-assure-message-parsed m2)   (> (send m1 :get :char-count)      (send m2 :get :char-count)))(defprop :size-backward size-sort-msg-function-backward sort-predicate)(defun keywords-sort-msg-function-forward (m1 m2)   (alphalessp (message-keywords m1); Recursive alphabetic comparison on lists.       (message-keywords m2)))(defprop :keywords-forward keywords-sort-msg-function-forward sort-predicate)(defun keywords-sort-msg-function-backward (m1 m2)   (alphalessp (message-keywords m2); Recursive alphabetic comparison on lists.       (message-keywords m1)))(defprop :keywords-backward keywords-sort-msg-function-backward sort-predicate)(defparameter *sort-messages-sort-options*      '(("Date (forward)" :value :date-forward :documentation "Sort by Date field, earliest first.")        ("Date (backward)" :value :date-backward :documentation "Sort by Date field, latest first.")("From (forward)" :value :from-forward :documentation "Sort by From field, alphabetically.")("From (backward)" :value :from-backward :documentation "Sort by From field, reverse alphabetically.")("To (forward)" :value :to-forward :documentation "Sort by To field, alphabetically.")("To (backward)" :value :to-backward :documentation "Sort by To field, reverse alphabetically.")("Size (forward)" :value :size-forward :documentation "Sort by size in characters, smallest first.")("Size (backward)" :value :size-backward :documentation "Sort by size in characters, largest first.")("Subject (forward)" :value :subject-forward :documentation "Sort by Subject field, alphabetically.")("Subject (backward)" :value :subject-backward :documentation "Sort by Subject field, reverse alphabetically.")("Keywords (forward)" :value :keywords-forward :documentation "Sort by message keywords, alphabetically.")("Keywords (backward)" :value :keywords-backward :documentation "Sort by message keywords, reverse alphabetically.")("" :no-select nil)("Restore Original Order" :value :original :documentation "Restore original ordering.")))(defvar *sort-default-item* (first *sort-messages-sort-options*))(defcom com-sort-messages"Sort messages according to the options chosen from a menu." ()  (in-mail-context (:require-buffer t)    (let ((message-array (send *mail-buffer* :message-array))  sort-option)      (multiple-value-setq (sort-option *sort-default-item*)(w:menu-choose *sort-messages-sort-options*       :label "Sorting Options"       :default-item *sort-default-item*))      (cond (sort-option     (if (eq sort-option :original); Restore the original order. (let ((old-message-array (send *mail-buffer* :get :unsorted-message-array)))   (cond (old-message-array  (setq old-message-array (delete nil old-message-array)); Flush expunged messages.  (setf (send *mail-buffer* :get :unsorted-message-array) old-message-array)  (copy-array-contents-and-leader old-message-array  (buffer-message-array *mail-buffer*))) (:else  (format *query-io* "~&Buffer has never been sorted.")))) (let ((predicate (get sort-option 'sort-predicate)))   (unless predicate (barf "No such sort predicate."))   (unless (send *mail-buffer* :get :unsorted-message-array)     (let ((old-message-array (make-array (array-total-size message-array) :fill-pointer 0)))       (copy-array-contents-and-leader message-array old-message-array)       (setf (send *mail-buffer* :get :unsorted-message-array) old-message-array)))   (setf (buffer-message-array *mail-buffer*) (stable-sort message-array predicate))))     (setf (message-list *mail-buffer*) (coerce message-array 'list))     (mung-node *mail-buffer*)     (when (mail-summary-of *mail-buffer*)       (update-summary (mail-summary-of *mail-buffer*)))     (values dis-text dis-text))    (:else     (values dis-none dis-none))))))(defcom COM-LIST-REMINDERS"Lists in the typeout window all messages with the Reminder attribute." ()  (in-mail-context (:require-buffer t)    ;;  Ugly, but it's the only way to ensure the presence of summary lines without making    ;;  them ourselves, which might be wasteful if this function is called often.    (mail-summary-of *mail-buffer* t)    (format t "~&Reminders:~%")    (domsgs (msg *mail-buffer* i)      (when (msg-reminder-p msg)(terpri)(assure-message-parsed msg)(send *standard-output* :item 'reminder msg      (lisp:find msg (message-summary-lines msg) :test #'(lambda (m l)   (summary-line-message-equal l m *mail-buffer*))))))    (format t "~2&Done.~%")    (values dis-none dis-none)))(tv:add-typeout-item-type *typeout-command-alist* reminder "Select"  select-message-in-*mail-buffer* t "Select this message.")(defun select-message-in-*mail-buffer* (msg)   (select-message msg *mail-buffer*)   (must-redisplay-mail-buffer *mail-buffer* dis-text dis-bps))(defminor com-babyl-mode babyl-mode "Babyl" 1  "Minor mode of Read-Mail mode in which the keystroke commands are more compatible with Babyl.It is useful to set READ-MAIL-MODE-HOOK to TURN-ON-BABYL-MODE if you prefer it." ()  (set-comtab *read-mail-comtab* '(#\B com-other-mail-buffer   #\C com-continue-last-unsent-message   #\E com-expunge-mail-buffer   #\J com-babyl-jump-to-message   #\L com-change-message-keywords   #\O com-copy-message-to-mail-file   #\< com-beginning-of-message   #\> com-end-of-message   #\c-f com-mail-incremental-search   #\c-n com-next-message   #\c-p com-previous-message   #\c-r com-edit-message   #\c-s com-filter-messages)))(defun turn-on-babyl-mode ()   (turn-on-mode 'babyl-mode))(defcom com-babyl-jump-to-message"Jump to message number specified by prefix arg.  If none supplied, assume 1.If in summary buffer, switch to message buffer and show message." ()  (let-if (and (not *numeric-arg-p*)       (not (and (mail-summary-p *interval*) (null (mail-buffer-window *mail-buffer*)))))  ((*numeric-arg-p* :digits))    (com-jump-to-message)))(defcom com-continue-last-unsent-message"If there is an unsent message, go back to editing it." ()  (let ((*unsent-message-query-p* t))    (maybe-continue-unsent-message))  dis-none)(defcom com-beginning-of-message "Display the first screenfull of the message." ()  (in-mail-context (:require-buffer t :require-message t)    (let ((msg-window (mail-buffer-window *mail-buffer*)))      (when (and msg-window; NIL if only summary showing. (eq *msg* (message-displayed-by-buffer *mail-buffer*)))(move-bp (window-point msg-window) (interval-first-bp *msg*))(recenter-window msg-window :absolute 0)))    (values dis-text dis-none)))(defcom com-end-of-message "Display the last screenfull of the message." ()  (in-mail-context (:require-buffer t :require-message t)    (let ((msg-window (mail-buffer-window *mail-buffer*)))      (when (and msg-window; NIL if only summary showing. (eq *msg* (message-displayed-by-buffer *mail-buffer*)))(move-bp (window-point msg-window) (interval-last-bp *msg*))(recenter-window msg-window :absolute)))    (values dis-text dis-none)))(defun READ-MAILING-LIST (&optional default)    (let* ((objects (name:lookup-objects-from-properties :class :mailing-list :name-pattern "*" :read-only t)) (alist (mapcar #'(lambda (obj)    (cons (name:object-name obj) (name:object-name obj)))objects)) (mlist-list (read-comma-delimited-list "Mailing list names (separated by commas, * for all):" alist nil nil t)))    (when (null mlist-list)      (setq mlist-list default))    (cond ((lisp:find "*" mlist-list :test #'equal)   (loop     for alist-tail on alist     do (setf (car alist-tail) (caar alist-tail)))   alist)  (t    mlist-list))))(defcom COM-LIST-MAILING-LIST"List members of specified mailing list(s)."  ()  (let ((mlist-list (read-mailing-list '("*"))))    (dolist (mlist mlist-list)      (format t "~&~:@(~A~):  ~@[~A~]~2%" mlist (name:lookup-attribute-value (string mlist) :mailing-list :remark))      (let ((address-list (name:lookup-attribute-value (string mlist) :mailing-list :address-list)))(if (null address-list)    (write-line "Empty")  (dolist (address address-list)    (write-line address))))      (terpri) (terpri))    (format t "~%Done."))  dis-none)(defcom COM-LIST-MAILING-LIST-MEMBERSHIP"List all mailing lists that contain a particular member."  ()  (let* ((name (typein-line-readline "Member name (wildcards * and ? allowed)")) (mlist-list   (name:lookup-objects-from-properties :class :mailing-list :name-pattern "*" :read-only t)))    (loop      for mlist in mlist-list      for match = (lisp:find name (name:get-attribute-value mlist :address-list) :test-not #'match-mailing-list-member)      when match      collect (name:object-name mlist) into matches      finally      (format t "~&~%Mailing lists containing match for ~A:~2%" name)      (send *standard-output* :item-list nil matches))    (format t "~%Done."))  dis-none)(defun MATCH-MAILING-LIST-MEMBER (pattern name)  (name:pattern-match pattern name #\* #\?))(defcom COM-ADD-MAILING-LIST-MEMBER  "Add member(s) to the specified mailing list(s). New mailing lists are created as neccessary."  ()  (let* ((user-list (read-comma-delimited-list "Mailing list members (separated by commas):" nil nil nil t)) (mlist-list (read-mailing-list)))    (dolist (user user-list)      (dolist (mlist mlist-list)(name:add-group-member mlist :mailing-list :address-list user))))  dis-none)(defcom COM-DELETE-MAILING-LIST-MEMBER  "Delete member(s) from the specified mailing list(s)."  ()  (let* ((user-list (read-comma-delimited-list "Mailing list members (separated by commas):" nil nil nil t)) (mlist-list (read-mailing-list)))    (dolist (user user-list)      (dolist (mlist mlist-list)(name:delete-group-member mlist :mailing-list :address-list user))))  dis-none);;; Called "remove" to avoid completing on this accidentally(defcom COM-REMOVE-MAILING-LIST   "Remove the specified mailing list(s) from the namespace."  ()  (let ((mlist-list (read-mailing-list)))    (format t "~2%About to COMPLETELY remove the following mailing lists:~2%")    (send *standard-output* :item-list nil mlist-list)    (terpri)    (let ((*query-io* *terminal-io*))      (when (y-or-n-p "Remove?")(dolist (mlist mlist-list)  (name:delete-object mlist :mailing-list)))))  dis-none)(eval-when (load)  (set-comtab *zmacs-comtab* nil      '(("List Mailing List" . com-list-mailing-list)("List Mailing List Membership" . com-list-mailing-list-membership)("Add Mailing List Member" . com-add-mailing-list-member)("Delete Mailing List Member" . com-delete-mailing-list-member)("Remove Mailing List" . com-remove-mailing-list))))(defprop ? format-indirect format-ctl-multi-arg) (defun format-indirect (args ignore)  (let ((str (pop args)))    (let ((loop-arglist (if atsign-flag  args  (car args))))      (catch '|FORMAT-:^-POINT|(catch 'format-^-point  (let ((format-arglist loop-arglist))    (setq loop-arglist (format-ctl-string loop-arglist str)))))      (if atsign-flagloop-arglist(cdr args))))) ;;; This function is like F