X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=60e6ed9418fc362e76ec9f5fc18110d2d8720a4e;hb=224da95810808ee8b6512e24d092afeba0ffb54a;hp=650647d0929c4582ac8440ab339733b348aac6d4;hpb=870822142dbdbf720ada0e93c8f0649bbac1bd16;p=elisp%2Fgnus.git- diff --git a/lisp/message.el b/lisp/message.el index 650647d..60e6ed9 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -48,6 +48,14 @@ (require 'mailabbrev)) (require 'mime-edit) +;; Avoid byte-compile warnings. +(eval-when-compile + (require 'mail-parse) + (require 'mm-bodies) + (require 'mm-encode) + (require 'mml) + ) + (defgroup message '((user-mail-address custom-variable) (user-full-name custom-variable)) "Mail and news message composing." @@ -139,6 +147,11 @@ mailbox format." :group 'message-sending :type 'function) +(defcustom message-8bit-encoding-list '(8bit binary) + "*8bit encoding type in Content-Transfer-Encoding field." + :group 'message-sending + :type '(repeat (symbol :tag "Type"))) + (defcustom message-courtesy-message "The following message is a courtesy copy of an article\nthat has been posted to %s as well.\n\n" "*This is inserted at the start of a mailed copy of a posted message. @@ -153,6 +166,11 @@ If this variable is nil, no such courtesy message will be added." :group 'message-interface :type 'regexp) +(defcustom message-bounce-setup-function 'message-bounce-setup-for-mime-edit + "Function to setup a re-sending bounced message." + :group 'message-sending + :type 'function) + ;;;###autoload (defcustom message-from-style 'default "*Specifies how \"From\" headers look. @@ -298,14 +316,15 @@ nil means let mailer mail back a message to report errors." :group 'message-mail :type 'boolean) -(defcustom message-generate-new-buffers t +(defcustom message-generate-new-buffers 'unique "*Non-nil means that a new message buffer will be created whenever `message-setup' is called. If this is a function, call that function with three parameters: The type, the to address and the group name. (Any of these may be nil.) The function should return the new buffer name." :group 'message-buffers :type '(choice (const :tag "off" nil) - (const :tag "on" t) + (const :tag "unique" unique) + (const :tag "unsuniqueent" unsent) (function fun))) (defcustom message-kill-buffer-on-exit nil @@ -385,7 +404,7 @@ The provided functions are: :group 'message-forwarding :type 'boolean) -(defcustom message-ignored-resent-headers "^Return-Receipt" +(defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus" "*All headers that match this regexp will be deleted when resending a message." :group 'message-interface :type 'regexp) @@ -556,6 +575,12 @@ the signature is inserted." :group 'message-various :type 'hook) +(defcustom message-bounce-setup-hook nil + "Normal hook, run each time a a re-sending bounced message is initialized. +The function `message-bounce' runs this hook." + :group 'message-various + :type 'hook) + (defcustom message-mode-hook nil "Hook run in message mode buffers." :group 'message-various @@ -761,12 +786,21 @@ If nil, Message won't auto-save." :group 'message-buffers :type 'directory) +(defcustom message-buffer-naming-style 'unique + "*The way new message buffers are named. +Valid valued are `unique' and `unsent'." + :group 'message-buffers + :type '(choice (const :tag "unique" unique) + (const :tag "unsent" unsent))) + ;;; Internal variables. ;;; Well, not really internal. (defvar message-mode-syntax-table (let ((table (copy-syntax-table text-mode-syntax-table))) (modify-syntax-entry ?% ". " table) + (modify-syntax-entry ?> ". " table) + (modify-syntax-entry ?< ". " table) table) "Syntax table used while in Message mode.") @@ -978,6 +1012,7 @@ The cdr of ech entry is a function for applying the face to a region.") (defvar message-this-is-news nil) (defvar message-this-is-mail nil) (defvar message-draft-article nil) +(defvar message-mime-part nil) ;; Byte-compiler warning (defvar gnus-active-hashtb) @@ -1121,12 +1156,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) ?\") + ((eq (char-after) ?\") (setq quoted (not quoted))) - ((and (= (following-char) ?\() + ((and (eq (char-after) ?\() (not quoted)) (setq paren t)) - ((and (= (following-char) ?\)) + ((and (eq (char-after) ?\)) (not quoted)) (setq paren nil)))) (nreverse elems))))) @@ -1482,8 +1517,7 @@ C-c C-z message-kill-to-signature (kill the text up to the signature). C-c C-r message-caesar-buffer-body (rot13 the message body)." (interactive) (kill-all-local-variables) - (make-local-variable 'message-reply-buffer) - (setq message-reply-buffer nil) + (set (make-local-variable 'message-reply-buffer) nil) (make-local-variable 'message-send-actions) (make-local-variable 'message-exit-actions) (make-local-variable 'message-kill-actions) @@ -1524,10 +1558,8 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (setq message-reply-headers nil) (make-local-variable 'message-user-agent) (make-local-variable 'message-post-method) - (make-local-variable 'message-sent-message-via) - (setq message-sent-message-via nil) - (make-local-variable 'message-checksum) - (setq message-checksum nil) + (set (make-local-variable 'message-sent-message-via) nil) + (set (make-local-variable 'message-checksum) nil) (make-local-variable 'message-parameter-alist) (setq message-parameter-alist (copy-sequence message-startup-parameter-alist)) @@ -1967,6 +1999,11 @@ prefix, and don't delete any headers." (if (listp message-indent-citation-function) message-indent-citation-function (list message-indent-citation-function))))) + (goto-char start) + ;; Quote parts. + (while (re-search-forward "<#/?!*\\(multi\\|part\\)>" end t) + (goto-char (match-beginning 1)) + (insert "!")) (goto-char end) (when (re-search-backward "^-- $" start t) ;; Also peel off any blank lines before the signature. @@ -1990,12 +2027,18 @@ prefix, and don't delete any headers." mail-citation-hook) (run-hooks 'mail-citation-hook) (let ((start (point)) + (end (mark t)) (functions (when message-indent-citation-function (if (listp message-indent-citation-function) message-indent-citation-function (list message-indent-citation-function))))) (goto-char start) + ;; Quote parts. + (while (re-search-forward "<#/?!*\\(multi\\|part\\)>" end t) + (goto-char (match-beginning 1)) + (insert "!")) + (goto-char start) (while functions (funcall (pop functions))) (when message-citation-line-function @@ -2249,11 +2292,56 @@ the user from the mailer." (eval (car actions))))) (pop actions))) +(defsubst message-maybe-split-and-send-mail () + "Split a message if necessary, and send it via mail. +Returns nil if sending succeeded, returns any string if sending failed. +This sub function is for exclusive use of `message-send-mail'." + (let ((mime-edit-split-ignored-field-regexp + mime-edit-split-ignored-field-regexp) + (case-fold-search t) + failure) + (while (string-match "Message-ID" mime-edit-split-ignored-field-regexp) + (setq mime-edit-split-ignored-field-regexp + (concat (substring mime-edit-split-ignored-field-regexp + 0 (match-beginning 0)) + "Hey_MIME-Edit,_there_is_an_inviolable_Message_ID" + "_so_don't_rape_it!" + (substring mime-edit-split-ignored-field-regexp + (match-end 0))))) + (setq failure + (or + (catch 'message-sending-mail-failure + (mime-edit-maybe-split-and-send + (function + (lambda () + (interactive) + (save-restriction + (std11-narrow-to-header mail-header-separator) + (goto-char (point-min)) + (when (re-search-forward "^Message-ID:" nil t) + (delete-region (match-end 0) (std11-field-end)) + (insert " " (message-make-message-id)))) + (condition-case err + (funcall message-send-mail-function) + (error + (throw 'message-sending-mail-failure err)))))) + nil) + (condition-case err + (progn + (funcall message-send-mail-function) + nil) + (error err)))) + (when failure + (if (eq 'error (car failure)) + (cadr failure) + (prin1-to-string failure))))) + (defun message-send-mail (&optional arg) (require 'mail-utils) (let ((tembuf (message-generate-new-buffer-clone-locals " message temp")) (case-fold-search nil) - (news (message-news-p))) + (news (message-news-p)) + failure) (save-restriction (message-narrow-to-headers) ;; Insert some headers. @@ -2262,46 +2350,36 @@ the user from the mailer." (message-generate-headers message-required-mail-headers)) ;; Let the user do all of the above. (run-hooks 'message-header-hook)) - (unwind-protect - (save-excursion - (set-buffer tembuf) - (erase-buffer) - (insert-buffer message-encoding-buffer) - ;; Remove some headers. - (save-restriction - (message-narrow-to-headers) + (if (not (message-check-mail-syntax)) + (progn + (message "") + nil) + (unwind-protect + (save-excursion + (set-buffer tembuf) + (erase-buffer) + (insert-buffer message-encoding-buffer) ;; Remove some headers. - (message-remove-header message-ignored-mail-headers t)) - (goto-char (point-max)) - ;; require one newline at the end. - (or (= (preceding-char) ?\n) - (insert ?\n)) - (when (and news - (or (message-fetch-field "cc") - (message-fetch-field "to"))) - (message-insert-courtesy-copy)) -;; (mime-edit-maybe-split-and-send -;; (function -;; (lambda () -;; (interactive) -;; (funcall message-send-mail-function) -;; ))) - (mime-edit-maybe-split-and-send - (function - (lambda () - (interactive) - (save-restriction - (std11-narrow-to-header mail-header-separator) - (goto-char (point-min)) - (when (re-search-forward "^Message-Id:" nil t) - (delete-region (match-end 0)(std11-field-end)) - (insert (concat " " (message-make-message-id))) - )) - (funcall message-send-mail-function)))) - (funcall message-send-mail-function)) - (kill-buffer tembuf)) - (set-buffer message-edit-buffer) - (push 'mail message-sent-message-via))) + (save-restriction + (message-narrow-to-headers) + ;; Remove some headers. + (message-remove-header message-ignored-mail-headers t)) + (goto-char (point-max)) + ;; require one newline at the end. + (or (= (preceding-char) ?\n) + (insert ?\n)) + (when (and news + (or (message-fetch-field "cc") + (message-fetch-field "to"))) + (message-insert-courtesy-copy)) + (setq failure (message-maybe-split-and-send-mail))) + (kill-buffer tembuf)) + (set-buffer message-edit-buffer) + (if failure + (progn + (message "Couldn't send message via mail: %s" failure) + nil) + (push 'mail message-sent-message-via))))) (defun message-send-mail-with-sendmail () "Send off the prepared buffer with sendmail." @@ -2456,6 +2534,38 @@ to find out how to use this." (error "Sending failed; " result))) (error "Sending failed; no recipients")))) +(defsubst message-maybe-split-and-send-news (method) + "Split a message if necessary, and send it via news. +Returns nil if sending succeeded, returns t if sending failed. +This sub function is for exclusive use of `message-send-news'." + (let ((mime-edit-split-ignored-field-regexp + mime-edit-split-ignored-field-regexp) + (case-fold-search t)) + (while (string-match "Message-ID" mime-edit-split-ignored-field-regexp) + (setq mime-edit-split-ignored-field-regexp + (concat (substring mime-edit-split-ignored-field-regexp + 0 (match-beginning 0)) + "Hey_MIME-Edit,_there_is_an_inviolable_Message_ID" + "_so_don't_rape_it!" + (substring mime-edit-split-ignored-field-regexp + (match-end 0))))) + (or + (catch 'message-sending-news-failure + (mime-edit-maybe-split-and-send + (function + (lambda () + (interactive) + (save-restriction + (std11-narrow-to-header mail-header-separator) + (goto-char (point-min)) + (when (re-search-forward "^Message-ID:" nil t) + (delete-region (match-end 0) (std11-field-end)) + (insert " " (message-make-message-id)))) + (unless (funcall message-send-news-function method) + (throw 'message-sending-news-failure t))))) + nil) + (not (funcall message-send-news-function method))))) + (defun message-send-news (&optional arg) (let ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) (case-fold-search nil) @@ -2492,27 +2602,15 @@ to find out how to use this." ;; require one newline at the end. (or (= (preceding-char) ?\n) (insert ?\n)) - (mime-edit-maybe-split-and-send - (function - (lambda () - (interactive) - (save-restriction - (std11-narrow-to-header mail-header-separator) - (goto-char (point-min)) - (when (re-search-forward "^Message-Id:" nil t) - (delete-region (match-end 0)(std11-field-end)) - (insert (concat " " (message-make-message-id))) - )) - (funcall message-send-news-function method) - ))) - (setq result (funcall message-send-news-function method))) + (setq result (message-maybe-split-and-send-news method))) (kill-buffer tembuf)) (set-buffer message-edit-buffer) (if result - (push 'news message-sent-message-via) - (message "Couldn't send message via news: %s" - (nnheader-get-report (car method))) - nil)))) + (progn + (message "Couldn't send message via news: %s" + (nnheader-get-report (car method))) + nil) + (push 'news message-sent-message-via))))) ;; 1997-09-29 by MORIOKA Tomohiko (defun message-send-news-with-gnus (method) @@ -2776,6 +2874,9 @@ to find out how to use this." (y-or-n-p "The article contains control characters. Really post? ") t)) + ;; Check 8bit characters. + (message-check '8bit + (message-check-8bit)) ;; Check excessive size. (message-check 'size (if (> (buffer-size) 60000) @@ -2803,6 +2904,54 @@ to find out how to use this." (1- (count-lines (point) (point-max))))) t))))) +(defun message-check-mail-syntax () + "Check the syntax of the message." + (save-excursion + (save-restriction + (widen) + (and + ;; We narrow to the headers and check them first. + (save-excursion + (save-restriction + (message-narrow-to-headers) + (message-check-mail-header-syntax))) + ;; Check the body. + (save-excursion + (set-buffer message-edit-buffer) + (message-check-mail-body-syntax)))))) + +(defun message-check-mail-header-syntax () + t) + +(defun message-check-mail-body-syntax () + (and + ;; Check 8bit characters. + (message-check '8bit + (message-check-8bit) + ))) + +(defun message-check-8bit () + "Check the article contains 8bit characters." + (save-excursion + (set-buffer message-encoding-buffer) + (message-narrow-to-headers) + (let* ((case-fold-search t) + (field-value (message-fetch-field "content-transfer-encoding"))) + (if (and field-value + (member (downcase field-value) message-8bit-encoding-list)) + t + (widen) + (set-buffer (get-buffer-create " message syntax")) + (erase-buffer) + (goto-char (point-min)) + (set-buffer-multibyte nil) + (insert-buffer message-encoding-buffer) + (goto-char (point-min)) + (if (re-search-forward "[^\x00-\x7f]" nil t) + (y-or-n-p + "The article contains 8bit characters. Really post? ") + t))))) + (defun message-checksum () "Return a \"checksum\" for the current buffer." (let ((sum 0)) @@ -2813,7 +2962,7 @@ to find out how to use this." (while (not (eobp)) (when (not (looking-at "[ \t\n]")) (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1) - (following-char)))) + (char-after)))) (forward-char 1))) sum)) @@ -2831,7 +2980,6 @@ to find out how to use this." (while (setq file (message-fetch-field "fcc")) (push file list) (message-remove-header "fcc" nil t))) - (run-hooks 'message-header-hook 'message-before-do-fcc-hook) (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) (replace-match "" t t) @@ -2854,7 +3002,6 @@ to find out how to use this." (rmail-output file 1 nil t) (let ((mail-use-rfc822 t)) (rmail-output file 1 t t)))))) - (kill-buffer (current-buffer))))) (defun message-output (filename) @@ -2903,7 +3050,8 @@ If NOW, use that time instead." (zone (nth 8 (decode-time now))) (sign "+")) (when (< zone 0) - (setq sign "")) + (setq sign "-") + (setq zone (- zone))) (concat (format-time-string "%d" now) ;; The month name of the %b spec is locale-specific. Pfff. @@ -3029,10 +3177,10 @@ If NOW, use that time instead." (let ((pair (std11-extract-address-components from))) (concat "\n (" (or (car pair) (cadr pair)) - "'s message of " + "'s message of \"" (if (or (not date) (string= date "")) "(unknown date)" date) - ")")))))))) + "\")")))))))) (defun message-make-distribution () "Make a Distribution header." @@ -3250,7 +3398,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) ? ) (insert " ") (forward-char 1)) ;; Find out whether the header is empty... (looking-at "[ \t]*$"))) ;; So we find out what value we should insert. @@ -3359,7 +3507,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 (eq (char-after) ?,) (eobp)) (when (not quoted) (if (and (> (current-column) 78) @@ -3430,7 +3578,7 @@ Headers already prepared in the buffer are not modified." (search-backward ":" ) (widen) (forward-char 1) - (if (= (following-char) ? ) + (if (eq (char-after) ? ) (forward-char 1) (insert " "))) (t @@ -3449,7 +3597,7 @@ Headers already prepared in the buffer are not modified." ((message-functionp message-generate-new-buffers) (funcall message-generate-new-buffers type to group)) ;; Generate a new buffer name The Message Way. - (message-generate-new-buffers + ((eq message-generate-new-buffers 'unique) (generate-new-buffer-name (concat "*" type (if to @@ -3459,6 +3607,16 @@ Headers already prepared in the buffer are not modified." "") (if (and group (not (string= group ""))) (concat " on " group) "") "*"))) + ((eq message-generate-new-buffers 'unsent) + (generate-new-buffer-name + (concat "*unsent " type + (if to + (concat " to " + (or (car (mail-extract-address-components to)) + to) "") + "") + (if (and group (not (string= group ""))) (concat " on " group) "") + "*"))) ;; Use standard name. (t (format "*%s message*" type)))) @@ -3514,7 +3672,7 @@ Headers already prepared in the buffer are not modified." ;; Rename the buffer. (if message-send-rename-function (funcall message-send-rename-function) - (when (string-match "\\`\\*" (buffer-name)) + (when (string-match "\\`\\*\\(unsent \\)?" (buffer-name)) (rename-buffer (concat "*sent " (substring (buffer-name) (match-end 0))) t))) ;; Push the current buffer onto the list. @@ -4118,10 +4276,12 @@ the message." (let ((funcs message-make-forward-subject-function) (subject (if message-wash-forwarded-subjects (message-wash-subject - (or (eword-decode-unstructured-field-body - (message-fetch-field "Subject")) "")) - (or (eword-decode-unstructured-field-body - (message-fetch-field "Subject")) "")))) + (or (nnheader-decode-subject + (message-fetch-field "Subject")) + "")) + (or (nnheader-decode-subject + (message-fetch-field "Subject")) + "")))) ;; Make sure funcs is a list. (and funcs (not (listp funcs)) @@ -4217,10 +4377,18 @@ Optional NEWS will use news to forward instead of mail." ;; Send it. (let ((message-encoding-buffer (current-buffer)) (message-edit-buffer (current-buffer))) - (message-send-mail)) + (let (message-required-mail-headers) + (message-send-mail))) (kill-buffer (current-buffer))) (message "Resending message to %s...done" address))) +(defun message-bounce-setup-for-mime-edit () + (goto-char (point-min)) + (when (search-forward (concat "\n" mail-header-separator "\n") nil t) + (replace-match "\n\n")) + (set (make-local-variable 'message-setup-hook) nil) + (mime-edit-again)) + ;;;###autoload (defun message-bounce () "Re-mail the current message. @@ -4260,6 +4428,9 @@ you." (message-remove-header message-ignored-bounced-headers t) (goto-char (point-max)) (insert mail-header-separator)) + (when message-bounce-setup-function + (funcall message-bounce-setup-function)) + (run-hooks 'message-bounce-setup-hook) (message-position-point))) ;;; @@ -4337,7 +4508,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) "\b")) (forward-char 1))))) ;;;###autoload @@ -4351,7 +4522,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) (char-after (- (point) 2))) (delete-char -2)))))) (defalias 'message-exchange-point-and-mark 'exchange-point-and-mark) @@ -4528,34 +4699,39 @@ regexp varstr." ;;; MIME functions ;;; +(defun message-insert-mime-part (file type) + "Insert a multipart/alternative part into the buffer." + (interactive + (let* ((file (read-file-name "Insert file: " nil nil t)) + (type (mm-default-file-encoding file))) + (list file + (completing-read + (format "MIME type for %s: " file) + (mapcar (lambda (m) (list (cdr m))) mailcap-mime-extensions) + nil nil type)))) + (insert (format "<#part type=%s filename=\"%s\"><#/part>\n" + type file))) + (defun message-encode-message-body () - "Examine the message body, encode it, and add the requisite headers." - (when (featurep 'mule) - (let (old-headers) - (save-excursion - (save-restriction - (message-narrow-to-headers-or-head) - (unless (setq old-headers (message-fetch-field "mime-version")) - (message-remove-header - "^Content-Transfer-Encoding:\\|^Content-Type:\\|^Mime-Version:" t)) - (goto-char (point-max)) - (widen) - (narrow-to-region (point) (point-max)) - (let* ((charset (mm-encode-body)) - (encoding (mm-body-encoding))) - (when (consp charset) - (error "Can't encode messages with multiple charsets (yet)")) - (widen) - (message-narrow-to-headers-or-head) - (goto-char (point-max)) - (setq charset (or charset - (mm-mule-charset-to-mime-charset 'ascii))) - ;; We don't insert MIME headers if they only say the default. - (when (and (not old-headers) - (not (and (eq charset 'us-ascii) - (eq encoding '7bit)))) - (mm-insert-rfc822-headers charset encoding)) - (mm-encode-body))))))) + (message-goto-body) + (save-restriction + (narrow-to-region (point) (point-max)) + (let ((new (mml-generate-mime))) + (delete-region (point-min) (point-max)) + (insert new) + (goto-char (point-min)) + (widen) + (forward-line -1) + (let ((beg (point)) + (line (buffer-substring (point) (progn (forward-line 1) (point))))) + (delete-region beg (point)) + (insert "Mime-Version: 1.0\n") + (search-forward "\n\n") + (insert line) + (when (save-excursion + (re-search-backward "^Content-Type: multipart/" nil t)) + (insert "This is a MIME multipart message. If you are reading\n") + (insert "this, you shouldn't.\n\n")))))) (defvar message-save-buffer " *encoding") (defun message-save-drafts ()