X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=4aa804be05932058eba276fd5e1c34e7a4e1669c;hb=6fa1e3e40590041d48b15003cb65eae118b28df1;hp=e549b516056196ffa2f262a32311289d62a58847;hpb=d66179690a51e7a26ded8ec7459b414ee39978e7;p=elisp%2Fgnus.git- diff --git a/lisp/message.el b/lisp/message.el index e549b51..4aa804b 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -1,8 +1,9 @@ ;;; message.el --- composing mail and news messages -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen -;; Keywords: mail, news +;; MORIOKA Tomohiko +;; Keywords: mail, news, MIME ;; This file is part of GNU Emacs. @@ -29,10 +30,12 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile + (require 'cl) + (require 'smtp) + ) (require 'mailheader) -(require 'rmail) (require 'nnheader) (require 'timezone) (require 'easymenu) @@ -40,6 +43,7 @@ (if (string-match "XEmacs\\|Lucid" emacs-version) (require 'mail-abbrevs) (require 'mailabbrev)) +(require 'mime-edit) (defgroup message '((user-mail-address custom-variable) (user-full-name custom-variable)) @@ -123,6 +127,11 @@ mailbox format." (function :tag "Other")) :group 'message-sending) +(defcustom message-encode-function 'message-maybe-encode + "*A function called to encode messages." + :group 'message-sending + :type 'function) + (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. @@ -157,8 +166,8 @@ Otherwise, most addresses look like `angles', but they look like :group 'message-headers) (defcustom message-syntax-checks nil - ;; Guess this one shouldn't be easy to customize... - "Controls what syntax checks should not be performed on outgoing posts. + ; Guess this one shouldn't be easy to customize... + "*Controls what syntax checks should not be performed on outgoing posts. To disable checking of long signatures, for instance, add `(signature . disabled)' to this list. @@ -174,7 +183,7 @@ shorten-followup-to existing-newsgroups buffer-file-name unchanged." '(From Newsgroups Subject Date Message-ID (optional . Organization) Lines (optional . X-Newsreader)) - "Headers to be generated or prompted for when posting an article. + "*Headers to be generated or prompted for when posting an article. RFC977 and RFC1036 require From, Date, Newsgroups, Subject, Message-ID. Organization, Lines, In-Reply-To, Expires, and X-Newsreader are optional. If don't you want message to insert some @@ -186,7 +195,7 @@ header, remove it from this list." (defcustom message-required-mail-headers '(From Subject Date (optional . In-Reply-To) Message-ID Lines (optional . X-Mailer)) - "Headers to be generated or prompted for when mailing a message. + "*Headers to be generated or prompted for when mailing a message. RFC822 required that From, Date, To, Subject and Message-ID be included. Organization, Lines and X-Mailer are optional." :group 'message-mail @@ -205,13 +214,13 @@ included. Organization, Lines and X-Mailer are optional." :group 'message-headers :type 'regexp) -(defcustom message-ignored-mail-headers "^[GF]cc:\\|^Resent-Fcc:" +(defcustom message-ignored-mail-headers "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:" "*Regexp of headers to be removed unconditionally before mailing." :group 'message-mail :group 'message-headers :type 'regexp) -(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\||X-Trace:\\|X-Complaints-To:\\|Return-Path:\\|^Supersedes:" +(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:" "*Header lines matching this regexp will be deleted before posting. It's best to delete old Path and Date headers before posting to avoid any confusion." @@ -225,7 +234,9 @@ any confusion." :group 'message-various) (defcustom message-elide-elipsis "\n[...]\n\n" - "*The string which is inserted for elided text.") + "*The string which is inserted for elided text." + :type 'string + :group 'message-various) (defcustom message-interactive nil "Non-nil means when sending a message wait for and display errors. @@ -268,21 +279,14 @@ If t, use `message-user-organization-file'." :type 'file :group 'message-headers) -(defcustom message-autosave-directory - (nnheader-concat message-directory "drafts/") - "*Directory where Message autosaves buffers. -If nil, Message won't autosave." - :group 'message-buffers - :type 'directory) - (defcustom message-forward-start-separator - "------- Start of forwarded message -------\n" + (concat (mime-make-tag "message" "rfc822") "\n") "*Delimiter inserted before forwarded messages." :group 'message-forwarding :type 'string) (defcustom message-forward-end-separator - "------- End of forwarded message -------\n" + "" "*Delimiter inserted after forwarded messages." :group 'message-forwarding :type 'string) @@ -321,10 +325,12 @@ The headers should be delimited by a line whose contents match the variable `mail-header-separator'. Legal values include `message-send-mail-with-sendmail' (the default), -`message-send-mail-with-mh' and `message-send-mail-with-qmail'." +`message-send-mail-with-mh', `message-send-mail-with-qmail' and +`message-send-mail-with-smtp'." :type '(radio (function-item message-send-mail-with-sendmail) (function-item message-send-mail-with-mh) (function-item message-send-mail-with-qmail) + (function-item message-send-mail-with-smtp) (function :tag "Other")) :group 'message-sending :group 'message-mail) @@ -402,7 +408,9 @@ might set this variable to '(\"-f\" \"you@some.where\")." ((boundp 'gnus-select-method) gnus-select-method) (t '(nnspool ""))) - "Method used to post news." + "*Method used to post news. +Note that when posting from inside Gnus, for instance, this +variable isn't used." :group 'message-news :group 'message-sending ;; This should be the `gnus-select-method' widget, but that might @@ -414,7 +422,8 @@ might set this variable to '(\"-f\" \"you@some.where\")." :group 'message-headers :type 'boolean) -(defcustom message-setup-hook nil +(defcustom message-setup-hook + '(message-maybe-setup-default-charset turn-on-mime-edit) "Normal hook, run each time a new outgoing message is initialized. The function `message-setup' runs this hook." :group 'message-various @@ -432,14 +441,13 @@ the signature is inserted." :group 'message-various :type 'hook) -(defcustom message-header-hook nil +(defcustom message-header-hook '(eword-encode-header) "Hook run in a message mode buffer narrowed to the headers." :group 'message-various :type 'hook) (defcustom message-header-setup-hook nil - "Hook called narrowed to the headers when setting up a message -buffer." + "Hook called narrowed to the headers when setting up a message buffer." :group 'message-various :type 'hook) @@ -468,8 +476,11 @@ Used by `message-yank-original' via `message-yank-cite'." mail-citation-hook) mail-citation-hook 'message-cite-original) - "*Function for citing an original message." + "*Function for citing an original message. +Pre-defined functions include `message-cite-original' and +`message-cite-original-without-signature'." :type '(radio (function-item message-cite-original) + (function-item message-cite-original-without-signature) (function-item sc-cite-original) (function :tag "Other")) :group 'message-insertion) @@ -540,6 +551,7 @@ If stringp, use this; if non-nil, use no host name (user name only)." (define-widget 'message-header-lines 'text "All header lines must be LFD terminated." + :format "%t:%n%v" :valid-regexp "^\\'" :error "All header lines must be newline terminated") @@ -583,7 +595,7 @@ articles." ;; 33 and 126, except colon)", i. e., any chars except ctl chars, ;; space, or colon. '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:")) - "Set this non-nil if the system's mailer runs the header and body together. + "*Set this non-nil if the system's mailer runs the header and body together. \(This problem exists on Sunos 4 when sendmail is run in remote mode.) The value should be an expression to test whether the problem will actually occur." @@ -621,6 +633,13 @@ the prefix.") The default is `abbrev', which uses mailabbrev. nil switches mail aliases off.") +(defcustom message-autosave-directory + (nnheader-concat message-directory "drafts/") + "*Directory where Message autosaves buffers if Gnus isn't running. +If nil, Message won't autosave." + :group 'message-buffers + :type 'directory) + ;;; Internal variables. ;;; Well, not really internal. @@ -768,14 +787,21 @@ Defaults to `text-mode-abbrev-table'.") (,(concat "^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):" content) (1 'message-header-name-face) (2 'message-header-name-face)) - (,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$") - 1 'message-separator-face) + ,@(if (and mail-header-separator + (not (equal mail-header-separator ""))) + `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$") + 1 'message-separator-face)) + nil) (,(concat "^[ \t]*" "\\([" cite-prefix "]+[" cite-suffix "]*\\)?" - "[>|}].*") + "[:>|}].*") (0 'message-cited-text-face)))) "Additional expressions to highlight in Message mode.") +;; XEmacs does it like this. For Emacs, we have to set the +;; `font-lock-defaults' buffer-local variable. +(put 'message-mode 'font-lock-defaults '(message-font-lock-keywords t)) + (defvar message-face-alist '((bold . bold-region) (underline . underline-region) @@ -896,7 +922,7 @@ The cdr of ech entry is a function for applying the face to a region.") (Lines) (Expires) (Message-ID) - (References) + (References . message-fill-references) (X-Mailer) (X-Newsreader)) "Alist used for formatting headers.") @@ -911,7 +937,11 @@ The cdr of ech entry is a function for applying the face to a region.") (autoload 'gnus-output-to-rmail "gnus-util") (autoload 'mail-abbrev-in-expansion-header-p "mailabbrev") (autoload 'nndraft-request-associate-buffer "nndraft") - (autoload 'nndraft-request-expire-articles "nndraft")) + (autoload 'nndraft-request-expire-articles "nndraft") + (autoload 'gnus-open-server "gnus-int") + (autoload 'gnus-request-post "gnus-int") + (autoload 'gnus-alive-p "gnus-util") + (autoload 'rmail-output "rmail")) @@ -974,7 +1004,8 @@ The cdr of ech entry is a function for applying the face to a region.") (defun message-fetch-field (header &optional not-all) "The same as `mail-fetch-field', only remove all newlines." - (let ((value (mail-fetch-field header nil (not not-all)))) + (let* ((inhibit-point-motion-hooks t) + (value (mail-fetch-field header nil (not not-all)))) (when value (nnheader-replace-chars-in-string value ?\n ? )))) @@ -1077,22 +1108,24 @@ Return the number of headers removed." (defun message-news-p () "Say whether the current buffer contains a news message." - (or message-this-is-news - (save-excursion - (save-restriction - (message-narrow-to-headers) - (and (message-fetch-field "newsgroups") - (not (message-fetch-field "posted-to"))))))) + (and (not message-this-is-mail) + (or message-this-is-news + (save-excursion + (save-restriction + (message-narrow-to-headers) + (and (message-fetch-field "newsgroups") + (not (message-fetch-field "posted-to")))))))) (defun message-mail-p () "Say whether the current buffer contains a mail message." - (or message-this-is-mail - (save-excursion - (save-restriction - (message-narrow-to-headers) - (or (message-fetch-field "to") - (message-fetch-field "cc") - (message-fetch-field "bcc")))))) + (and (not message-this-is-news) + (or message-this-is-mail + (save-excursion + (save-restriction + (message-narrow-to-headers) + (or (message-fetch-field "to") + (message-fetch-field "cc") + (message-fetch-field "bcc"))))))) (defun message-next-header () "Go to the beginning of the next header." @@ -1181,6 +1214,7 @@ Return the number of headers removed." (define-key message-mode-map "\C-c\C-e" 'message-elide-region) (define-key message-mode-map "\C-c\C-v" 'message-delete-not-region) + (define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature) (define-key message-mode-map "\M-\r" 'message-newline-and-reformat) (define-key message-mode-map "\t" 'message-tab)) @@ -1196,6 +1230,7 @@ Return the number of headers removed." ["Caesar (rot13) Region" message-caesar-region (mark t)] ["Elide Region" message-elide-region (mark t)] ["Delete Outside Region" message-delete-not-region (mark t)] + ["Kill To Signature" message-kill-to-signature t] ["Newline and Reformat" message-newline-and-reformat t] ["Rename buffer" message-rename-buffer t] ["Spellcheck" ispell-message t] @@ -1244,6 +1279,7 @@ C-c C-w message-insert-signature (insert `message-signature-file' file). C-c C-y message-yank-original (insert current message, if any). C-c C-q message-fill-yanked-message (fill what was yanked). C-c C-e message-elide-region (elide the text between point and mark). +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) @@ -1261,8 +1297,6 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (setq major-mode 'message-mode) (setq mode-name "Message") (setq buffer-offer-save t) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(message-font-lock-keywords t)) (make-local-variable 'facemenu-add-face-function) (make-local-variable 'facemenu-remove-face-function) (setq facemenu-add-face-function @@ -1279,7 +1313,7 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (concat (regexp-quote mail-header-separator) "$\\|[ \t]*[-_][-_][-_]+$\\|" "-- $\\|" - ;;!!! Uhm... shurely this can't be right. + ;;!!! Uhm... shurely this can't be right? "[> " (regexp-quote message-yank-prefix) "]+$\\|" paragraph-start)) (setq paragraph-separate @@ -1309,6 +1343,18 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (mail-abbrevs-setup) (funcall (intern "mail-aliases-setup")))) (message-set-auto-save-file-name) + (unless (string-match "XEmacs" emacs-version) + (set (make-local-variable 'font-lock-defaults) + '(message-font-lock-keywords t))) + (make-local-variable 'adaptive-fill-regexp) + (setq adaptive-fill-regexp + (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|" adaptive-fill-regexp)) + (unless (boundp 'adaptive-fill-first-line-regexp) + (setq adaptive-fill-first-line-regexp nil)) + (make-local-variable 'adaptive-fill-first-line-regexp) + (setq adaptive-fill-first-line-regexp + (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|" + adaptive-fill-first-line-regexp)) (run-hooks 'text-mode-hook 'message-mode-hook)) @@ -1438,6 +1484,17 @@ With the prefix argument FORCE, insert the header anyway." (message-goto-signature) (forward-line -2)) +(defun message-kill-to-signature () + "Deletes all text up to the signature." + (interactive) + (let ((point (point))) + (message-goto-signature) + (unless (eobp) + (forward-line -2)) + (kill-region point (point)) + (unless (bolp) + (insert "\n")))) + (defun message-newline-and-reformat () "Insert four newlines, and then reformat if inside quoted text." (interactive) @@ -1492,8 +1549,9 @@ With the prefix argument FORCE, insert the header anyway." (or (bolp) (insert "\n"))))) (defun message-elide-region (b e) - "Elide the text between point and mark. An ellipsis (from -message-elide-elipsis) will be inserted where the text was killed." + "Elide the text between point and mark. +An ellipsis (from `message-elide-elipsis') will be inserted where the +text was killed." (interactive "r") (kill-region b e) (unless (bolp) @@ -1589,9 +1647,7 @@ name, rather than giving an automatic name." (name-default (concat "*message* " mail-trimmed-to)) (name (if enter-string (read-string "New buffer name: " name-default) - name-default)) - (default-directory - (file-name-as-directory message-autosave-directory))) + name-default))) (rename-buffer name t))))) (defun message-fill-yanked-message (&optional justifyp) @@ -1673,6 +1729,26 @@ prefix, and don't delete any headers." (unless modified (setq message-checksum (cons (message-checksum) (buffer-size))))))) +(defun message-cite-original-without-signature () + "Cite function in the standard Message manner." + (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 end) + (when (re-search-backward "^-- $" start t) + (delete-region (point) end)) + (goto-char start) + (while functions + (funcall (pop functions))) + (when message-citation-line-function + (unless (bolp) + (insert "\n")) + (funcall message-citation-line-function)))) + (defun message-cite-original () "Cite function in the standard Message manner." (let ((start (point)) @@ -1767,6 +1843,8 @@ The text will also be indented the normal way." (defun message-dont-send () "Don't send the message you have been editing." (interactive) + (set-buffer-modified-p t) + (save-buffer) (let ((actions message-postpone-actions)) (message-bury (current-buffer)) (message-do-actions actions))) @@ -1799,15 +1877,9 @@ Otherwise any failure is reported in a message back to the user from the mailer." (interactive "P") ;; Disabled test. - (when (if (and buffer-file-name - nil) - (y-or-n-p (format "Send buffer contents as %s message? " - (if (message-mail-p) - (if (message-news-p) "mail and news" "mail") - "news"))) - (or (buffer-modified-p) - (message-check-element 'unchanged) - (y-or-n-p "No changes in the buffer; really send? "))) + (when (or (buffer-modified-p) + (message-check-element 'unchanged) + (y-or-n-p "No changes in the buffer; really send? ")) ;; Make it possible to undo the coming changes. (undo-boundary) (let ((inhibit-read-only t)) @@ -1815,20 +1887,29 @@ the user from the mailer." (message-fix-before-sending) (run-hooks 'message-send-hook) (message "Sending...") - (let ((alist message-send-method-alist) + (let ((message-encoding-buffer + (message-generate-new-buffer-clone-locals " message encoding")) + (message-edit-buffer (current-buffer)) + (message-mime-mode mime-edit-mode-flag) + (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))) + (save-excursion + (set-buffer message-encoding-buffer) + (erase-buffer) + (insert-buffer message-edit-buffer) + (funcall message-encode-function) + (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) @@ -1885,8 +1966,7 @@ the user from the mailer." (require 'mail-utils) (let ((tembuf (message-generate-new-buffer-clone-locals " message temp")) (case-fold-search nil) - (news (message-news-p)) - (message-buffer (current-buffer))) + (news (message-news-p))) (save-restriction (message-narrow-to-headers) ;; Insert some headers. @@ -1899,14 +1979,7 @@ the user from the mailer." (save-excursion (set-buffer tembuf) (erase-buffer) - ;; Avoid copying text props. - ;; (insert (format - ;; "%s" (save-excursion - ;; (set-buffer message-buffer) - ;; (buffer-string)))) - ;; 1997-09-29 by MORIOKA Tomohiko - ;; Don't avoid text properties. - (insert-buffer message-buffer) + (insert-buffer message-encoding-buffer) ;; Remove some headers. (save-restriction (message-narrow-to-headers) @@ -1920,11 +1993,15 @@ the user from the mailer." (or (message-fetch-field "cc") (message-fetch-field "to"))) (message-insert-courtesy-copy)) - ;; 1997-09-29 by MORIOKA Tomohiko - (run-hooks 'message-encode-mail-hook) + (mime-edit-maybe-split-and-send + (function + (lambda () + (interactive) + (funcall message-send-mail-function) + ))) (funcall message-send-mail-function)) (kill-buffer tembuf)) - (set-buffer message-buffer) + (set-buffer message-edit-buffer) (push 'mail message-sent-message-via))) (defun message-send-mail-with-sendmail () @@ -1954,7 +2031,8 @@ the user from the mailer." (save-excursion (set-buffer errbuf) (erase-buffer)))) - (let ((default-directory "/")) + (let ((default-directory "/") + (coding-system-for-write 'binary)) (apply 'call-process-region (append (list (point-min) (point-max) (if (boundp 'sendmail-program) @@ -2002,27 +2080,28 @@ to find out how to use this." (run-hooks 'message-send-mail-hook) ;; send the message (case - (apply - 'call-process-region 1 (point-max) message-qmail-inject-program - nil nil nil - ;; qmail-inject's default behaviour is to look for addresses on the - ;; command line; if there're none, it scans the headers. - ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin. - ;; - ;; in general, ALL of qmail-inject's defaults are perfect for simply - ;; reading a formatted (i. e., at least a To: or Resent-To header) - ;; message from stdin. - ;; - ;; qmail also has the advantage of not having been raped by - ;; various vendors, so we don't have to allow for that, either -- - ;; compare this with message-send-mail-with-sendmail and weep - ;; for sendmail's lost innocence. - ;; - ;; all this is way cool coz it lets us keep the arguments entirely - ;; free for -inject-arguments -- a big win for the user and for us - ;; since we don't have to play that double-guessing game and the user - ;; gets full control (no gestapo'ish -f's, for instance). --sj - message-qmail-inject-args) + (let ((coding-system-for-write 'binary)) + (apply + 'call-process-region 1 (point-max) message-qmail-inject-program + nil nil nil + ;; qmail-inject's default behaviour is to look for addresses on the + ;; command line; if there're none, it scans the headers. + ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin. + ;; + ;; in general, ALL of qmail-inject's defaults are perfect for simply + ;; reading a formatted (i. e., at least a To: or Resent-To header) + ;; message from stdin. + ;; + ;; qmail also has the advantage of not having been raped by + ;; various vendors, so we don't have to allow for that, either -- + ;; compare this with message-send-mail-with-sendmail and weep + ;; for sendmail's lost innocence. + ;; + ;; all this is way cool coz it lets us keep the arguments entirely + ;; free for -inject-arguments -- a big win for the user and for us + ;; since we don't have to play that double-guessing game and the user + ;; gets full control (no gestapo'ish -f's, for instance). --sj + message-qmail-inject-args)) ;; qmail-inject doesn't say anything on it's stdout/stderr, ;; we have to look at the retval instead (0 nil) @@ -2049,13 +2128,151 @@ to find out how to use this." ;; Pass it on to mh. (mh-send-letter))) +(defun message-send-mail-with-smtp () + "Send the prepared message buffer with SMTP." + (require 'smtp) + (let ((errbuf (if mail-interactive + (generate-new-buffer " smtp errors") + 0)) + (case-fold-search nil) + resend-to-addresses + delimline) + (unwind-protect + (save-excursion + (goto-char (point-max)) + ;; require one newline at the end. + (or (= (preceding-char) ?\n) + (insert ?\n)) + ;; 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) + ;; (sendmail-synch-aliases) + ;; (if mail-aliases + ;; (expand-mail-aliases (point-min) delimline)) + (goto-char (point-min)) + ;; ignore any blank lines in the header + (while (and (re-search-forward "\n\n\n*" delimline t) + (< (point) delimline)) + (replace-match "\n")) + (let ((case-fold-search t)) + (goto-char (point-min)) + (goto-char (point-min)) + (while (re-search-forward "^Resent-to:" delimline t) + (setq resend-to-addresses + (save-restriction + (narrow-to-region (point) + (save-excursion + (end-of-line) + (point))) + (append (mail-parse-comma-list) + resend-to-addresses)))) +;;; Apparently this causes a duplicate Sender. +;;; ;; If the From is different than current user, insert Sender. +;;; (goto-char (point-min)) +;;; (and (re-search-forward "^From:" delimline t) +;;; (progn +;;; (require 'mail-utils) +;;; (not (string-equal +;;; (mail-strip-quoted-names +;;; (save-restriction +;;; (narrow-to-region (point-min) delimline) +;;; (mail-fetch-field "From"))) +;;; (user-login-name)))) +;;; (progn +;;; (forward-line 1) +;;; (insert "Sender: " (user-login-name) "\n"))) + ;; Don't send out a blank subject line + (goto-char (point-min)) + (if (re-search-forward "^Subject:[ \t]*\n" delimline t) + (replace-match "")) + ;; Put the "From:" field in unless for some odd reason + ;; they put one in themselves. + (goto-char (point-min)) + (if (not (re-search-forward "^From:" delimline t)) + (let* ((login user-mail-address) + (fullname (user-full-name))) + (cond ((eq mail-from-style 'angles) + (insert "From: " fullname) + (let ((fullname-start (+ (point-min) 6)) + (fullname-end (point-marker))) + (goto-char fullname-start) + ;; Look for a character that cannot appear unquoted + ;; according to RFC 822. + (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" + fullname-end 1) + (progn + ;; Quote fullname, escaping specials. + (goto-char fullname-start) + (insert "\"") + (while (re-search-forward "[\"\\]" + fullname-end 1) + (replace-match "\\\\\\&" t)) + (insert "\"")))) + (insert " <" login ">\n")) + ((eq mail-from-style 'parens) + (insert "From: " login " (") + (let ((fullname-start (point))) + (insert fullname) + (let ((fullname-end (point-marker))) + (goto-char fullname-start) + ;; RFC 822 says \ and nonmatching parentheses + ;; must be escaped in comments. + ;; Escape every instance of ()\ ... + (while (re-search-forward "[()\\]" fullname-end 1) + (replace-match "\\\\\\&" t)) + ;; ... then undo escaping of matching parentheses, + ;; including matching nested parentheses. + (goto-char fullname-start) + (while (re-search-forward + "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)" + fullname-end 1) + (replace-match "\\1(\\3)" t) + (goto-char fullname-start)))) + (insert ")\n")) + ((null mail-from-style) + (insert "From: " login "\n"))))) + ;; Insert an extra newline if we need it to work around + ;; Sun's bug that swallows newlines. + (goto-char (1+ delimline)) + (if (eval mail-mailer-swallows-blank-line) + (newline)) + ;; Find and handle any FCC fields. + (goto-char (point-min)) + (if (re-search-forward "^FCC:" delimline t) + (mail-do-fcc delimline)) + (if mail-interactive + (save-excursion + (set-buffer errbuf) + (erase-buffer)))) + ;; + ;; + ;; + (let ((recipient-address-list + (or resend-to-addresses + (smtp-deduce-address-list (current-buffer) + (point-min) delimline)))) + (smtp-do-bcc delimline) + + (if recipient-address-list + (if (not (smtp-via-smtp recipient-address-list + (current-buffer))) + (error "Sending failed; SMTP protocol error")) + (error "Sending failed; no recipients")) + )) + (if (bufferp errbuf) + (kill-buffer errbuf))))) + (defun message-send-news (&optional arg) (let ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) (case-fold-search nil) (method (if (message-functionp message-post-method) (funcall message-post-method arg) message-post-method)) - (message-buffer (current-buffer)) (message-syntax-checks (if arg (cons '(existing-newsgroups . disabled) @@ -2078,14 +2295,7 @@ to find out how to use this." (set-buffer tembuf) (buffer-disable-undo (current-buffer)) (erase-buffer) - ;; Avoid copying text props. - ;; (insert (format - ;; "%s" (save-excursion - ;; (set-buffer message-buffer) - ;; (buffer-string)))) - ;; 1997-09-29 by MORIOKA Tomohiko - ;; Don't avoid text properties. - (insert-buffer message-buffer) + (insert-buffer message-encoding-buffer) ;; Remove some headers. (save-restriction (message-narrow-to-headers) @@ -2095,11 +2305,22 @@ to find out how to use this." ;; require one newline at the end. (or (= (preceding-char) ?\n) (insert ?\n)) - ;; 1997-09-29 by MORIOKA Tomohiko - (run-hooks 'message-encode-news-hook) + (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))) (kill-buffer tembuf)) - (set-buffer message-buffer) + (set-buffer message-edit-buffer) (if result (push 'news message-sent-message-via) (message "Couldn't send message via news: %s" @@ -2159,7 +2380,9 @@ to find out how to use this." (message-narrow-to-headers) (message-check-news-header-syntax))) ;; Check the body. - (message-check-news-body-syntax))))) + (save-excursion + (set-buffer message-edit-buffer) + (message-check-news-body-syntax)))))) (defun message-check-news-header-syntax () (and @@ -2241,8 +2464,12 @@ to find out how to use this." (let* ((case-fold-search t) (message-id (message-fetch-field "message-id" t))) (or (not message-id) + ;; Is there an @ in the ID? (and (string-match "@" message-id) - (string-match "@[^\\.]*\\." message-id)) + ;; Is there a dot in the ID? + (string-match "@[^.]*\\." message-id) + ;; Does the ID end with a dot? + (not (string-match "\\.>" message-id))) (y-or-n-p (format "The Message-ID looks strange: \"%s\". Really post? " message-id))))) @@ -2337,8 +2564,6 @@ to find out how to use this." nil) (t t)))))) -(defconst message-max-size 60000) - (defun message-check-news-body-syntax () (and ;; Check for long lines. @@ -2418,18 +2643,19 @@ to find out how to use this." (defun message-do-fcc () "Process Fcc headers in the current buffer." (let ((case-fold-search t) - (buf (current-buffer)) + (coding-system-for-write 'raw-text) list file) (save-excursion (set-buffer (get-buffer-create " *message temp*")) (buffer-disable-undo (current-buffer)) (erase-buffer) - (insert-buffer-substring buf) + (insert-buffer-substring message-encoding-buffer) (save-restriction (message-narrow-to-headers) (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) @@ -2467,31 +2693,32 @@ to find out how to use this." ;; Remove empty lines in the header. (save-restriction (message-narrow-to-headers) + ;; Remove blank lines. (while (re-search-forward "^[ \t]*\n" nil t) - (replace-match "" t t))) + (replace-match "" t t)) - ;; Correct Newsgroups and Followup-To headers: change sequence of - ;; spaces to comma and eliminate spaces around commas. Eliminate - ;; embedded line breaks. - (goto-char (point-min)) - (while (re-search-forward "^\\(Newsgroups\\|Followup-To\\): +" nil t) - (save-restriction - (narrow-to-region - (point) - (if (re-search-forward "^[^ \t]" nil t) - (match-beginning 0) - (forward-line 1) - (point))) - (goto-char (point-min)) - (while (re-search-forward "\n[ \t]+" nil t) - (replace-match " " t t)) ;No line breaks (too confusing) - (goto-char (point-min)) - (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t) - (replace-match "," t t)) - (goto-char (point-min)) - ;; Remove trailing commas. - (when (re-search-forward ",+$" nil t) - (replace-match "" t t))))) + ;; Correct Newsgroups and Followup-To headers: Change sequence of + ;; spaces to comma and eliminate spaces around commas. Eliminate + ;; embedded line breaks. + (goto-char (point-min)) + (while (re-search-forward "^\\(Newsgroups\\|Followup-To\\): +" nil t) + (save-restriction + (narrow-to-region + (point) + (if (re-search-forward "^[^ \t]" nil t) + (match-beginning 0) + (forward-line 1) + (point))) + (goto-char (point-min)) + (while (re-search-forward "\n[ \t]+" nil t) + (replace-match " " t t)) ;No line breaks (too confusing) + (goto-char (point-min)) + (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t) + (replace-match "," t t)) + (goto-char (point-min)) + ;; Remove trailing commas. + (when (re-search-forward ",+$" nil t) + (replace-match "" t t)))))) (defun message-make-date () "Make a valid data header." @@ -2563,11 +2790,10 @@ to find out how to use this." (defun message-make-organization () "Make an Organization header." (let* ((organization - (or (getenv "ORGANIZATION") - (when message-user-organization + (when message-user-organization (if (message-functionp message-user-organization) (funcall message-user-organization) - message-user-organization))))) + message-user-organization)))) (save-excursion (message-set-work-buffer) (cond ((stringp organization) @@ -2601,7 +2827,9 @@ to find out how to use this." (when from (let ((stop-pos (string-match " *at \\| *@ \\| *(\\| *<" from))) - (concat (if stop-pos (substring from 0 stop-pos) from) + (concat (if (and stop-pos + (not (zerop stop-pos))) + (substring from 0 stop-pos) from) "'s message of \"" (if (or (not date) (string= date "")) "(unknown date)" date) @@ -2868,7 +3096,7 @@ Headers already prepared in the buffer are not modified." (insert "Original-") (beginning-of-line)) (when (or (message-news-p) - (string-match "^[^@]@.+\\..+" secure-sender)) + (string-match "@.+\\.." secure-sender)) (insert "Sender: " secure-sender "\n"))))))) (defun message-insert-courtesy-copy () @@ -2922,9 +3150,16 @@ Headers already prepared in the buffer are not modified." (widen) (forward-line 1))) +(defun message-fill-references (header value) + (insert (capitalize (symbol-name header)) + ": " + (std11-fill-msg-id-list-string + (if (consp value) (car value) value)) + "\n")) + (defun message-fill-header (header value) (let ((begin (point)) - (fill-column 78) + (fill-column 990) (fill-prefix "\t")) (insert (capitalize (symbol-name header)) ": " @@ -3087,7 +3322,12 @@ Headers already prepared in the buffer are not modified." (defun message-set-auto-save-file-name () "Associate the message buffer with a file in the drafts directory." (when message-autosave-directory - (setq message-draft-article (nndraft-request-associate-buffer "drafts")) + (if (gnus-alive-p) + (setq message-draft-article + (nndraft-request-associate-buffer "drafts")) + (setq buffer-file-name (expand-file-name "*message*" + message-autosave-directory)) + (setq buffer-auto-save-file-name (make-auto-save-file-name))) (clear-visited-file-modtime))) (defun message-disassociate-draft () @@ -3176,7 +3416,10 @@ Headers already prepared in the buffer are not modified." (unless follow-to (if (or (not wide) to-address) - (setq follow-to (list (cons 'To (or to-address reply-to from)))) + (progn + (setq follow-to (list (cons 'To (or to-address reply-to from)))) + (when (and wide mct) + (push (cons 'Cc mct) follow-to))) (let (ccalist) (save-excursion (message-set-work-buffer) @@ -3352,18 +3595,20 @@ responses here are directed to other newsgroups.")) (unless (message-news-p) (error "This is not a news article; canceling is impossible")) (when (yes-or-no-p "Do you really want to cancel this article? ") - (let (from newsgroups message-id distribution buf) + (let (from newsgroups message-id distribution buf sender) (save-excursion ;; Get header info. from original article. (save-restriction (message-narrow-to-head) (setq from (message-fetch-field "from") + sender (message-fetch-field "sender") newsgroups (message-fetch-field "newsgroups") message-id (message-fetch-field "message-id" t) distribution (message-fetch-field "distribution"))) ;; Make sure that this article was written by the user. (unless (string-equal - (downcase (cadr (mail-extract-address-components from))) + (downcase + (or sender (cadr (std11-extract-address-components from)))) (downcase (message-make-address))) (error "This article is not yours")) ;; Make control message. @@ -3381,7 +3626,9 @@ responses here are directed to other newsgroups.")) message-cancel-message) (message "Canceling your article...") (if (let ((message-syntax-checks - 'dont-check-for-anything-just-trust-me)) + 'dont-check-for-anything-just-trust-me) + (message-encoding-buffer (current-buffer)) + (message-edit-buffer (current-buffer))) (message-send-news)) (message "Canceling your article...done")) (kill-buffer buf))))) @@ -3395,9 +3642,10 @@ header line with the old Message-ID." (let ((cur (current-buffer))) ;; Check whether the user owns the article that is to be superseded. (unless (string-equal - (downcase (cadr (mail-extract-address-components - (message-fetch-field "from")))) - (downcase (message-make-address))) + (downcase (or (message-fetch-field "sender") + (cadr (mail-extract-address-components + (message-fetch-field "from"))))) + (downcase (message-make-sender))) (error "This article is not yours")) ;; Get a normal message buffer. (message-pop-to-buffer (message-buffer-name "supersede")) @@ -3444,7 +3692,8 @@ header line with the old Message-ID." (concat "[" (or (message-fetch-field (if (message-news-p) "newsgroups" "from")) "(nowhere)") - "] " (or (message-fetch-field "Subject") ""))))) + "] " (or (eword-decode-unstructured-field-body + (message-fetch-field "Subject") "")))))) ;;;###autoload (defun message-forward (&optional news) @@ -3494,7 +3743,10 @@ Optional NEWS will use news to forward instead of mail." (set-buffer (get-buffer-create " *message resend*")) (buffer-disable-undo (current-buffer)) (erase-buffer) - (message-setup `((To . ,address))) + ;; avoid to turn-on-mime-edit + (let (message-setup-hook) + (message-setup `((To . ,address))) + ) ;; Insert our usual headers. (message-generate-headers '(From Date To)) (message-narrow-to-headers) @@ -3517,7 +3769,7 @@ Optional NEWS will use news to forward instead of mail." (goto-char (point-max))) (insert mail-header-separator) ;; Rename all old ("Also-")Resent headers. - (while (re-search-backward "^\\(Also-\\)?Resent-" beg t) + (while (re-search-backward "^\\(Also-\\)*Resent-" beg t) (beginning-of-line) (insert "Also-")) ;; Quote any "From " lines at the beginning. @@ -3525,7 +3777,9 @@ Optional NEWS will use news to forward instead of mail." (when (looking-at "From ") (replace-match "X-From-Line: ")) ;; Send it. - (message-send-mail) + (let ((message-encoding-buffer (current-buffer)) + (message-edit-buffer (current-buffer))) + (message-send-mail)) (kill-buffer (current-buffer))) (message "Resending message to %s...done" address))) @@ -3681,6 +3935,7 @@ Do a `tab-to-tab-stop' if not in those headers." (defvar gnus-active-hashtb) (defun message-expand-group () + "Expand the group name under point." (let* ((b (save-excursion (save-restriction (narrow-to-region @@ -3691,7 +3946,8 @@ Do a `tab-to-tab-stop' if not in those headers." (point)) (skip-chars-backward "^, \t\n") (point)))) (completion-ignore-case t) - (string (buffer-substring b (point))) + (string (buffer-substring b (progn (skip-chars-forward "^,\t\n ") + (point)))) (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb)) (completions (all-completions string hashtb)) (cur (current-buffer)) @@ -3775,6 +4031,47 @@ regexp varstr." (cdr local))))) locals))) + +;;; @ for MIME Edit mode +;;; + +(defun message-maybe-setup-default-charset () + (let ((charset + (and (boundp 'gnus-summary-buffer) + (buffer-live-p gnus-summary-buffer) + (save-excursion + (set-buffer gnus-summary-buffer) + default-mime-charset)))) + (if charset + (progn + (make-local-variable 'default-mime-charset) + (setq default-mime-charset charset) + )))) + +(defun message-maybe-encode () + (when message-mime-mode + (run-hooks 'mime-edit-translate-hook) + (if (catch 'mime-edit-error + (save-excursion + (mime-edit-translate-body) + )) + (error "Translation error!") + ) + (end-of-invisible) + (run-hooks 'mime-edit-exit-hook) + )) + +(defun message-mime-insert-article (&optional message) + (interactive) + (let ((message-cite-function 'mime-edit-inserted-message-filter) + (message-reply-buffer gnus-original-article-buffer) + ) + (message-yank-original nil) + )) + +(set-alist 'mime-edit-message-inserter-alist + 'message-mode (function message-mime-insert-article)) + ;;; Miscellaneous functions ;; stolen (and renamed) from nnheader.el