X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=81bd8f2be3b59613919bcf3f3c865d7982f29326;hb=d85c80f876a6de1db60456db70cf1098ddf6da00;hp=e7f210144156963ec4e47a5d4ee7ea6d9906aa84;hpb=ef486b95dd94245221f44a216ad5ca88f06d9028;p=gnus diff --git a/lisp/message.el b/lisp/message.el index e7f210144..81bd8f2be 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -1,5 +1,6 @@ ;;; message.el --- composing mail and news messages -;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2000 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: mail, news @@ -29,18 +30,12 @@ ;;; Code: -(eval-when-compile (require 'cl)) - +(eval-when-compile + (require 'cl) + (defvar gnus-list-identifiers)) ; gnus-sum is required where necessary (require 'mailheader) (require 'nnheader) -(require 'easymenu) -(require 'custom) -(if (string-match "XEmacs\\|Lucid" emacs-version) - (require 'mail-abbrevs) - (require 'mailabbrev)) (require 'mail-parse) -(require 'mm-bodies) -(require 'mm-encode) (require 'mml) (defgroup message '((user-mail-address custom-variable) @@ -159,7 +154,7 @@ 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... + ;; 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. @@ -171,7 +166,8 @@ long-lines control-chars size new-text redirected-followup signature approved sender empty empty-headers message-id from subject shorten-followup-to existing-newsgroups buffer-file-name unchanged newsgroups." - :group 'message-news) + :group 'message-news + :type '(repeat sexp)) (defcustom message-required-news-headers '(From Newsgroups Subject Date Message-ID @@ -232,7 +228,7 @@ any confusion." :type 'regexp :group 'message-various) -(defcustom message-elide-elipsis "\n[...]\n\n" +(defcustom message-elide-ellipsis "\n[...]\n\n" "*The string which is inserted for elided text." :type 'string :group 'message-various) @@ -281,7 +277,7 @@ If t, use `message-user-organization-file'." (defcustom message-make-forward-subject-function 'message-forward-subject-author-subject - "*A list of functions that are called to generate a subject header for forwarded messages. + "*A list of functions that are called to generate a subject header for forwarded messages. The subject generated by the previous function is passed into each successive function. @@ -291,9 +287,24 @@ The provided functions are: newsgroup)), in brackets followed by the subject * message-forward-subject-fwd (Subject of article with 'Fwd:' prepended to it." - :group 'message-forwarding - :type '(radio (function-item message-forward-subject-author-subject) - (function-item message-forward-subject-fwd))) + :group 'message-forwarding + :type '(radio (function-item message-forward-subject-author-subject) + (function-item message-forward-subject-fwd))) + +(defcustom message-forward-as-mime t + "*If non-nil, forward messages as an inline/rfc822 MIME section. Otherwise, directly inline the old message in the forwarded message." + :group 'message-forwarding + :type 'boolean) + +(defcustom message-forward-show-mml t + "*If non-nil, forward messages are shown as mml. Otherwise, forward messages are unchanged." + :group 'message-forwarding + :type 'boolean) + +(defcustom message-forward-before-signature t + "*If non-nil, put forwarded message before signature, else after." + :group 'message-forwarding + :type 'boolean) (defcustom message-wash-forwarded-subjects nil "*If non-nil, try to remove as much old cruft as possible from the subject of messages before generating the new subject of a forward." @@ -305,8 +316,7 @@ The provided functions are: :group 'message-interface :type 'regexp) - -(defcustom message-forward-ignored-headers nil +(defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus" "*All headers that match this regexp will be deleted when forwarding a message." :group 'message-forwarding :type '(choice (const :tag "None" nil) @@ -317,7 +327,7 @@ The provided functions are: :group 'message-insertion :type 'regexp) -(defcustom message-cancel-message "I am canceling my own article." +(defcustom message-cancel-message "I am canceling my own article.\n" "Message to be inserted in the cancel message." :group 'message-interface :type 'string) @@ -380,10 +390,9 @@ always query the user whether to use the value. If it is the symbol (const use) (const ask))) -;; stuff relating to broken sendmail in MMDF (defcustom message-sendmail-f-is-evil nil - "*Non-nil means that \"-f username\" should not be added to the sendmail -command line, because it is even more evil than leaving it out." + "*Non-nil means that \"-f username\" should not be added to the sendmail command line. +Doing so would be even more evil than leaving it out." :group 'message-sending :type 'boolean) @@ -403,6 +412,11 @@ might set this variable to '(\"-f\" \"you@some.where\")." :group 'message-sending :type '(repeat string)) +(defvar message-cater-to-broken-inn t + "Non-nil means Gnus should not fold the `References' header. +Folding `References' makes ancient versions of INN create incorrect +NOV lines.") + (defvar gnus-post-method) (defvar gnus-select-method) (defcustom message-post-method @@ -574,8 +588,7 @@ these lines." :type 'message-header-lines) (defcustom message-default-news-headers "" - "*A string of header lines to be inserted in outgoing news -articles." + "*A string of header lines to be inserted in outgoing news articles." :group 'message-headers :group 'message-news :type 'message-header-lines) @@ -833,7 +846,7 @@ Defaults to `text-mode-abbrev-table'.") "\\([" cite-prefix "]+[" cite-suffix "]*\\)?" "[:>|}].*") (0 'message-cited-text-face)) - ("<#/?\\(multipart\\|part\\|external\\).*>" + ("<#/?\\(multipart\\|part\\|external\\|mml\\).*>" (0 'message-mml-face)))) "Additional expressions to highlight in Message mode.") @@ -878,6 +891,14 @@ The cdr of ech entry is a function for applying the face to a region.") mm-auto-save-coding-system "Coding system to compose mail.") +(defcustom message-send-mail-partially-limit 1000000 + "The limitation of messages sent as message/partial. +The lower bound of message size in characters, beyond which the message +should be sent in several parts. If it is nil, the size is unlimited." + :group 'message-buffers + :type '(choice (const :tag "unlimited" nil) + (integer 1000000))) + ;;; Internal variables. (defvar message-buffer-list nil) @@ -925,10 +946,10 @@ The cdr of ech entry is a function for applying the face to a region.") "\\([^\0-\b\n-\r\^?].*\\)? " ;; The time the message was sent. - "\\([^\0-\r \^?]+\\) +" ; day of the week - "\\([^\0-\r \^?]+\\) +" ; month - "\\([0-3]?[0-9]\\) +" ; day of month - "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *" ; time of day + "\\([^\0-\r \^?]+\\) +" ; day of the week + "\\([^\0-\r \^?]+\\) +" ; month + "\\([0-3]?[0-9]\\) +" ; day of month + "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *" ; time of day ;; Perhaps a time zone, specified by an abbreviation, or by a ;; numeric offset. @@ -981,6 +1002,7 @@ The cdr of ech entry is a function for applying the face to a region.") (autoload 'mh-send-letter "mh-comp") (autoload 'gnus-point-at-eol "gnus-util") (autoload 'gnus-point-at-bol "gnus-util") + (autoload 'gnus-output-to-rmail "gnus-util") (autoload 'gnus-output-to-mail "gnus-util") (autoload 'mail-abbrev-in-expansion-header-p "mailabbrev") (autoload 'nndraft-request-associate-buffer "nndraft") @@ -988,6 +1010,7 @@ The cdr of ech entry is a function for applying the face to a region.") (autoload 'gnus-open-server "gnus-int") (autoload 'gnus-request-post "gnus-int") (autoload 'gnus-alive-p "gnus-util") + (autoload 'gnus-group-name-charset "gnus-group") (autoload 'rmail-output "rmail")) @@ -1005,9 +1028,19 @@ The cdr of ech entry is a function for applying the face to a region.") `(delete-region (progn (beginning-of-line) (point)) (progn (forward-line ,(or n 1)) (point)))) +(defun message-unquote-tokens (elems) + "Remove double quotes (\") from strings in list." + (mapcar (lambda (item) + (while (string-match "^\\(.*\\)\"\\(.*\\)$" item) + (setq item (concat (match-string 1 item) + (match-string 2 item)))) + item) + elems)) + (defun message-tokenize-header (header &optional separator) "Split HEADER into a list of header elements. -\",\" is used as the separator." +SEPARATOR is a string of characters to be used as separators. \",\" +is used by default." (if (not header) nil (let ((regexp (format "[%s]+" (or separator ","))) @@ -1037,7 +1070,7 @@ The cdr of ech entry is a function for applying the face to a region.") ((and (eq (char-after) ?\)) (not quoted)) (setq paren nil)))) - (nreverse elems))))) + (nreverse elems))))) (defun message-mail-file-mbox-p (file) "Say whether FILE looks like a Unix mbox file." @@ -1052,12 +1085,13 @@ 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* ((inhibit-point-motion-hooks t) + (case-fold-search t) (value (mail-fetch-field header nil (not not-all)))) (when value (while (string-match "\n[\t ]+" value) (setq value (replace-match " " t t value))) - ;; We remove all text props. - (format "%s" value)))) + (set-text-properties 0 (length value) nil value) + value))) (defun message-narrow-to-field () "Narrow the buffer to the header on the current line." @@ -1080,10 +1114,10 @@ The cdr of ech entry is a function for applying the face to a region.") (unless (string-match "^\\([^:]+\\):[ \t]*[^ \t]" (car headers)) (error "Invalid header `%s'" (car headers))) (setq hclean (match-string 1 (car headers))) - (save-restriction - (message-narrow-to-headers) - (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t) - (insert (car headers) ?\n)))) + (save-restriction + (message-narrow-to-headers) + (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t) + (insert (car headers) ?\n)))) (setq headers (cdr headers)))) @@ -1110,6 +1144,21 @@ The cdr of ech entry is a function for applying the face to a region.") (and (listp form) (eq (car form) 'lambda)) (byte-code-function-p form))) +(defun message-strip-list-identifiers (subject) + "Remove list identifiers in `gnus-list-identifiers'." + (require 'gnus-sum) ; for gnus-list-identifiers + (let ((regexp (if (stringp gnus-list-identifiers) + gnus-list-identifiers + (mapconcat 'identity gnus-list-identifiers " *\\|")))) + (if (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp + " *\\)\\)+\\(Re: +\\)?\\)") subject) + (concat (substring subject 0 (match-beginning 1)) + (or (match-string 3 subject) + (match-string 5 subject)) + (substring subject + (match-end 1))) + subject))) + (defun message-strip-subject-re (subject) "Remove \"Re:\" from subject lines." (if (string-match message-subject-re-regexp subject) @@ -1296,6 +1345,7 @@ Point is left at the beginning of the narrowed-to region." (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups) (define-key message-mode-map "\C-c\C-y" 'message-yank-original) + (define-key message-mode-map "\C-c\M-\C-y" 'message-yank-buffer) (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message) (define-key message-mode-map "\C-c\C-w" 'message-insert-signature) (define-key message-mode-map "\C-c\M-h" 'message-insert-headers) @@ -1383,8 +1433,11 @@ C-c C-e message-elide-region (elide the text between point and mark). C-c C-v message-delete-not-region (remove the text outside the region). 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). -C-c C-a mml-attach-file (attach a file as MIME)." +C-c C-a mml-attach-file (attach a file as MIME). +M-RET message-newline-and-reformat (break the line and reformat)." (interactive) + (if (local-variable-p 'mml-buffer-list (current-buffer)) + (mml-destroy-buffers)) (kill-all-local-variables) (set (make-local-variable 'message-reply-buffer) nil) (make-local-variable 'message-send-actions) @@ -1433,8 +1486,10 @@ C-c C-a mml-attach-file (attach a file as MIME)." (set (make-local-variable 'message-mime-part) 0) ;;(when (fboundp 'mail-hist-define-keys) ;; (mail-hist-define-keys)) - (when (string-match "XEmacs\\|Lucid" emacs-version) - (message-setup-toolbar)) + (if (featurep 'xemacs) + (message-setup-toolbar) + (set (make-local-variable 'font-lock-defaults) + '(message-font-lock-keywords t))) (easy-menu-add message-mode-menu message-mode-map) (easy-menu-add message-mode-field-menu message-mode-map) ;; Allow mail alias things. @@ -1443,9 +1498,6 @@ C-c C-a mml-attach-file (attach a file as MIME)." (mail-abbrevs-setup) (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]*\\)+[ \t]*\\|" adaptive-fill-regexp)) @@ -1455,6 +1507,8 @@ C-c C-a mml-attach-file (attach a file as MIME)." (setq adaptive-fill-first-line-regexp (concat "[ \t]*[-a-z0-9A-Z]*\\(>[ \t]*\\)+[ \t]*\\|" adaptive-fill-first-line-regexp)) + (make-local-variable 'auto-fill-inhibit-regexp) + (setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:") (mm-enable-multibyte) (make-local-variable 'indent-tabs-mode) ;Turn off tabs for indentation. (setq indent-tabs-mode nil) @@ -1570,6 +1624,24 @@ With the prefix argument FORCE, insert the header anyway." (insert (or (message-fetch-reply-field "reply-to") (message-fetch-reply-field "from") ""))) +(defun message-widen-reply () + "Widen the reply to include maximum recipients." + (interactive) + (let ((follow-to + (and message-reply-buffer + (buffer-name message-reply-buffer) + (save-excursion + (set-buffer message-reply-buffer) + (message-get-reply-headers t))))) + (save-excursion + (save-restriction + (message-narrow-to-headers) + (dolist (elem follow-to) + (message-remove-header (symbol-name (car elem))) + (goto-char (point-min)) + (insert (symbol-name (car elem)) ": " + (cdr elem) "\n")))))) + (defun message-insert-newsgroups () "Insert the Newsgroups header from the article being replied to." (interactive) @@ -1614,19 +1686,24 @@ With the prefix argument FORCE, insert the header anyway." (defun message-newline-and-reformat () "Insert four newlines, and then reformat if inside quoted text." (interactive) - (let ((point (point)) - quoted) - (save-excursion - (beginning-of-line) - (if (looking-at (sc-cite-regexp)) - (setq quoted (buffer-substring (match-beginning 0) (match-end 0))))) - (insert "\n\n\n\n") + (let ((prefix "[]>ยป|:}+ \t]*") + (supercite-thing "[-._a-zA-Z0-9]*[>]+[ \t]*") + quoted point) + (unless (bolp) + (save-excursion + (beginning-of-line) + (when (looking-at (concat prefix + supercite-thing)) + (setq quoted (match-string 0)))) + (insert "\n")) + (setq point (point)) + (insert "\n\n\n") (delete-region (point) (re-search-forward "[ \t]*")) (when quoted (insert quoted)) (fill-paragraph nil) (goto-char point) - (forward-line 2))) + (forward-line 1))) (defun message-insert-signature (&optional force) "Insert a signature. See documentation for the `message-signature' variable." @@ -1667,13 +1744,11 @@ With the prefix argument FORCE, insert the header anyway." (defun message-elide-region (b e) "Elide the text between point and mark. -An ellipsis (from `message-elide-elipsis') will be inserted where the +An ellipsis (from `message-elide-ellipsis') will be inserted where the text was killed." (interactive "r") (kill-region b e) - (unless (bolp) - (insert "\n")) - (insert message-elide-elipsis)) + (insert message-elide-ellipsis)) (defvar message-caesar-translation-table nil) @@ -1692,16 +1767,9 @@ text was killed." ;; We build the table, if necessary. (when (or (not message-caesar-translation-table) (/= (aref message-caesar-translation-table ?a) (+ ?a n))) - (setq message-caesar-translation-table - (message-make-caesar-translation-table n))) - ;; Then we translate the region. Do it this way to retain - ;; text properties. - (while (< b e) - (when (< (char-after b) 255) - (subst-char-in-region - b (1+ b) (char-after b) - (aref message-caesar-translation-table (char-after b)))) - (incf b)))) + (setq message-caesar-translation-table + (message-make-caesar-translation-table n))) + (translate-region b e message-caesar-translation-table))) (defun message-make-caesar-translation-table (n) "Create a rot table with offset N." @@ -1738,11 +1806,8 @@ Mail and USENET news headers are not rotated." (save-restriction (when (message-goto-body) (narrow-to-region (point) (point-max))) - (let ((body (buffer-substring (point-min) (point-max)))) - (unless (equal 0 (call-process-region - (point-min) (point-max) program t t)) - (insert body) - (message "%s failed" program)))))) + (shell-command-on-region + (point-min) (point-max) program nil t)))) (defun message-rename-buffer (&optional enter-string) "Rename the *message* buffer to \"*message* RECIPIENT\". @@ -1847,6 +1912,24 @@ prefix, and don't delete any headers." (unless modified (setq message-checksum (message-checksum)))))) +(defun message-yank-buffer (buffer) + "Insert BUFFER into the current buffer and quote it." + (interactive "bYank buffer: ") + (let ((message-reply-buffer buffer)) + (save-window-excursion + (message-yank-original)))) + +(defun message-buffers () + "Return a list of active message buffers." + (let (buffers) + (save-excursion + (dolist (buffer (buffer-list t)) + (set-buffer buffer) + (when (and (eq major-mode 'message-mode) + (null message-sent-message-via)) + (push (buffer-name buffer) buffers)))) + (nreverse buffers))) + (defun message-cite-original-without-signature () "Cite function in the standard Message manner." (let ((start (point)) @@ -1857,6 +1940,8 @@ prefix, and don't delete any headers." message-indent-citation-function (list message-indent-citation-function))))) (mml-quote-region start end) + ;; Allow undoing. + (undo-boundary) (goto-char end) (when (re-search-backward message-signature-separator start t) ;; Also peel off any blank lines before the signature. @@ -2002,10 +2087,12 @@ The text will also be indented the normal way." (defun message-send (&optional arg) "Send the message in the current buffer. -If `message-interactive' is non-nil, wait for success indication -or error messages, and inform user. -Otherwise any failure is reported in a message back to -the user from the mailer." +If `message-interactive' is non-nil, wait for success indication or +error messages, and inform user. +Otherwise any failure is reported in a message back to the user from +the mailer. +The usage of ARG is defined by the instance that called Message. +It should typically alter the sending method in some way or other." (interactive "P") ;; Make it possible to undo the coming changes. (undo-boundary) @@ -2097,12 +2184,83 @@ the user from the mailer." (eval (car actions))))) (pop actions))) +(defun message-send-mail-partially () + "Sendmail as message/partial." + (let ((p (goto-char (point-min))) + (tembuf (message-generate-new-buffer-clone-locals " message temp")) + (curbuf (current-buffer)) + (id (message-make-message-id)) (n 1) + plist total header required-mail-headers) + (while (not (eobp)) + (if (< (point-max) (+ p message-send-mail-partially-limit)) + (goto-char (point-max)) + (goto-char (+ p message-send-mail-partially-limit)) + (beginning-of-line) + (if (<= (point) p) (forward-line 1))) ;; In case of bad message. + (push p plist) + (setq p (point))) + (setq total (length plist)) + (push (point-max) plist) + (setq plist (nreverse plist)) + (unwind-protect + (save-excursion + (setq p (pop plist)) + (while plist + (set-buffer curbuf) + (copy-to-buffer tembuf p (car plist)) + (set-buffer tembuf) + (goto-char (point-min)) + (if header + (progn + (goto-char (point-min)) + (narrow-to-region (point) (point)) + (insert header)) + (message-goto-eoh) + (setq header (buffer-substring (point-min) (point))) + (goto-char (point-min)) + (narrow-to-region (point) (point)) + (insert header) + (message-remove-header "Mime-Version") + (message-remove-header "Content-Type") + (message-remove-header "Content-Transfer-Encoding") + (message-remove-header "Message-ID") + (message-remove-header "Lines") + (goto-char (point-max)) + (insert "Mime-Version: 1.0\n") + (setq header (buffer-substring (point-min) (point-max)))) + (goto-char (point-max)) + (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n" + id n total)) + (let ((mail-header-separator "")) + (when (memq 'Message-ID message-required-mail-headers) + (insert "Message-ID: " (message-make-message-id) "\n")) + (when (memq 'Lines message-required-mail-headers) + (let ((mail-header-separator "")) + (insert "Lines: " (message-make-lines) "\n"))) + (message-goto-subject) + (end-of-line) + (insert (format " (%d/%d)" n total)) + (goto-char (point-max)) + (insert "\n") + (widen) + (mm-with-unibyte-current-buffer + (funcall message-send-mail-function))) + (setq n (+ n 1)) + (setq p (pop plist)) + (erase-buffer))) + (kill-buffer tembuf)))) + (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)) - (mailbuf (current-buffer))) + (let* ((tembuf (message-generate-new-buffer-clone-locals " message temp")) + (case-fold-search nil) + (news (message-news-p)) + (mailbuf (current-buffer)) + (message-this-is-mail t) + (message-posting-charset + (if (fboundp 'gnus-setup-posting-charset) + (gnus-setup-posting-charset nil) + message-posting-charset))) (save-restriction (message-narrow-to-headers) ;; Insert some headers. @@ -2129,7 +2287,8 @@ the user from the mailer." (message-generate-headers '(Lines))) ;; Remove some headers. (message-remove-header message-ignored-mail-headers t) - (mail-encode-encoded-word-buffer)) + (let ((mail-parse-charset message-default-charset)) + (mail-encode-encoded-word-buffer))) (goto-char (point-max)) ;; require one newline at the end. (or (= (preceding-char) ?\n) @@ -2138,7 +2297,12 @@ the user from the mailer." (or (message-fetch-field "cc") (message-fetch-field "to"))) (message-insert-courtesy-copy)) - (funcall message-send-mail-function)) + (if (or (not message-send-mail-partially-limit) + (< (point-max) message-send-mail-partially-limit) + (not (y-or-n-p "The message size is too large, should it be sent partially?"))) + (mm-with-unibyte-current-buffer + (funcall message-send-mail-function)) + (message-send-mail-partially))) (kill-buffer tembuf)) (set-buffer mailbuf) (push 'mail message-sent-message-via))) @@ -2146,7 +2310,8 @@ the user from the mailer." (defun message-send-mail-with-sendmail () "Send off the prepared buffer with sendmail." (let ((errbuf (if message-interactive - (generate-new-buffer " sendmail errors") + (message-generate-new-buffer-clone-locals + " sendmail errors") 0)) resend-to-addresses delimline) (let ((case-fold-search t)) @@ -2183,7 +2348,7 @@ the user from the mailer." ;; But some systems are more broken with -f, so ;; we'll let users override this. (if (null message-sendmail-f-is-evil) - (list "-f" (user-login-name))) + (list "-f" (message-make-address))) ;; These mean "report errors by mail" ;; and "deliver in background". (if (null message-interactive) '("-oem" "-odb")) @@ -2268,18 +2433,29 @@ to find out how to use this." (mh-send-letter))) (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)) - (messbuf (current-buffer)) - (message-syntax-checks - (if arg - (cons '(existing-newsgroups . disabled) - message-syntax-checks) - message-syntax-checks)) - result) + (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)) + (group-name-charset (gnus-group-name-charset method "")) + (rfc2047-header-encoding-alist + (if group-name-charset + (cons (cons "Newsgroups" group-name-charset) + rfc2047-header-encoding-alist) + rfc2047-header-encoding-alist)) + (messbuf (current-buffer)) + (message-syntax-checks + (if arg + (cons '(existing-newsgroups . disabled) + message-syntax-checks) + message-syntax-checks)) + (message-this-is-news t) + (message-posting-charset (gnus-setup-posting-charset + (save-restriction + (message-narrow-to-headers-or-head) + (message-fetch-field "Newsgroups")))) + result) (if (not (message-check-news-body-syntax)) nil (save-restriction @@ -2288,6 +2464,10 @@ to find out how to use this." (message-generate-headers message-required-news-headers) ;; Let the user do all of the above. (run-hooks 'message-header-hook)) + (if group-name-charset + (setq message-syntax-checks + (cons '(valid-newsgroups . disabled) + message-syntax-checks))) (message-cleanup-headers) (if (not (message-check-news-syntax)) nil @@ -2310,7 +2490,7 @@ to find out how to use this." (message-generate-headers '(Lines))) ;; Remove some headers. (message-remove-header message-ignored-news-headers t) - (let ((mail-parse-charset message-posting-charset)) + (let ((mail-parse-charset message-default-charset)) (mail-encode-encoded-word-buffer))) (goto-char (point-max)) ;; require one newline at the end. @@ -2325,8 +2505,8 @@ to find out how to use this." (backward-char 1)) (run-hooks 'message-send-news-hook) (gnus-open-server method) - (setq result (let ((mail-header-separator "")) - (gnus-request-post method)))) + (setq result (let ((mail-header-separator "")) + (gnus-request-post method)))) (kill-buffer tembuf)) (set-buffer messbuf) (if result @@ -2361,7 +2541,7 @@ to find out how to use this." (defun message-check-news-header-syntax () (and ;; Check Newsgroups header. - (message-check 'newsgroyps + (message-check 'newsgroups (let ((group (message-fetch-field "newsgroups"))) (or (and group @@ -2636,9 +2816,19 @@ to find out how to use this." (while (setq file (message-fetch-field "fcc")) (push file list) (message-remove-header "fcc" nil t))) + (message-encode-message-body) + (save-restriction + (message-narrow-to-headers) + (let ((mail-parse-charset message-default-charset) + (rfc2047-header-encoding-alist + (cons '("Newsgroups" . default) + rfc2047-header-encoding-alist))) + (mail-encode-encoded-word-buffer))) (goto-char (point-min)) - (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) - (replace-match "" t t) + (when (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$") + nil t) + (replace-match "" t t )) ;; Process FCC operations. (while list (setq file (pop list)) @@ -2658,14 +2848,13 @@ 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) "Append this article to Unix/babyl mail file.." (if (and (file-readable-p filename) (mail-file-babyl-p filename)) - (rmail-output-to-rmail-file filename t) + (gnus-output-to-rmail filename t) (gnus-output-to-mail filename t))) (defun message-cleanup-headers () @@ -2784,9 +2973,9 @@ If NOW, use that time instead." "Make an Organization header." (let* ((organization (when message-user-organization - (if (message-functionp message-user-organization) - (funcall message-user-organization) - message-user-organization)))) + (if (message-functionp message-user-organization) + (funcall message-user-organization) + message-user-organization)))) (save-excursion (message-set-work-buffer) (cond ((stringp organization) @@ -3043,7 +3232,7 @@ Headers already prepared in the buffer are not modified." ;; The element is a symbol. We insert the value ;; of this symbol, if any. (symbol-value header)) - (t + ((not (message-check-element header)) ;; We couldn't generate a value for this header, ;; so we just ask the user. (read-from-minibuffer @@ -3148,7 +3337,7 @@ Headers already prepared in the buffer are not modified." (defun message-fill-header (header value) (let ((begin (point)) - (fill-column 990) + (fill-column 78) (fill-prefix "\t")) (insert (capitalize (symbol-name header)) ": " @@ -3167,23 +3356,63 @@ Headers already prepared in the buffer are not modified." (replace-match " " t t)) (goto-char (point-max))))) +(defun message-shorten-1 (list cut surplus) + ;; Cut SURPLUS elements out of LIST, beginning with CUTth one. + (setcdr (nthcdr (- cut 2) list) + (nthcdr (+ (- cut 2) surplus 1) list))) + (defun message-shorten-references (header references) - "Limit REFERENCES to be shorter than 988 characters." - (let ((max 988) - (cut 4) + "Trim REFERENCES to be less than 31 Message-ID long, and fold them. +If folding is disallowed, also check that the REFERENCES are less +than 988 characters long, and if they are not, trim them until they are." + (let ((maxcount 31) + (count 0) + (cut 6) refs) (with-temp-buffer (insert references) (goto-char (point-min)) + ;; Cons a list of valid references. (while (re-search-forward "<[^>]+>" nil t) (push (match-string 0) refs)) - (setq refs (nreverse refs)) - (while (> (length (mapconcat 'identity refs " ")) max) - (when (< (length refs) (1+ cut)) - (decf cut)) - (setcdr (nthcdr cut refs) (cddr (nthcdr cut refs))))) - (insert (capitalize (symbol-name header)) ": " - (mapconcat 'identity refs " ") "\n"))) + (setq refs (nreverse refs) + count (length refs))) + + ;; If the list has more than MAXCOUNT elements, trim it by + ;; removing the CUTth element and the required number of + ;; elements that follow. + (when (> count maxcount) + (let ((surplus (- count maxcount))) + (message-shorten-1 refs cut surplus) + (decf count surplus))) + + ;; If folding is disallowed, make sure the total length (including + ;; the spaces between) will be less than MAXSIZE characters. + ;; + ;; Only disallow folding for News messages. At this point the headers + ;; have not been generated, thus we use message-this-is-news directly. + (when (and message-this-is-news message-cater-to-broken-inn) + (let ((maxsize 988) + (totalsize (+ (apply #'+ (mapcar #'length refs)) + (1- count))) + (surplus 0) + (ptr (nthcdr (1- cut) refs))) + ;; Decide how many elements to cut off... + (while (> totalsize maxsize) + (decf totalsize (1+ (length (car ptr)))) + (incf surplus) + (setq ptr (cdr ptr))) + ;; ...and do it. + (when (> surplus 0) + (message-shorten-1 refs cut surplus)))) + + ;; Finally, collect the references back into a string and insert + ;; it into the buffer. + (let ((refstring (mapconcat #'identity refs " "))) + (if (and message-this-is-news message-cater-to-broken-inn) + (insert (capitalize (symbol-name header)) ": " + refstring "\n") + (message-fill-header header refstring))))) (defun message-position-point () "Move point to where the user probably wants to find it." @@ -3400,16 +3629,79 @@ OTHER-HEADERS is an alist of header/value pairs." (message-setup `((Newsgroups . ,(or newsgroups "")) (Subject . ,(or subject "")))))) +(defun message-get-reply-headers (wide &optional to-address) + (let (follow-to mct never-mct from to cc reply-to ccalist) + ;; Find all relevant headers we need. + (setq from (message-fetch-field "from") + to (message-fetch-field "to") + cc (message-fetch-field "cc") + mct (message-fetch-field "mail-copies-to") + reply-to (message-fetch-field "reply-to")) + + ;; Handle special values of Mail-Copies-To. + (when mct + (cond ((or (equal (downcase mct) "never") + (equal (downcase mct) "nobody")) + (setq never-mct t) + (setq mct nil)) + ((or (equal (downcase mct) "always") + (equal (downcase mct) "poster")) + (setq mct (or reply-to from))))) + + (if (or (not wide) + to-address) + (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) + (unless never-mct + (insert (or reply-to from ""))) + (insert (if to (concat (if (bolp) "" ", ") to "") "")) + (insert (if mct (concat (if (bolp) "" ", ") mct) "")) + (insert (if cc (concat (if (bolp) "" ", ") cc) "")) + (goto-char (point-min)) + (while (re-search-forward "[ \t]+" nil t) + (replace-match " " t t)) + ;; Remove addresses that match `rmail-dont-reply-to-names'. + (let ((rmail-dont-reply-to-names message-dont-reply-to-names)) + (insert (prog1 (rmail-dont-reply-to (buffer-string)) + (erase-buffer)))) + (goto-char (point-min)) + ;; Perhaps "Mail-Copies-To: never" removed the only address? + (when (eobp) + (insert (or reply-to from ""))) + (setq ccalist + (mapcar + (lambda (addr) + (cons (mail-strip-quoted-names addr) addr)) + (message-tokenize-header (buffer-string)))) + (let ((s ccalist)) + (while s + (setq ccalist (delq (assoc (car (pop s)) s) ccalist))))) + (setq follow-to (list (cons 'To (cdr (pop ccalist))))) + (when ccalist + (let ((ccs (cons 'Cc (mapconcat + (lambda (addr) (cdr addr)) ccalist ", ")))) + (when (string-match "^ +" (cdr ccs)) + (setcdr ccs (substring (cdr ccs) (match-end 0)))) + (push ccs follow-to))))) + follow-to)) + + ;;;###autoload (defun message-reply (&optional to-address wide) "Start editing a reply to the article in the current buffer." (interactive) + (require 'gnus-sum) ; for gnus-list-identifiers (let ((cur (current-buffer)) from subject date reply-to to cc references message-id follow-to (inhibit-point-motion-hooks t) (message-this-is-mail t) - mct never-mct gnus-warning) + gnus-warning) (save-restriction (message-narrow-to-head) ;; Allow customizations to have their say. @@ -3422,82 +3714,26 @@ OTHER-HEADERS is an alist of header/value pairs." (save-excursion (setq follow-to (funcall message-wide-reply-to-function))))) - ;; Find all relevant headers we need. - (setq from (message-fetch-field "from") - date (message-fetch-field "date") - subject (or (message-fetch-field "subject") "none") - to (message-fetch-field "to") - cc (message-fetch-field "cc") - mct (message-fetch-field "mail-copies-to") - reply-to (message-fetch-field "reply-to") + (setq message-id (message-fetch-field "message-id" t) references (message-fetch-field "references") - message-id (message-fetch-field "message-id" t)) - ;; Remove any (buggy) Re:'s that are present and make a - ;; proper one. - (when (string-match message-subject-re-regexp subject) - (setq subject (substring subject (match-end 0)))) - (setq subject (concat "Re: " subject)) + date (message-fetch-field "date") + from (message-fetch-field "from") + subject (or (message-fetch-field "subject") "none")) + (if gnus-list-identifiers + (setq subject (message-strip-list-identifiers subject))) + (setq subject (concat "Re: " (message-strip-subject-re subject))) - (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) - (string-match "<[^>]+>" gnus-warning)) - (setq message-id (match-string 0 gnus-warning))) + (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) + (string-match "<[^>]+>" gnus-warning)) + (setq message-id (match-string 0 gnus-warning))) - ;; Handle special values of Mail-Copies-To. - (when mct - (cond ((or (equal (downcase mct) "never") - (equal (downcase mct) "nobody")) - (setq never-mct t) - (setq mct nil)) - ((or (equal (downcase mct) "always") - (equal (downcase mct) "poster")) - (setq mct (or reply-to from))))) - - (unless follow-to - (if (or (not wide) - to-address) - (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) - (unless never-mct - (insert (or reply-to from ""))) - (insert (if to (concat (if (bolp) "" ", ") to "") "")) - (insert (if mct (concat (if (bolp) "" ", ") mct) "")) - (insert (if cc (concat (if (bolp) "" ", ") cc) "")) - (goto-char (point-min)) - (while (re-search-forward "[ \t]+" nil t) - (replace-match " " t t)) - ;; Remove addresses that match `rmail-dont-reply-to-names'. - (let ((rmail-dont-reply-to-names message-dont-reply-to-names)) - (insert (prog1 (rmail-dont-reply-to (buffer-string)) - (erase-buffer)))) - (goto-char (point-min)) - ;; Perhaps Mail-Copies-To: never removed the only address? - (when (eobp) - (insert (or reply-to from ""))) - (setq ccalist - (mapcar - (lambda (addr) - (cons (mail-strip-quoted-names addr) addr)) - (message-tokenize-header (buffer-string)))) - (let ((s ccalist)) - (while s - (setq ccalist (delq (assoc (car (pop s)) s) ccalist))))) - (setq follow-to (list (cons 'To (cdr (pop ccalist))))) - (when ccalist - (let ((ccs (cons 'Cc (mapconcat - (lambda (addr) (cdr addr)) ccalist ", ")))) - (when (string-match "^ +" (cdr ccs)) - (setcdr ccs (substring (cdr ccs) (match-end 0)))) - (push ccs follow-to)))))) - (widen)) + (unless follow-to + (setq follow-to (message-get-reply-headers wide to-address)))) - (message-pop-to-buffer (message-buffer-name - (if wide "wide reply" "reply") from - (if wide to-address nil))) + (message-pop-to-buffer + (message-buffer-name + (if wide "wide reply" "reply") from + (if wide to-address nil))) (setq message-reply-headers (vector 0 subject from date message-id references 0 0 "")) @@ -3522,6 +3758,7 @@ OTHER-HEADERS is an alist of header/value pairs." "Follow up to the message in the current buffer. If TO-NEWSGROUPS, use that as the new Newsgroups line." (interactive) + (require 'gnus-sum) ; for gnus-list-identifiers (let ((cur (current-buffer)) from subject date reply-to mct references message-id follow-to @@ -3556,11 +3793,9 @@ If TO-NEWSGROUPS, use that as the new Newsgroups line." (let ((case-fold-search t)) (string-match "world" distribution))) (setq distribution nil)) - ;; Remove any (buggy) Re:'s that are present and make a - ;; proper one. - (when (string-match message-subject-re-regexp subject) - (setq subject (substring subject (match-end 0)))) - (setq subject (concat "Re: " subject)) + (if gnus-list-identifiers + (setq subject (message-strip-list-identifiers subject))) + (setq subject (concat "Re: " (message-strip-subject-re subject))) (widen)) (message-pop-to-buffer (message-buffer-name "followup" from newsgroups)) @@ -3631,15 +3866,16 @@ responses here are directed to other newsgroups.")) ;;;###autoload -(defun message-cancel-news () - "Cancel an article you posted." - (interactive) +(defun message-cancel-news (&optional arg) + "Cancel an article you posted. +If ARG, allow editing of the cancellation message." + (interactive "P") (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 sender) (save-excursion - ;; Get header info. from original article. + ;; Get header info from original article. (save-restriction (message-narrow-to-head) (setq from (message-fetch-field "from") @@ -3658,7 +3894,9 @@ responses here are directed to other newsgroups.")) (message-make-from)))))) (error "This article is not yours")) ;; Make control message. - (setq buf (set-buffer (get-buffer-create " *message cancel*"))) + (if arg + (message-news) + (setq buf (set-buffer (get-buffer-create " *message cancel*")))) (erase-buffer) (insert "Newsgroups: " newsgroups "\n" "From: " (message-make-from) "\n" @@ -3670,12 +3908,13 @@ responses here are directed to other newsgroups.")) mail-header-separator "\n" message-cancel-message) (run-hooks 'message-cancel-hook) - (message "Canceling your article...") - (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))))) + (unless arg + (message "Canceling your article...") + (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 (defun message-supersede () @@ -3699,6 +3938,7 @@ header line with the old Message-ID." ;; Get a normal message buffer. (message-pop-to-buffer (message-buffer-name "supersede")) (insert-buffer-substring cur) + (mime-to-mml) (message-narrow-to-head) ;; Remove unwanted headers. (when message-ignored-supersedes-headers @@ -3720,6 +3960,8 @@ header line with the old Message-ID." (cond ((save-window-excursion (if (not (eq system-type 'vax-vms)) (with-output-to-temp-buffer "*Directory*" + (with-current-buffer standard-output + (fundamental-mode)) ; for Emacs 20.4+ (buffer-disable-undo standard-output) (let ((default-directory "/")) (call-process @@ -3805,30 +4047,64 @@ the message." subject)))) ;;;###autoload -(defun message-forward (&optional news) +(defun message-forward (&optional news digest) "Forward the current message via mail. -Optional NEWS will use news to forward instead of mail." +Optional NEWS will use news to forward instead of mail. +Optional DIGEST will use digest to forward." (interactive "P") - (let ((cur (current-buffer)) - (subject (message-make-forward-subject)) - art-beg) + (let* ((cur (current-buffer)) + (subject (if message-forward-show-mml + (message-make-forward-subject) + (mail-decode-encoded-word-string + (message-make-forward-subject)))) + art-beg) (if news (message-news nil subject) (message-mail nil subject)) ;; Put point where we want it before inserting the forwarded ;; message. - (message-goto-body) - (insert "\n\n<#part type=message/rfc822 disposition=inline>\n") - (let ((b (point)) - e) - (mml-insert-buffer cur) + (if message-forward-before-signature + (message-goto-body) + (goto-char (point-max))) + (if message-forward-as-mime + (if digest + (insert "\n<#multipart type=digest>\n") + (if message-forward-show-mml + (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n") + (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n"))) + (insert "\n-------------------- Start of forwarded message --------------------\n")) + (let ((b (point)) e) + (if digest + (if message-forward-as-mime + (insert-buffer-substring cur) + (mml-insert-buffer cur)) + (if message-forward-show-mml + (insert-buffer-substring cur) + (mm-with-unibyte-current-buffer + (mml-insert-buffer cur)))) (setq e (point)) - (insert "<#/part>\n") - (when message-forward-ignored-headers - (save-restriction - (narrow-to-region b e) - (message-narrow-to-head) - (message-remove-header message-forward-ignored-headers t)))) + (if message-forward-as-mime + (if digest + (insert "<#/multipart>\n") + (if message-forward-show-mml + (insert "<#/mml>\n") + (insert "<#/part>\n"))) + (insert "\n-------------------- End of forwarded message --------------------\n")) + (if (and digest message-forward-as-mime) + (save-restriction + (narrow-to-region b e) + (goto-char b) + (narrow-to-region (point) + (or (search-forward "\n\n" nil t) (point))) + (delete-region (point-min) (point-max))) + (when (and (not current-prefix-arg) + message-forward-ignored-headers) + (save-restriction + (narrow-to-region b e) + (goto-char b) + (narrow-to-region (point) + (or (search-forward "\n\n" nil t) (point))) + (message-remove-header message-forward-ignored-headers t))))) (message-position-point))) ;;;###autoload @@ -3883,7 +4159,7 @@ Optional NEWS will use news to forward instead of mail." ;;;###autoload (defun message-bounce () "Re-mail the current message. -This only makes sense if the current message is a bounce message than +This only makes sense if the current message is a bounce message that contains some mail you have written which has been bounced back to you." (interactive) @@ -3908,6 +4184,8 @@ you." (if (re-search-forward "^[^ \n\t]+:" nil t) (match-beginning 0) (point)))) + (mm-enable-multibyte) + (mime-to-mml) (save-restriction (message-narrow-to-head) (message-remove-header message-ignored-bounced-headers t) @@ -4083,6 +4361,7 @@ The following arguments may contain lists of values." (save-excursion (with-output-to-temp-buffer " *MESSAGE information message*" (set-buffer " *MESSAGE information message*") + (fundamental-mode) ; for Emacs 20.4+ (mapcar 'princ text) (goto-char (point-min)))) (funcall ask question)) @@ -4106,20 +4385,22 @@ regexp varstr." (let ((oldbuf (current-buffer))) (save-excursion (set-buffer (generate-new-buffer name)) - (message-clone-locals oldbuf) + (message-clone-locals oldbuf varstr) (current-buffer)))) -(defun message-clone-locals (buffer) +(defun message-clone-locals (buffer &optional varstr) "Clone the local variables from BUFFER to the current buffer." (let ((locals (save-excursion (set-buffer buffer) (buffer-local-variables))) - (regexp "^gnus\\|^nn\\|^message")) + (regexp "^gnus\\|^nn\\|^message\\|^user-mail-address")) (mapcar (lambda (local) (when (and (consp local) (car local) - (string-match regexp (symbol-name (car local)))) + (string-match regexp (symbol-name (car local))) + (or (null varstr) + (string-match varstr (symbol-name (car local))))) (ignore-errors (set (make-local-variable (car local)) (cdr local))))) @@ -4128,17 +4409,20 @@ regexp varstr." ;;; Miscellaneous functions ;; stolen (and renamed) from nnheader.el -(defun message-replace-chars-in-string (string from to) - "Replace characters in STRING from FROM to TO." - (let ((string (substring string 0)) ;Copy string. - (len (length string)) - (idx 0)) - ;; Replace all occurrences of FROM with TO. - (while (< idx len) - (when (= (aref string idx) from) - (aset string idx to)) - (setq idx (1+ idx))) - string)) +(if (fboundp 'subst-char-in-string) + (defsubst message-replace-chars-in-string (string from to) + (subst-char-in-string from to string)) + (defun message-replace-chars-in-string (string from to) + "Replace characters in STRING from FROM to TO." + (let ((string (substring string 0)) ;Copy string. + (len (length string)) + (idx 0)) + ;; Replace all occurrences of FROM with TO. + (while (< idx len) + (when (= (aref string idx) from) + (aset string idx to)) + (setq idx (1+ idx))) + string))) ;;; ;;; MIME functions @@ -4149,8 +4433,7 @@ regexp varstr." (defun message-encode-message-body () (unless message-inhibit-body-encoding (let ((mail-parse-charset (or mail-parse-charset - message-default-charset - message-posting-charset)) + message-default-charset)) (case-fold-search t) lines content-type-p) (message-goto-body) @@ -4165,7 +4448,7 @@ regexp varstr." (delete-char 1) (search-forward "\n\n") (setq lines (buffer-substring (point-min) (1- (point)))) - (delete-region (point-min) (point)))))) + (delete-region (point-min) (point)))))) (save-restriction (message-narrow-to-headers-or-head) (message-remove-header "Mime-Version") @@ -4195,12 +4478,16 @@ regexp varstr." (if (fboundp 'mail-abbrevs-setup) (let ((mail-abbrev-mode-regexp "") (minibuffer-setup-hook 'mail-abbrevs-setup)) - (read-from-minibuffer prompt))) - (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook)) - (read-string prompt))) + (read-from-minibuffer prompt)) + (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook)) + (read-string prompt)))) (provide 'message) (run-hooks 'message-load-hook) +;; Local Variables: +;; coding: iso-8859-1 +;; End: + ;;; message.el ends here