# HG changeset patch # User Henry S. Thompson # Date 1703095114 0 # Node ID b09e8120dc5372df25194c8bbe94433f179cace4 # Parent eee08de75336f3cc098821fb7718605a01e8859f copied in from lucid, moved use-text-not-html support to my-news, still has a lot of diary-related stuff which is _currently_ only relevant on ecclerig diff -r eee08de75336 -r b09e8120dc53 mail-extras.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/mail-extras.el Wed Dec 20 17:58:34 2023 +0000 @@ -0,0 +1,492 @@ +;; Last edited: Fri Nov 2 10:26:24 1990 +;; extra widgets for rmail and rmailsum +;; Copyright (C) 1990 Henry S. Thompson + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + +(require 'rmail) +(require 'sendmail) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; mods and fixes for reading mail ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar ht-last-file (expand-file-name "~/XMAIL") + "default for moving mail to") +(make-variable-buffer-local 'ht-last-file) + +(defvar rmht-always-recompress t + "If non-nil, when saving into compressed babyl file, +always recompress and save immediately") + +(defvar rmht-allow-autosave t + "if non-nil, leaves autosave alone for compressed babyl files, +otherwise turns it off") + +(add-hook 'rmail-mode-hook 'rmail-mode-fun1) +(add-hook 'rmail-mode-hook 'rmail-mode-fun2) + +;; run the first time in to RMAIL +(defun rmail-mode-fun1 () + "add ht's mods to RMAIL" + (define-key rmail-mode-map "R" 'reply-w/o-cc) + (define-key rmail-mode-map "M" 'rmht-output) + (define-key rmail-mode-map "H" 'print-buffer) + (define-key rmail-mode-map "W" 'edit-and-move-to-diary) + (define-key rmail-mode-map "D" 'update-default-diary) + (define-key rmail-mode-map "F" 're-post-failed-mail) + (define-key rmail-mode-map "B" 'ht-write-body-to-file) + (define-key rmail-mode-map "E" 'extract-attachment) + ;; fix the doc string + (repl-comment 'rmail-mode + "Rmail Mode is used by \\[rmail] for editing Rmail files. +All normal editing commands are turned off. +Instead, these commands are available (additions from ht's mail-extras.el +indicated by *: + +. Move point to front of this message (same as \\[beginning-of-buffer]). +SPC Scroll to next screen of this message. +DEL Scroll to previous screen of this message. +n Move to Next non-deleted message. +p Move to Previous non-deleted message. +M-n Move to Next message whether deleted or not. +M-p Move to Previous message whether deleted or not. +> Move to the last message in Rmail file. +j Jump to message specified by numeric position in file. +M-s Search for string and show message it is found in. +d Delete this message, move to next nondeleted. +C-d Delete this message, move to previous nondeleted. +u Undelete message. Tries current message, then earlier messages + till a deleted message is found. +e Expunge deleted messages. +s Expunge and save the file. +q Quit Rmail: expunge, save, then switch to another buffer. +C-x C-s Save without expunging. +g Move new mail from system spool directory or mbox into this file. +m Mail a message (same as \\[mail-other-window]). +c Continue composing outgoing message started before. +r Reply to this message. Like m but initializes some fields. +R * Like r, but reply to originator only. +f Forward this message to another user. +F * like f, but assumes message is \"failed mail\" for re-sending +o Output this message to an Rmail file (append it). +C-o Output this message to a Unix-format mail file (append it). +M * Output this message to a file, + in format determined by extension (babyl for RMAIL/msg for Unix). +B * Write the body of the message to a file, leaving a pointer +H * Print the message (same as \\\\[print-buffer]).\\ +i Input Rmail file. Run Rmail on that file. +a Add label to message. It will be displayed in the mode line. +k Kill label. Remove a label from current message. +C-M-n Move to Next message with specified label + (label defaults to last one specified). + Standard labels: filed, unseen, answered, forwarded, deleted. + Any other label is present only if you add it with `a'. +C-M-p Move to Previous message with specified label +h, C-M-h Show headers buffer, with a one line summary of each message. +l, C-M-l Like h only just messages with particular label(s) are summarized. +C-M-r Like h only just messages with particular recipient(s) are summarized. +t Toggle header, show Rmail header if unformatted or vice versa. +w Edit the current message. C-c C-c to return to Rmail. +W * Edit the subject field. C-c C-c to move the message to the Diary. +D * Update the Diary. + +Messages for the diary (see also \\[describe-mode] in rmail-summary mode +or \\[describe-function] rmail-summary-mode) should have a subject field +which begins with the date and optional time of the event described therein. +These must be in the form + d m y t +where d is one or two digits for the day, +m is either the full month name or the first three letters thereof, +y is two digits for the year, +and t, if present, is 4 digits for the time, +thus for example + 31 Jun 91 1530 +") + (remove-hook 'rmail-mode-hook 'rmail-mode-fun1)) + +(defun rmail-mode-fun2 () + "always run in RMAIL mode" + (setq case-fold-search t)) + +(defun reply-w/o-cc () + "Reply as r, but without sending to other recipients" + (interactive) + (rmail-reply t)) + +(defun rmht-output (&optional file-name gnus) + "Move to a file, determining format by extension (babyl/msg)" + (interactive) + (if (not file-name) + (setq file-name (car (get-move-file-name)))) + (if (string-match "\\.g?[zZ]$" file-name) + (let ((clean-file-name (substring file-name 0 (match-beginning 0))) + there) + (if (setq there (get-file-buffer clean-file-name)) + nil + (save-window-excursion (rmail clean-file-name) + (setq there + (get-file-buffer clean-file-name)))) + (rmht-output clean-file-name gnus) + (if rmht-always-recompress + (save-excursion + (set-buffer there) + (save-buffer)) + (if (not rmht-allow-autosave) + (save-excursion + (set-buffer there) + (auto-save-mode -1))))) + (setq file-name (expand-file-name file-name)) + (save-excursion + (if (string-match "\\.babyl$" file-name) + (if gnus + (gnus-output-to-rmail file-name) + (rmail-output-to-rmail-file file-name 1)) + (if (string-match "\\.msg$" file-name) + (if (or (get-file-buffer file-name) + (file-exists-p file-name) + (yes-or-no-p + (concat "\"" file-name "\" does not exist, create it? "))) + (rmail-output file-name 1) + (error "Output file does not exist")) + (error "not a valid mail file: %s" file-name)))) + (setq ht-last-file file-name) + (if (not gnus) (ht-rmail-delete-forward)))) + +(defun get-move-file-name () + "get a file name for moving a message to" + (list (read-file-name + (concat "Output message to file: (default " + (file-name-nondirectory ht-last-file) + ") ") + (file-name-directory ht-last-file) + ht-last-file))) + +(defun re-post-failed-mail () + "try to salvage the original from failed mail and prepare to resend it" + (interactive) + (rmail-forward nil) + (let ((top (point)) + subjp textp) + (re-search-forward "^Subject: ") + (kill-line nil) + (setq subjp (point)) + (re-search-forward "^From: ") ; the bouncer + (re-search-forward "^From: ") ; should be us + (re-search-forward "^Subject: ") + (kill-line nil) + (save-excursion (goto-char subjp) + (yank)) + (beginning-of-line 3) + (setq textp (point)) + (goto-char top) + (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) + (beginning-of-line 2) + (delete-region (point) textp) + (goto-char top))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; mods and fixes for mail summaries ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(add-hook 'rmail-summary-mode-hook 'rmail-summary-mode-fun1) + +;; run the first time we make a summary window +(defun rmail-summary-mode-fun1 () + "install ht's mods" + (define-key rmail-summary-mode-map "r" 'rms-reply-w-cc) + (define-key rmail-summary-mode-map "R" 'rms-reply-w/o-cc) + (define-key rmail-summary-mode-map "s" 'diary-save) + (define-key rmail-summary-mode-map "m" 'rms-move) + (define-key rmail-summary-mode-map "d" 'rms-delete) + (define-key rmail-summary-mode-map "h" 'rms-hardcopy) + (define-key rmail-summary-mode-map " " 'ht-rmailsum-scroll-msg-up) + (define-key rmail-summary-mode-map "\177" 'ht-rmailsum-scroll-msg-down) + ;; fix the doc string + (repl-comment 'rmail-summary-mode + "Major mode in effect in Rmail summary buffer. +A subset of the Rmail mode commands are supported in this mode. +As commands are issued in the summary buffer the corresponding +mail message is displayed in the rmail buffer. +Modifications from ht's mail-extras.el indicated with *: + +n Move to next undeleted message, or arg messages. +p Move to previous undeleted message, or arg messages. +C-n Move to next, or forward arg messages. +C-p Move to previous, or previous arg messages. +j Jump to the message at the cursor location. +d Delete the message at the cursor location and move to next message. +u Undelete this or previous deleted message. +q Quit Rmail. +x Exit and kill the summary window. +space * If cursor is on line of current message, + scroll message window forward. Otherwise, jump to indicated message. +delete * same as space, but scrolls backward. +r * Same as r in rmail window. Reply to current message. +R * Same as R in rmail window. Reply to current message, originator only. +s * Update and save the rmail file, and re-summarise. Re-sorts if Diary. +m * Same as M in rmail window. Moves message to file. +h * Same as H in rmail window. Prints message on line printer. + +Entering this mode calls value of hook variable rmail-summary-mode-hook. + +If the file summarised is called by the name given in ht-diary-file-name, +which defaults to diary.babyl, +then the summary will be called *Diary*, sorted in date order and +formated in a special way. + +Messages in the diary should have a subject field +which begins with the date and optional time of the event described therein. +These must be in the form + d m y t +where d is one or two digits for the day, +m is either the full month name or the first three letters thereof, +y is two digits for the year, +and t, if present, is 4 digits for the time, +thus for example +Subject: 31 Jun 91 1530 Hades freezing ceremony followed by champagne reception +") + (remove-hook 'rmail-summary-mode-hook 'rmail-summary-mode-fun1)) + +(defun rmht-sum-reply (sender-only) + "reply to current message" + (rmail-summary-goto-msg) + (pop-to-buffer rmail-buffer) + (rmail-reply sender-only) + (switch-to-buffer rmail-summary-buffer) + (switch-to-buffer "*mail*") +) + +(defun rms-reply-w-cc () + "Do r in RMAIL - reply to everybody" + (interactive) + (rmht-sum-reply nil)) + +(defun rms-reply-w/o-cc () + "Do R in RMAIL - reply to sender only" + (interactive) + (rmht-sum-reply t)) + +(defun rms-save () + "expunge deleted messages, save RMAIL file and re-display headers" + (interactive) + (pop-to-buffer rmail-buffer) + (rmail-expunge-and-save) + (rmail-summary)) + +(defun rms-delete () + "delete current and move down to next in summary buffer" + (interactive) + (rmail-summary-goto-msg) + (save-excursion + (rmail-summary-delete-forward nil)) + (rms-del)) + +(defun rms-move () + "Move to a file, mode determined by file extension (babyl/msg)" + (interactive) + (rmail-summary-goto-msg) + (save-excursion + (set-buffer rmail-buffer) + (rmht-output)) + (rms-del)) + +(defun rms-del () + "mark current summary line as deleted and move down" + (let ((buffer-read-only nil)) + (skip-chars-forward " ") + (skip-chars-forward "[0-9]") + (delete-char 1) + (insert "D")) + (forward-line 1)) + +(defun rms-hardcopy () + "hardcopy the current message" + (interactive) + (pop-to-buffer rmail-buffer) + (print-buffer) + (pop-to-buffer rmail-summary-buffer)) + + +;; fix interpretation of SPACE and DEL in summary windows to +;; 1) scroll the right window regardless of how many panes are up; +;; 2) go to the message associated with the current line if not already there, +;; a la gnus, for instance + +(defun ht-rmailsum-normalise () + "if not already showing message named on current line, go to it & return t" + (beginning-of-line) + (let ((current-msg-num (cdr (assoc 'rmail-current-message + (buffer-local-variables + (or rmail-buffer + (error + "not in a summary buffer")))))) + (line-message-num (string-to-int + (buffer-substring + (point) + (min (point-max)(+ 5 (point))))))) + (if (= current-msg-num line-message-num) + nil + (rmail-summary-goto-msg line-message-num) + t))) + +(defun ht-rmailsum-scroll-msg-up (&optional dist) + "goto other message or scroll current message forward" + (interactive "P") + (if (ht-rmailsum-normalise) + nil + (pop-to-buffer rmail-buffer) + (scroll-up dist) + (pop-to-buffer rmail-summary-buffer))) + +(defun ht-rmailsum-scroll-msg-down (&optional dist) + "goto other message or scroll current message backward" + (interactive "P") + (if (ht-rmailsum-normalise) + nil + (pop-to-buffer rmail-buffer) + (scroll-down dist) + (pop-to-buffer rmail-summary-buffer))) + +(autoload 'edit-and-move-to-diary "diary") +(autoload 'update-diary "diary") +(autoload 'diary-save "diary") + +;;; I _think_ (almost?) everything above here is diary-related, so belongs +;;; in diary.el. + +;; unfortunately, gnus mucks about with the buffers before calling +;; mail, so we have to intervene to make the about-to-mail-hook work right + +(defun ht-Subject-mode-fun () + "fix the map to save window state" +; (define-key gnus-summary-mode-map "r" 'ht-Subject-mail-reply) +; (define-key gnus-summary-mode-map "R" 'ht-Subject-mail-reply-with-original) +; (define-key gnus-summary-mode-map "m" 'ht-Subject-mail-other-window) + (define-key gnus-summary-save-map "M" 'ht-Subject-move) + (remove-hook 'gnus-summary-mode-hook 'ht-Subject-mode-fun)) + +(add-hook 'gnus-summary-mode-hook 'ht-Subject-mode-fun) + +(defun ht-Subject-mail-reply (yank) + "Runs about-to-mail-hook, then calls gnus-summary-mail-reply" + (interactive "P") + (require 'sendmail) + (run-hooks 'about-to-mail-hook) + (let (about-to-mail-hook) + (gnus-summary-reply yank))) + +(defun ht-Subject-mail-reply-with-original () + "Runs about-to-mail-hook, then calls gnus-summary-mail-reply-with-original" + (interactive) + (require 'sendmail) + (run-hooks 'about-to-mail-hook) + (let (about-to-mail-hook) + (gnus-summary-reply-with-original))) + +(defun ht-Subject-mail-other-window () + "Runs about-to-mail-hook, then calls gnus-summary-mail-other-window" + (interactive) + (require 'sendmail) + (run-hooks 'about-to-mail-hook) + (let (about-to-mail-hook) + (gnus-summary-mail-other-window))) + +(defun ht-Subject-move () + "Move article to a file, mode determined by file extension (babyl/msg)" + (interactive) + (gnus-summary-select-article) + (save-excursion + (set-buffer gnus-article-buffer) + (rmht-output nil t))) + + +(defun ht-write-body-to-file (file) + "Write the body of the message to a file and replace it with a pointer" + (interactive "FFile to save in: ") + (goto-char (point-min)) + (or (search-forward "\n\n" nil t) + (error "Can't find text")) + (write-region (point)(point-max) file) + (rmail-edit-current-message) + (delete-region (point)(point-max)) + (insert "\n>> " file "\n") + (rmail-cease-edit) + (rmht-output)) + +(defun extract-attachment () + "extract attachments from a multi-part mime message" + (interactive) + (rmail-toggle-header) + (mime/viewer-mode) + (let ((pt 0)) + (while (progn + (mime-viewer/next-content) + (and + (equal "*Preview-RMAIL*" (buffer-name (current-buffer))) + (not (= pt (point))))) + (setq pt (point)) + (if (looking-at "^\\[[0-9]* [^ ]+ <") + (mime-viewer/extract-content)))) + (if (not (equal "*Preview-RMAIL*" (buffer-name (current-buffer)))) + ;; we fell off the end + (rmail-previous-undeleted-message 1)) + (kill-buffer "*Preview-RMAIL*") + ) + +;(load-library "mailcrypt") ; provides "mc-setversion" +;(mc-setversion "gpg") ; for PGP 2.6 (default); also "5.0" and "gpg" +;(autoload 'mc-install-write-mode "mailcrypt" nil t) +;(autoload 'mc-install-read-mode "mailcrypt" nil t) +;(add-hook 'mail-mode-hook 'mc-install-write-mode) +;(add-hook 'gnus-summary-mode-hook 'mc-install-read-mode) +;(add-hook 'message-mode-hook 'mc-install-write-mode) +;(add-hook 'news-reply-mode-hook 'mc-install-write-mode) +;(setq mc-passwd-timeout 6000) +;;; Key server at Cambridge University (Cambridge, England) +;(setq mc-pgp-fetch-methods '(mc-pgp-fetch-from-keyrings +; mc-pgp-fetch-from-http)) +;(require 'pgg) +;(add-hook 'message-send-hook 'my-sign-message) +(setq hack-yn-map (copy-keymap query-replace-map)) +(define-key hack-yn-map 'return 'act) + +(defun my-sign-message () + (goto-char (point-min)) + (unless + (or + (re-search-forward "<#\\(part\\|mml\\) " nil t) + ; signing attachments doesn't seem + ; to work well + (search-forward "\n-- \nHenry S. Thompson, Central Edinburgh LM" nil t) + ; Don't sign Quaker mail + ) + (let* ((headers (mail-header-extract-no-properties)) + (cc (mail-header 'cc)) + (to (mail-header 'to))) + (if (and to + (not (string-match "htcalendar[@]markup\.co\.uk" to)) + (not (string-match "^ht$" to)) + (or + (string-match "w3.org" to) + (and cc (string-match "w3.org" cc)) + (let ((query-replace-map hack-yn-map)) + (y-or-n-p "Sign message? ")))) + (mml-secure-message-sign-pgp))))) + +(provide 'mail-extras)