X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=42d8616db2973844c8b311e97d199d340a0e326a;hb=432e59e56e22227e4b4d01ea6c26baf2239200e2;hp=2a35784ff691ce5a23832986ec77458439dfed42;hpb=1a41a5b2dd8e60004b7ca27566f9a8a5900c6ee1;p=elisp%2Fgnus.git- diff --git a/lisp/message.el b/lisp/message.el index 2a35784..42d8616 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -285,7 +285,8 @@ any confusion." :group 'message-sending :type 'function) -(defcustom message-subject-re-regexp "^[ \t]*\\([Rr][Ee]:[ \t]*\\)*[ \t]*" +(defcustom message-subject-re-regexp + "^[ \t]*\\([Rr][Ee]\\(\\[[0-9]*\\]\\)*:[ \t]*\\)*[ \t]*" "*Regexp matching \"Re: \" in the subject line." :group 'message-various :type 'regexp) @@ -349,7 +350,7 @@ value may go against RFC-1036 and draft-ietf-usefor-article-05.txt. " :type 'string :group 'message-various) -(defcustom message-interactive nil +(defcustom message-interactive t "Non-nil means when sending a message wait for and display errors. nil means let mailer mail back a message to report errors." :group 'message-sending @@ -1003,14 +1004,6 @@ If nil, Message won't auto-save." :group 'message-buffers :type '(choice directory (const :tag "Don't auto-save" nil))) -(defcustom message-buffer-naming-style 'unique - "*The way new message buffers are named. -Valid valued are `unique' and `unsent'." - :version "21.1" - :group 'message-buffers - :type '(choice (const :tag "unique" unique) - (const :tag "unsent" unsent))) - (defcustom message-default-charset (and (featurep 'xemacs) (not (featurep 'mule)) 'iso-8859-1) "Default charset used in non-MULE XEmacsen." @@ -1174,27 +1167,51 @@ candidates: "Face used for displaying MML." :group 'message-faces) +(defun message-font-lock-make-header-matcher (regexp) + (let ((form + `(lambda (limit) + (let ((start (point))) + (save-restriction + (widen) + (goto-char (point-min)) + (if (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$") + nil t) + (setq limit (min limit (match-beginning 0)))) + (goto-char start)) + (and (< start limit) + (re-search-forward ,regexp limit t)))))) + (if (featurep 'bytecomp) + (byte-compile form) + form))) + (defvar message-font-lock-keywords (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?")) - `((,(concat "^\\([Tt]o:\\)" content) + `((,(message-font-lock-make-header-matcher + (concat "^\\([Tt]o:\\)" content)) (1 'message-header-name-face) (2 'message-header-to-face nil t)) - (,(concat "^\\([GBF]?[Cc][Cc]:\\|[Rr]eply-[Tt]o:\\|" - "[Mm]ail-[Cc]opies-[Tt]o:\\|" - "[Mm]ail-[Rr]eply-[Tt]o:\\|" - "[Mm]ail-[Ff]ollowup-[Tt]o:\\)" content) + (,(message-font-lock-make-header-matcher + (concat "^\\([GBF]?[Cc][Cc]:\\|[Rr]eply-[Tt]o:\\|" + "[Mm]ail-[Cc]opies-[Tt]o:\\|" + "[Mm]ail-[Rr]eply-[Tt]o:\\|" + "[Mm]ail-[Ff]ollowup-[Tt]o:\\)" content)) (1 'message-header-name-face) (2 'message-header-cc-face nil t)) - (,(concat "^\\([Ss]ubject:\\)" content) + (,(message-font-lock-make-header-matcher + (concat "^\\([Ss]ubject:\\)" content)) (1 'message-header-name-face) (2 'message-header-subject-face nil t)) - (,(concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content) + (,(message-font-lock-make-header-matcher + (concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content)) (1 'message-header-name-face) (2 'message-header-newsgroups-face nil t)) - (,(concat "^\\([A-Z][^: \n\t]+:\\)" content) + (,(message-font-lock-make-header-matcher + (concat "^\\([A-Z][^: \n\t]+:\\)" content)) (1 'message-header-name-face) (2 'message-header-other-face nil t)) - (,(concat "^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):" content) + (,(message-font-lock-make-header-matcher + (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content)) (1 'message-header-name-face) (2 'message-header-name-face)) ,@(if (and mail-header-separator @@ -1202,7 +1219,11 @@ candidates: `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$") 1 'message-separator-face)) nil) - (,(concat "^\\(" message-cite-prefix-regexp "\\).*") + ((lambda (limit) + (re-search-forward (concat "^\\(" + message-cite-prefix-regexp + "\\).*") + limit t)) (0 'message-cited-text-face)) (,mime-edit-tag-regexp (0 'message-mml-face)))) @@ -1255,15 +1276,7 @@ The cdr of ech entry is a function for applying the face to a region.") (const :tag "ask" ask))) (defvar message-draft-coding-system - (cond - ((boundp 'MULE) '*junet*) - ((not (fboundp 'find-coding-system)) nil) - ((find-coding-system 'emacs-mule) - (if (memq system-type '(windows-nt ms-dos ms-windows)) - 'emacs-mule-dos 'emacs-mule)) - ((find-coding-system 'escape-quoted) 'escape-quoted) - ((find-coding-system 'no-conversion) 'no-conversion) - (t nil)) + nnheader-auto-save-coding-system "Coding system to compose mail.") (defcustom message-send-mail-partially-limit 1000000 @@ -1815,6 +1828,7 @@ Point is left at the beginning of the narrowed-to region." (define-key message-mode-map "\C-c\C-t" 'message-insert-to) (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups) + (define-key message-mode-map "\C-c\C-l" 'message-to-list-only) (define-key message-mode-map "\C-c\C-u" 'message-insert-or-toggle-importance) (define-key message-mode-map "\C-c\M-n" 'message-insert-disposition-notification-to) @@ -1844,7 +1858,6 @@ Point is left at the beginning of the narrowed-to region." (define-key message-mode-map "\t" 'message-tab) (define-key message-mode-map "\M-;" 'comment-region) - (define-key message-mode-map "\C-x\C-s" 'message-save-drafts) (define-key message-mode-map "\C-xk" 'message-mimic-kill-buffer)) (easy-menu-define @@ -1989,11 +2002,13 @@ C-c C-f move to a header field (and create it if there isn't): C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution + C-c C-f C-o move to From (\"Originator\") C-c C-f C-f move to Followup-To C-c C-f C-m move to Mail-Followup-To C-c C-f C-i cycle through Importance values C-c C-f c move to Mail-Copies-To C-c C-t `message-insert-to' (add a To header to a news followup) +C-c C-l `message-to-list-only' (removes all but list address in to/cc) C-c C-n `message-insert-newsgroups' (add a Newsgroup header to a news reply) C-c C-b `message-goto-body' (move to beginning of message text). C-c C-i `message-goto-signature' (move to the beginning of the signature). @@ -2235,7 +2250,7 @@ in the current mail buffer, and appends the current user-mail-address. If the optional argument `include-cc' is non-nil, the addresses in the Cc: header are also put into the MFT." - (interactive) + (interactive "P") (message-remove-header "Mail-Followup-To") (let* ((cc (and include-cc (message-fetch-field "Cc"))) (tos (if cc @@ -2956,7 +2971,8 @@ The text will also be indented the normal way." "Don't send the message you have been editing. Instead, just auto-save the buffer and then bury it." (interactive) - (message-save-drafts) + (set-buffer-modified-p t) + (save-buffer) (let ((actions message-postpone-actions) (frame (selected-frame)) (org-frame message-original-frame)) @@ -3064,36 +3080,41 @@ It should typically alter the sending method in some way or other." (success t) elem sent dont-barf-on-no-method (message-options message-options)) - (message-options-set-recipient) - (save-excursion - (set-buffer message-encoding-buffer) - (erase-buffer) - ;; ;; Avoid copying text props (except hard newlines). - ;; T-gnus change: copy all text props from the editing buffer - ;; into the encoding buffer. - (insert-buffer message-edit-buffer) - (funcall message-encode-function) - (while (and success - (setq elem (pop alist))) - (when (funcall (cadr elem)) - (when (and (or (not (memq (car elem) - message-sent-message-via)) - (if (or (message-gnksa-enable-p 'multiple-copies) - (not (eq (car elem) 'news))) - (y-or-n-p - (format - "Already sent message via %s; resend? " - (car elem))) - (error "Denied posting -- multiple copies"))) - (setq success (funcall (caddr elem) arg))) - (setq sent t))))) - (unless - (or sent - (not success) - (let ((fcc (message-fetch-field "Fcc")) - (gcc (message-fetch-field "Gcc"))) - (when (or fcc gcc) - (or (eq message-allow-no-recipients 'always) + (unwind-protect + (progn + (message-options-set-recipient) + (save-excursion + (set-buffer message-encoding-buffer) + (erase-buffer) + ;; ;; Avoid copying text props (except hard newlines). + ;; T-gnus change: copy all text props from the editing buffer + ;; into the encoding buffer. + (insert-buffer-substring message-edit-buffer) + (funcall message-encode-function) + (while (and success + (setq elem (pop alist))) + (when (funcall (cadr elem)) + (when (and + (or (not (memq (car elem) + message-sent-message-via)) + (if (or (message-gnksa-enable-p 'multiple-copies) + (not (eq (car elem) 'news))) + (y-or-n-p + (format + "Already sent message via %s; resend? " + (car elem))) + (error "Denied posting -- multiple copies"))) + (setq success (funcall (caddr elem) arg))) + (setq sent t))))) + (unless + (or + sent + (not success) + (let ((fcc (message-fetch-field "Fcc")) + (gcc (message-fetch-field "Gcc"))) + (when (or fcc gcc) + (or + (eq message-allow-no-recipients 'always) (and (not (eq message-allow-no-recipients 'never)) (setq dont-barf-on-no-method (gnus-y-or-n-p @@ -3101,23 +3122,22 @@ It should typically alter the sending method in some way or other." (cond ((and fcc gcc) "Fcc and Gcc") (fcc "Fcc") (t "Gcc")))))))))) - (error "No methods specified to send by")) - (prog1 - (when (or dont-barf-on-no-method - (and success sent)) - (message-do-fcc) - (save-excursion - (run-hooks 'message-sent-hook)) - (message "Sending...done") - ;; Mark the buffer as unmodified and delete auto-save. - (set-buffer-modified-p nil) - (delete-auto-save-file-if-necessary t) - (message-disassociate-draft) - ;; Delete other mail buffers and stuff. - (message-do-send-housekeeping) - (message-do-actions message-send-actions) - ;; Return success. - t) + (error "No methods specified to send by")) + (when (or dont-barf-on-no-method + (and success sent)) + (message-do-fcc) + (save-excursion + (run-hooks 'message-sent-hook)) + (message "Sending...done") + ;; Mark the buffer as unmodified and delete auto-save. + (set-buffer-modified-p nil) + (delete-auto-save-file-if-necessary t) + (message-disassociate-draft) + ;; Delete other mail buffers and stuff. + (message-do-send-housekeeping) + (message-do-actions message-send-actions) + ;; Return success. + t)) (kill-buffer message-encoding-buffer))))) (defun message-send-via-mail (arg) @@ -3429,7 +3449,7 @@ This sub function is for exclusive use of `message-send-mail'." ;; ;; Avoid copying text props (except hard newlines). ;; T-gnus change: copy all text props from the editing buffer ;; into the encoding buffer. - (insert-buffer message-encoding-buffer) + (insert-buffer-substring message-encoding-buffer) ;; Remove some headers. (save-restriction (message-narrow-to-headers) @@ -3469,61 +3489,67 @@ This sub function is for exclusive use of `message-send-mail'." " sendmail errors") 0)) resend-to-addresses delimline) - (let ((case-fold-search t)) - (save-restriction - (message-narrow-to-headers) - (setq resend-to-addresses (message-fetch-field "resent-to"))) - ;; Change header-delimiter to be what sendmail expects. - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (replace-match "\n") - (backward-char 1) - (setq delimline (point-marker)) - (run-hooks 'message-send-mail-hook) - ;; Insert an extra newline if we need it to work around - ;; Sun's bug that swallows newlines. - (goto-char (1+ delimline)) - (when (eval message-mailer-swallows-blank-line) - (newline)) - (when message-interactive - (save-excursion - (set-buffer errbuf) - (erase-buffer)))) - (let ((default-directory "/")) - (as-binary-process - (apply 'call-process-region - (append (list (point-min) (point-max) - (if (boundp 'sendmail-program) - sendmail-program - "/usr/lib/sendmail") - nil errbuf nil "-oi") - ;; Always specify who from, - ;; since some systems have broken sendmails. - ;; But some systems are more broken with -f, so - ;; we'll let users override this. - (if (null message-sendmail-f-is-evil) - (list "-f" (message-make-address))) - ;; These mean "report errors by mail" - ;; and "deliver in background". - (if (null message-interactive) '("-oem" "-odb")) - ;; Get the addresses from the message - ;; unless this is a resend. - ;; We must not do that for a resend - ;; because we would find the original addresses. - ;; For a resend, include the specific addresses. - (if resend-to-addresses - (list resend-to-addresses) - '("-t")))))) - (when message-interactive - (save-excursion - (set-buffer errbuf) - (goto-char (point-min)) - (while (re-search-forward "\n\n* *" nil t) - (replace-match "; ")) - (if (not (zerop (buffer-size))) - (error "Sending...failed to %s" - (buffer-substring (point-min) (point-max))))) + (unwind-protect + (progn + (let ((case-fold-search t)) + (save-restriction + (message-narrow-to-headers) + (setq resend-to-addresses (message-fetch-field "resent-to"))) + ;; Change header-delimiter to be what sendmail expects. + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + (backward-char 1) + (setq delimline (point-marker)) + (run-hooks 'message-send-mail-hook) + ;; Insert an extra newline if we need it to work around + ;; Sun's bug that swallows newlines. + (goto-char (1+ delimline)) + (when (eval message-mailer-swallows-blank-line) + (newline)) + (when message-interactive + (save-excursion + (set-buffer errbuf) + (erase-buffer)))) + (let* ((default-directory "/") + (cpr (as-binary-process + (apply + 'call-process-region + (append + (list (point-min) (point-max) + (if (boundp 'sendmail-program) + sendmail-program + "/usr/lib/sendmail") + nil errbuf nil "-oi") + ;; Always specify who from, + ;; since some systems have broken sendmails. + ;; But some systems are more broken with -f, so + ;; we'll let users override this. + (if (null message-sendmail-f-is-evil) + (list "-f" (message-make-address))) + ;; These mean "report errors by mail" + ;; and "deliver in background". + (if (null message-interactive) '("-oem" "-odb")) + ;; Get the addresses from the message + ;; unless this is a resend. + ;; We must not do that for a resend + ;; because we would find the original addresses. + ;; For a resend, include the specific addresses. + (if resend-to-addresses + (list resend-to-addresses) + '("-t"))))))) + (unless (or (null cpr) (zerop cpr)) + (error "Sending...failed with exit value %d" cpr))) + (when message-interactive + (save-excursion + (set-buffer errbuf) + (goto-char (point-min)) + (while (re-search-forward "\n\n* *" nil t) + (replace-match "; ")) + (if (not (zerop (buffer-size))) + (error "Sending...failed to %s" + (buffer-substring (point-min) (point-max))))))) (when (bufferp errbuf) (kill-buffer errbuf))))) @@ -3665,7 +3691,8 @@ Do not use this for anything important, it is cryptographically weak." This is the value of `canlock-password', if that option is non-nil. Otherwise, generate and save a value for `canlock-password' first." (unless canlock-password - (customize-save-variable 'canlock-password (message-canlock-generate))) + (customize-save-variable 'canlock-password (message-canlock-generate)) + (setq canlock-password-for-verify canlock-password)) canlock-password) (defun message-insert-canlock () @@ -3730,7 +3757,7 @@ Otherwise, generate and save a value for `canlock-password' first." (set-buffer tembuf) (buffer-disable-undo) (erase-buffer) - (insert-buffer message-encoding-buffer) + (insert-buffer-substring message-encoding-buffer) ;; Remove some headers. (save-restriction (message-narrow-to-headers) @@ -4184,7 +4211,7 @@ Otherwise, generate and save a value for `canlock-password' first." (erase-buffer) (goto-char (point-min)) (set-buffer-multibyte nil) - (insert-buffer message-encoding-buffer) + (insert-buffer-substring message-encoding-buffer) (goto-char (point-min)) (if (re-search-forward "[^\x00-\x7f]" nil t) (y-or-n-p @@ -4555,10 +4582,24 @@ give as trustworthy answer as possible." (or mail-host-address (message-make-fqdn))) -(defun message-make-mft () - "Return the Mail-Followup-To header." +(defun message-to-list-only () + (interactive) + (let ((listaddr (message-make-mft t))) + (when listaddr + (save-excursion + (message-remove-header "to") + (message-remove-header "cc") + (message-position-on-field "To" "X-Draft-From") + (insert listaddr))))) + +(defun message-make-mft (&optional only-show-subscribed) + "Return the Mail-Followup-To header. If passed the optional +argument `only-show-subscribed' only return the subscribed address (and +not the additional To and Cc header contents)." (let* ((case-fold-search t) - (msg-recipients (message-options-get 'message-recipients)) + (to (message-fetch-field "To")) + (cc (message-fetch-field "cc")) + (msg-recipients (concat to (and to cc ", ") cc)) (recipients (mapcar 'mail-strip-quoted-names (message-tokenize-header msg-recipients))) @@ -4584,16 +4625,16 @@ give as trustworthy answer as possible." (mapcar 'funcall message-subscribed-address-functions)))) (save-match-data - (when (eval - (apply 'append '(or) - (mapcar - #'(lambda (regexp) - (mapcar - #'(lambda (recipient) - `(string-match ,regexp ,recipient)) - recipients)) - mft-regexps))) - msg-recipients)))) + (let ((subscribed-lists nil) + (list + (loop for recipient in recipients + when (loop for regexp in mft-regexps + when (string-match regexp recipient) return t) + return recipient))) + (when list + (if only-show-subscribed + list + msg-recipients)))))) ;; Dummy to avoid byte-compile warning. (defvar mule-version) @@ -4610,7 +4651,11 @@ string." (goto-char (point-min)) (let ((case-fold-search t) user-agent start p end) - (if (re-search-forward "^User-Agent:[\t ]*" nil t) + (if (re-search-forward + (concat "^User-Agent:[\t ]*\\(" + (regexp-quote gnus-product-name) + "/[0-9.]+\\([ \t\r\n]*([^)]+)\\)*\\)?[\t ]*") + nil t) (progn (setq start (match-beginning 0) p (match-end 0) @@ -4915,6 +4960,9 @@ than 988 characters long, and if they are not, trim them until they are." (defun message-beginning-of-line (&optional n) "Move point to beginning of header value or to beginning of line." (interactive "p") + (let ((zrs 'zmacs-region-stays)) + (when (and (interactive-p) (boundp zrs)) + (set zrs t))) (if (message-point-in-header-p) (let* ((here (point)) (bol (progn (beginning-of-line n) (point))) @@ -6089,35 +6137,37 @@ which specify the range to operate on." (defun message-tool-bar-map () (or message-tool-bar-map (setq message-tool-bar-map - (and (fboundp 'tool-bar-add-item-from-menu) - tool-bar-mode - (let ((tool-bar-map (copy-keymap tool-bar-map)) - (load-path (mm-image-load-path))) - ;; Zap some items which aren't so relevant and take - ;; up space. - (dolist (key '(print-buffer kill-buffer save-buffer - write-file dired open-file)) - (define-key tool-bar-map (vector key) nil)) - (tool-bar-add-item-from-menu - 'message-send-and-exit "mail_send" message-mode-map) - (tool-bar-add-item-from-menu - 'message-kill-buffer "close" message-mode-map) - (tool-bar-add-item-from-menu - 'message-dont-send "cancel" message-mode-map) - (tool-bar-add-item-from-menu - 'mime-edit-insert-file "attach" message-mode-map) - (tool-bar-add-item-from-menu - 'ispell-message "spell" message-mode-map) - (tool-bar-add-item-from-menu - 'message-insert-importance-high "important" - message-mode-map) - (tool-bar-add-item-from-menu - 'message-insert-importance-low "unimportant" - message-mode-map) - (tool-bar-add-item-from-menu - 'message-insert-disposition-notification-to "receipt" - message-mode-map) - tool-bar-map))))) + (and + (condition-case nil (require 'tool-bar) (error nil)) + (fboundp 'tool-bar-add-item-from-menu) + tool-bar-mode + (let ((tool-bar-map (copy-keymap tool-bar-map)) + (load-path (mm-image-load-path))) + ;; Zap some items which aren't so relevant and take + ;; up space. + (dolist (key '(print-buffer kill-buffer save-buffer + write-file dired open-file)) + (define-key tool-bar-map (vector key) nil)) + (tool-bar-add-item-from-menu + 'message-send-and-exit "mail_send" message-mode-map) + (tool-bar-add-item-from-menu + 'message-kill-buffer "close" message-mode-map) + (tool-bar-add-item-from-menu + 'message-dont-send "cancel" message-mode-map) + (tool-bar-add-item-from-menu + 'mime-edit-insert-file "attach" message-mode-map) + (tool-bar-add-item-from-menu + 'ispell-message "spell" message-mode-map) + (tool-bar-add-item-from-menu + 'message-insert-importance-high "important" + message-mode-map) + (tool-bar-add-item-from-menu + 'message-insert-importance-low "unimportant" + message-mode-map) + (tool-bar-add-item-from-menu + 'message-insert-disposition-notification-to "receipt" + message-mode-map) + tool-bar-map))))) ;;; Group name completion. @@ -6134,6 +6184,16 @@ which specify the range to operate on." :group 'message :type '(alist :key-type regexp :value-type function)) +(defcustom message-expand-name-function + (if (fboundp 'bbdb-complete-name) + 'bbdb-complete-name + (if (fboundp 'lsdb-complete-name) + 'lsdb-complete-name + 'expand-abbrev)) + "*A function called to expand addresses in field body." + :group 'message + :type 'function) + (defcustom message-tab-body-function nil "*Function to execute when `message-tab' (TAB) is executed in the body. If nil, the function bound in `text-mode-map' or `global-map' is executed." @@ -6198,9 +6258,7 @@ those headers." (delete-region (point) (progn (forward-line 3) (point)))))))))) (defun message-expand-name () - (if (fboundp 'bbdb-complete-name) - (bbdb-complete-name) - (expand-abbrev))) + (funcall message-expand-name-function)) ;;; Help stuff. @@ -6432,22 +6490,6 @@ regexp varstr." (require 'messagexmas) (message-xmas-redefine)) -(defun message-save-drafts () - "Postponing the message." - (interactive) - (message "Saving %s..." buffer-file-name) - (let ((reply-headers message-reply-headers) - (buffer (current-buffer))) - (with-temp-file buffer-file-name - (insert-buffer buffer) - (setq message-reply-headers reply-headers) - (message-generate-headers '((optional . In-Reply-To))) - (let ((mime-header-encode-method-alist - '((eword-encode-unstructured-field-body)))) - (mime-edit-translate-buffer))) - (set-buffer-modified-p nil)) - (message "Saving %s...done" buffer-file-name)) - (provide 'message) (run-hooks 'message-load-hook)