X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=22f2a30a4d5d6f051eeab031d44619fd7bc76797;hb=a3e52de2271f1336cb7e3c31c14bd122f4db609e;hp=f896d0106869e67584164cb177e2a2c75192a732;hpb=599f0297c52c8dd6c4c3d364c8ba273a2ed8ae69;p=gnus diff --git a/lisp/message.el b/lisp/message.el index f896d0106..22f2a30a4 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -591,6 +591,25 @@ actually occur." (defvar message-mh-deletable-headers '(Message-ID Date Lines Sender) "If non-nil, delete the deletable headers before feeding to mh.") +(defvar message-send-method-alist + '((news message-news-p message-send-via-news) + (mail message-mail-p message-send-via-mail)) + "Alist of ways to send outgoing messages. +Each element has the form + + \(TYPE PREDICATE FUNCTION) + +where TYPE is a symbol that names the method; PREDICATE is a function +called without any parameters to determine whether the message is +a message of type TYPE; and FUNCTION is a function to be called if +PREDICATE returns non-nil. FUNCTION is called with one parameter -- +the prefix.") + +(defvar message-mail-alias-type 'abbrev + "*What alias expansion type to use in Message buffers. +The default is `abbrev', which uses mailabbrev. nil switches +mail aliases off.") + ;;; Internal variables. ;;; Well, not really internal. @@ -720,19 +739,19 @@ Defaults to `text-mode-abbrev-table'.") (let* ((cite-prefix "A-Za-z") (cite-suffix (concat cite-prefix "0-9_.@-")) (content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)")) - `((,(concat "^\\(To:\\)" content) + `((,(concat "^\\([Tt]o:\\)" content) (1 'message-header-name-face) (2 'message-header-to-face nil t)) - (,(concat "^\\(^[GBF]?[Cc][Cc]:\\|^Reply-To:\\)" content) + (,(concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content) (1 'message-header-name-face) (2 'message-header-cc-face nil t)) - (,(concat "^\\(Subject:\\)" content) + (,(concat "^\\([Ss]ubject:\\)" content) (1 'message-header-name-face) (2 'message-header-subject-face nil t)) - (,(concat "^\\(Newsgroups:\\|Followup-to:\\)" content) + (,(concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content) (1 'message-header-name-face) (2 'message-header-newsgroups-face nil t)) - (,(concat "^\\([^: \n\t]+:\\)" content) + (,(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) @@ -902,12 +921,12 @@ The cdr of ech entry is a function for applying the face to a region.") (not paren)))) (push (buffer-substring beg (point)) elems) (setq beg (match-end 0))) - ((= (following-char) ?\") + ((= (char-after (point)) ?\") (setq quoted (not quoted))) - ((and (= (following-char) ?\() + ((and (= (char-after (point)) ?\() (not quoted)) (setq paren t)) - ((and (= (following-char) ?\)) + ((and (= (char-after (point)) ?\)) (not quoted)) (setq paren nil)))) (nreverse elems))))) @@ -1194,10 +1213,10 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (kill-all-local-variables) (make-local-variable 'message-reply-buffer) (setq message-reply-buffer nil) - (set (make-local-variable 'message-send-actions) nil) - (set (make-local-variable 'message-exit-actions) nil) - (set (make-local-variable 'message-kill-actions) nil) - (set (make-local-variable 'message-postpone-actions) nil) + (make-local-variable 'message-send-actions) + (make-local-variable 'message-exit-actions) + (make-local-variable 'message-kill-actions) + (make-local-variable 'message-postpone-actions) (set-syntax-table message-mode-syntax-table) (use-local-map message-mode-map) (setq local-abbrev-table message-mode-abbrev-table) @@ -1242,9 +1261,10 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (easy-menu-add message-mode-menu message-mode-map) (easy-menu-add message-mode-field-menu message-mode-map) ;; Allow mail alias things. - (if (fboundp 'mail-abbrevs-setup) - (mail-abbrevs-setup) - (funcall (intern "mail-aliases-setup"))) + (when (eq message-mail-alias-type 'abbrev) + (if (fboundp 'mail-abbrevs-setup) + (mail-abbrevs-setup) + (funcall (intern "mail-aliases-setup")))) (run-hooks 'text-mode-hook 'message-mode-hook)) @@ -1327,11 +1347,15 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." -(defun message-insert-to () - "Insert a To header that points to the author of the article being replied to." - (interactive) - (let ((co (message-fetch-field "mail-copies-to"))) - (when (and co +(defun message-insert-to (&optional force) + "Insert a To header that points to the author of the article being replied to. +If the original author requested not to be sent mail, the function signals +an error. +With the prefix argument FORCE, insert the header anyway." + (interactive "P") + (let ((co (message-fetch-reply-field "mail-copies-to"))) + (when (and (null force) + co (equal (downcase co) "never")) (error "The user has requested not to have copies sent via mail"))) (when (and (message-position-on-field "To") @@ -1515,14 +1539,20 @@ However, if `message-yank-prefix' is non-nil, insert that prefix on each line." (let ((start (point))) ;; Remove unwanted headers. (when message-ignored-cited-headers - (save-restriction - (narrow-to-region - (goto-char start) - (if (search-forward "\n\n" nil t) - (1- (point)) - (point))) - (message-remove-header message-ignored-cited-headers t) - (goto-char (point-max)))) + (let (all-removed) + (save-restriction + (narrow-to-region + (goto-char start) + (if (search-forward "\n\n" nil t) + (1- (point)) + (point))) + (message-remove-header message-ignored-cited-headers t) + (when (= (point-min) (point-max)) + (setq all-removed t)) + (goto-char (point-max))) + (if all-removed + (goto-char start) + (forward-line 1)))) ;; Delete blank lines at the start of the buffer. (while (and (point-min) (eolp) @@ -1706,30 +1736,43 @@ the user from the mailer." (message-fix-before-sending) (run-hooks 'message-send-hook) (message "Sending...") - (when (and (or (not (message-news-p)) - (and (or (not (memq 'news message-sent-message-via)) - (y-or-n-p - "Already sent message via news; resend? ")) - (funcall message-send-news-function arg))) - (or (not (message-mail-p)) - (and (or (not (memq 'mail message-sent-message-via)) - (y-or-n-p - "Already sent message via mail; resend? ")) - (message-send-mail arg)))) - (message-do-fcc) - ;;(when (fboundp 'mail-hist-put-headers-into-history) - ;; (mail-hist-put-headers-into-history)) - (run-hooks 'message-sent-hook) - (message "Sending...done") - ;; If buffer has no file, mark it as unmodified and delete autosave. - (unless buffer-file-name - (set-buffer-modified-p nil) - (delete-auto-save-file-if-necessary t)) - ;; Delete other mail buffers and stuff. - (message-do-send-housekeeping) - (message-do-actions message-send-actions) - ;; Return success. - t))) + (let ((alist message-send-method-alist) + (success t) + elem sent) + (while (and success + (setq elem (pop alist))) + (when (and (or (not (funcall (cadr elem))) + (and (or (not (memq (car elem) + message-sent-message-via)) + (y-or-n-p + (format + "Already sent message via %s; resend? " + (car elem)))) + (setq success (funcall (caddr elem) arg))))) + (setq sent t))) + (when (and success sent) + (message-do-fcc) + ;;(when (fboundp 'mail-hist-put-headers-into-history) + ;; (mail-hist-put-headers-into-history)) + (run-hooks 'message-sent-hook) + (message "Sending...done") + ;; If buffer has no file, mark it as unmodified and delete autosave. + (unless buffer-file-name + (set-buffer-modified-p nil) + (delete-auto-save-file-if-necessary t)) + ;; Delete other mail buffers and stuff. + (message-do-send-housekeeping) + (message-do-actions message-send-actions) + ;; Return success. + t)))) + +(defun message-send-via-mail (arg) + "Send the current message via mail." + (message-send-mail arg)) + +(defun message-send-via-news (arg) + "Send the current message via news." + (funcall message-send-news-function arg)) (defun message-fix-before-sending () "Do various things to make the message nice before sending it." @@ -1789,7 +1832,7 @@ the user from the mailer." (message-remove-header message-ignored-mail-headers t)) (goto-char (point-max)) ;; require one newline at the end. - (or (= (preceding-char) ?\n) + (or (= (char-before (point)) ?\n) (insert ?\n)) (when (and news (or (message-fetch-field "cc") @@ -1966,7 +2009,7 @@ to find out how to use this." (message-remove-header message-ignored-news-headers t)) (goto-char (point-max)) ;; require one newline at the end. - (or (= (preceding-char) ?\n) + (or (= (char-before (point)) ?\n) (insert ?\n)) (let ((case-fold-search t)) ;; Remove the delimiter. @@ -2026,6 +2069,16 @@ to find out how to use this." (defun message-check-news-header-syntax () (and + ;; Check the Subject header. + (message-check 'subject + (let* ((case-fold-search t) + (subject (message-fetch-field "subject"))) + (or + (and subject + (not (string-match "\\`[ \t]*\\'" subject))) + (ignore + (message + "The subject field is empty or missing. Posting is denied."))))) ;; Check for commands in Subject. (message-check 'subject-cmsg (if (string-match "^cmsg " (message-fetch-field "subject")) @@ -2099,16 +2152,6 @@ to find out how to use this." (y-or-n-p (format "The Message-ID looks strange: \"%s\". Really post? " message-id))))) - ;; Check the Subject header. - (message-check 'subject - (let* ((case-fold-search t) - (subject (message-fetch-field "subject"))) - (or - (and subject - (not (string-match "\\`[ \t]*\\'" subject))) - (ignore - (message - "The subject field is empty or missing. Posting is denied."))))) ;; Check the Newsgroups & Followup-To headers. (message-check 'existing-newsgroups (let* ((case-fold-search t) @@ -2255,7 +2298,8 @@ to find out how to use this." (concat "^" (regexp-quote mail-header-separator) "$")) (while (not (eobp)) (when (not (looking-at "[ \t\n]")) - (setq sum (logxor (ash sum 1) (following-char)))) + (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1) + (following-char)))) (forward-char 1))) sum)) @@ -2441,9 +2485,10 @@ to find out how to use this." (let ((stop-pos (string-match " *at \\| *@ \\| *(\\| *<" from))) (concat (if stop-pos (substring from 0 stop-pos) from) - "'s message of " + "'s message of \"" (if (or (not date) (string= date "")) - "(unknown date)" date))))))) + "(unknown date)" date) + "\"")))))) (defun message-make-distribution () "Make a Distribution header." @@ -2631,7 +2676,7 @@ Headers already prepared in the buffer are not modified." (progn ;; The header was found. We insert a space after the ;; colon, if there is none. - (if (/= (following-char) ? ) (insert " ") (forward-char 1)) + (if (/= (char-after (point)) ? ) (insert " ") (forward-char 1)) ;; Find out whether the header is empty... (looking-at "[ \t]*$"))) ;; So we find out what value we should insert. @@ -2702,7 +2747,9 @@ Headers already prepared in the buffer are not modified." (beginning-of-line) (insert "Original-") (beginning-of-line)) - (insert "Sender: " secure-sender "\n")))))) + (when (or (message-news-p) + (string-match "^[^@]@.+\\..+" secure-sender)) + (insert "Sender: " secure-sender "\n"))))))) (defun message-insert-courtesy-copy () "Insert a courtesy message in mail copies of combined messages." @@ -2737,7 +2784,7 @@ Headers already prepared in the buffer are not modified." (goto-char (point-min)) (while (not (eobp)) (skip-chars-forward "^,\"" (point-max)) - (if (or (= (following-char) ?,) + (if (or (= (char-after (point)) ?,) (eobp)) (when (not quoted) (if (and (> (current-column) 78) @@ -2784,7 +2831,7 @@ Headers already prepared in the buffer are not modified." (search-backward ":" ) (widen) (forward-char 1) - (if (= (following-char) ? ) + (if (= (char-after (point)) ? ) (forward-char 1) (insert " "))) (t @@ -2910,6 +2957,7 @@ Headers already prepared in the buffer are not modified." (message-narrow-to-headers) (run-hooks 'message-header-setup-hook)) (set-buffer-modified-p nil) + (setq buffer-undo-list nil) (run-hooks 'message-setup-hook) (message-position-point) (undo-boundary)) @@ -2922,7 +2970,9 @@ Headers already prepared in the buffer are not modified." (let ((name (make-temp-name (expand-file-name (concat (file-name-as-directory message-autosave-directory) - "msg."))))) + "msg." + (nnheader-replace-chars-in-string + (buffer-name) ?* ?.)))))) (setq buffer-auto-save-file-name (save-excursion (prog1 @@ -3066,10 +3116,10 @@ Headers already prepared in the buffer are not modified." cur))) ;;;###autoload -(defun message-wide-reply (&optional to-address) +(defun message-wide-reply (&optional to-address ignore-reply-to) "Make a \"wide\" reply to the message in the current buffer." (interactive) - (message-reply to-address t)) + (message-reply to-address t ignore-reply-to)) ;;;###autoload (defun message-followup (&optional to-newsgroups) @@ -3217,9 +3267,10 @@ responses here are directed to other newsgroups.")) mail-header-separator "\n" message-cancel-message) (message "Canceling your article...") - (let ((message-syntax-checks 'dont-check-for-anything-just-trust-me)) - (funcall message-send-news-function)) - (message "Canceling your article...done") + (if (let ((message-syntax-checks + 'dont-check-for-anything-just-trust-me)) + (funcall message-send-news-function)) + (message "Canceling your article...done")) (kill-buffer buf))))) ;;;###autoload @@ -3477,7 +3528,7 @@ which specify the range to operate on." (goto-char (min start end)) (while (< (point) end1) (or (looking-at "[_\^@- ]") - (insert (following-char) "\b")) + (insert (char-after (point)) "\b")) (forward-char 1))))) ;;;###autoload @@ -3491,7 +3542,7 @@ which specify the range to operate on." (move-marker end1 (max start end)) (goto-char (min start end)) (while (re-search-forward "\b" end1 t) - (if (eq (following-char) (char-after (- (point) 2))) + (if (eq (char-after (point)) (char-after (- (point) 2))) (delete-char -2)))))) (defalias 'message-exchange-point-and-mark 'exchange-point-and-mark) @@ -3547,14 +3598,15 @@ Do a `tab-to-tab-stop' if not in those headers." (insert string) (if (not comp) (message "No matching groups") - (pop-to-buffer "*Completions*") - (buffer-disable-undo (current-buffer)) - (let ((buffer-read-only nil)) - (erase-buffer) - (let ((standard-output (current-buffer))) - (display-completion-list (sort completions 'string<))) - (goto-char (point-min)) - (pop-to-buffer cur))))))) + (save-selected-window + (pop-to-buffer "*Completions*") + (buffer-disable-undo (current-buffer)) + (let ((buffer-read-only nil)) + (erase-buffer) + (let ((standard-output (current-buffer))) + (display-completion-list (sort completions 'string<))) + (goto-char (point-min)) + (delete-region (point) (progn (forward-line 3) (point)))))))))) ;;; Help stuff.