X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=32cfe3b9abf968391f298151f549de78a4293b34;hb=99648d27eedbdead431411bfa31edd18c4ad5db4;hp=2a9751a92f02bf0fd53ea3e706a65123a39d72a6;hpb=7452849ffc4c8b0ada15df4e17482c2d7cd53392;p=gnus diff --git a/lisp/message.el b/lisp/message.el index 2a9751a92..32cfe3b9a 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -1,6 +1,6 @@ ;;; message.el --- composing mail and news messages -;; Copyright (C) 1996-2012 Free Software Foundation, Inc. +;; Copyright (C) 1996-2014 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: mail, news @@ -28,9 +28,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) @@ -50,6 +47,7 @@ (require 'mml) (require 'rfc822) (require 'format-spec) +(require 'dired) (autoload 'mailclient-send-it "mailclient") ;; Emacs 22 or contrib/ @@ -268,7 +266,7 @@ This is a list of regexps and regexp matches." :type 'sexp) (defcustom message-ignored-news-headers - "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:" + "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:\\|^X-Message-SMTP-Method:\\|^X-Gnus-Delayed:" "*Regexp of headers to be removed unconditionally before posting." :group 'message-news :group 'message-headers @@ -535,7 +533,7 @@ If t, use `message-user-organization-file'." (setq orgfile f))) orgfile) "*Local news organization file." - :type 'file + :type '(choice (const nil) file) :link '(custom-manual "(message)News Headers") :group 'message-headers) @@ -600,8 +598,10 @@ Done before generating the new subject of a forward." ;; comes back to you (e.g. a mailing-list to which you subscribe, in which ;; case you may be removed from the list on the grounds that mail to you ;; bounced with a "mailing loop" error). - "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:\\|^>?From \\|^Delivered-To:" + "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:\\|^>?From \\|^Delivered-To:\ +\\|^X-Content-Length:\\|^X-UIDL:" "*All headers that match this regexp will be deleted when resending a message." + :version "24.4" :group 'message-interface :link '(custom-manual "(message)Resending") :type '(repeat :value-to-internal (lambda (widget value) @@ -612,7 +612,8 @@ Done before generating the new subject of a forward." regexp)) (defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus" - "*All headers that match this regexp will be deleted when forwarding a message." + "*All headers that match this regexp will be deleted when forwarding a message. +This may also be a list of regexps." :version "21.1" :group 'message-forwarding :type '(repeat :value-to-internal (lambda (widget value) @@ -622,6 +623,19 @@ Done before generating the new subject of a forward." (widget-editable-list-match widget value))) regexp)) +(defcustom message-forward-included-headers nil + "If non-nil, delete non-matching headers when forwarding a message. +Only headers that match this regexp will be included. This +variable should be a regexp or a list of regexps." + :version "24.5" + :group 'message-forwarding + :type '(repeat :value-to-internal (lambda (widget value) + (custom-split-regexp-maybe value)) + :match (lambda (widget value) + (or (stringp value) + (widget-editable-list-match widget value))) + regexp)) + (defcustom message-ignored-cited-headers "." "*Delete these headers from the messages you yank." :group 'message-insertion @@ -970,6 +984,8 @@ the signature is inserted." (set-keymap-parent map minibuffer-local-map) map) "Keymap for `message-read-from-minibuffer'." + ;; FIXME improve type. + :type '(restricted-sexp :match-alternatives (symbolp keymapp)) :version "22.1" :group 'message-various) @@ -1139,9 +1155,10 @@ probably want to set this variable only for specific groups, e.g. using `gnus-posting-styles': (eval (set (make-local-variable 'message-cite-reply-position) 'above))" - :type '(choice (const :tag "Reply inline" 'traditional) - (const :tag "Reply above" 'above) - (const :tag "Reply below" 'below)) + :version "24.1" + :type '(choice (const :tag "Reply inline" traditional) + (const :tag "Reply above" above) + (const :tag "Reply below" below)) :group 'message-insertion) (defcustom message-cite-style nil @@ -1375,11 +1392,11 @@ If nil, you might be asked to input the charset." :type 'symbol) (defcustom message-dont-reply-to-names - (and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names) + (and (boundp 'mail-dont-reply-to-names) mail-dont-reply-to-names) "*Addresses to prune when doing wide replies. This can be a regexp or a list of regexps. Also, a value of nil means exclude your own user name only." - :version "21.1" + :version "24.3" :group 'message :link '(custom-manual "(message)Wide Reply") :type '(choice (const :tag "Yourself" nil) @@ -1784,7 +1801,7 @@ no, only reply back to the author." (file-error)) (mm-coding-system-p 'utf-8) (executable-find idna-program) - (string= (idna-to-ascii "räksmörgås") + (string= (idna-to-ascii "räksmörgÃ¥s") "xn--rksmrgs-5wao1o") t) "Whether to encode non-ASCII in domain names into ASCII according to IDNA. @@ -1976,10 +1993,13 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." (autoload 'nndraft-request-associate-buffer "nndraft") (autoload 'nndraft-request-expire-articles "nndraft") (autoload 'nnvirtual-find-group-art "nnvirtual") -(autoload 'rmail-dont-reply-to "mail-utils") (autoload 'rmail-msg-is-pruned "rmail") (autoload 'rmail-output "rmailout") +;; Emacs < 24.1 do not have mail-dont-reply-to +(unless (fboundp 'mail-dont-reply-to) + (defalias 'mail-dont-reply-to 'rmail-dont-reply-to)) + ;;; @@ -2487,6 +2507,7 @@ With prefix-argument just set Follow-Up, don't cross-post." "Remove HEADER in the narrowed buffer. If IS-REGEXP, HEADER is a regular expression. If FIRST, only remove the first instance of the header. +If REVERSE, remove headers that doesn't match HEADER. Return the number of headers removed." (goto-char (point-min)) (let ((regexp (if is-regexp header (concat "^" (regexp-quote header) ":"))) @@ -2646,7 +2667,7 @@ Point is left at the beginning of the narrowed-to region." (interactive) (let ((start (point))) (message-skip-to-next-address) - (kill-region start (point)))) + (kill-region start (if (bolp) (1- (point)) (point))))) (autoload 'Info-goto-node "info") @@ -2977,7 +2998,6 @@ C-c M-n `message-insert-disposition-notification-to' (request receipt). C-c M-m `message-mark-inserted-region' (mark region with enclosing tags). C-c M-f `message-mark-insert-file' (insert file marked with enclosing tags). M-RET `message-newline-and-reformat' (break the line and reformat)." - (setq local-abbrev-table text-mode-abbrev-table) (set (make-local-variable 'message-reply-buffer) nil) (set (make-local-variable 'message-inserted-headers) nil) (set (make-local-variable 'message-send-actions) nil) @@ -3100,94 +3120,100 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (defun message-goto-to () "Move point to the To header." (interactive) + (push-mark) (message-position-on-field "To")) (defun message-goto-from () "Move point to the From header." (interactive) + (push-mark) (message-position-on-field "From")) (defun message-goto-subject () "Move point to the Subject header." (interactive) + (push-mark) (message-position-on-field "Subject")) (defun message-goto-cc () "Move point to the Cc header." (interactive) + (push-mark) (message-position-on-field "Cc" "To")) (defun message-goto-bcc () "Move point to the Bcc header." (interactive) + (push-mark) (message-position-on-field "Bcc" "Cc" "To")) (defun message-goto-fcc () "Move point to the Fcc header." (interactive) + (push-mark) (message-position-on-field "Fcc" "To" "Newsgroups")) (defun message-goto-reply-to () "Move point to the Reply-To header." (interactive) + (push-mark) (message-position-on-field "Reply-To" "Subject")) (defun message-goto-newsgroups () "Move point to the Newsgroups header." (interactive) + (push-mark) (message-position-on-field "Newsgroups")) (defun message-goto-distribution () "Move point to the Distribution header." (interactive) + (push-mark) (message-position-on-field "Distribution")) (defun message-goto-followup-to () "Move point to the Followup-To header." (interactive) + (push-mark) (message-position-on-field "Followup-To" "Newsgroups")) (defun message-goto-mail-followup-to () "Move point to the Mail-Followup-To header." (interactive) + (push-mark) (message-position-on-field "Mail-Followup-To" "To")) (defun message-goto-keywords () "Move point to the Keywords header." (interactive) + (push-mark) (message-position-on-field "Keywords" "Subject")) (defun message-goto-summary () "Move point to the Summary header." (interactive) + (push-mark) (message-position-on-field "Summary" "Subject")) -(eval-when-compile - (defmacro message-called-interactively-p (kind) - (condition-case nil - (progn - (eval '(called-interactively-p 'any)) - ;; Emacs >=23.2 - `(called-interactively-p ,kind)) - ;; Emacs <23.2 - (wrong-number-of-arguments '(called-interactively-p)) - ;; XEmacs - (void-function '(interactive-p))))) - (defun message-goto-body () "Move point to the beginning of the message body." (interactive) - (when (and (message-called-interactively-p 'any) + (when (and (gmm-called-interactively-p 'any) (looking-at "[ \t]*\n")) (expand-abbrev)) + (push-mark) (goto-char (point-min)) (or (search-forward (concat "\n" mail-header-separator "\n") nil t) (search-forward-regexp "[^:]+:\\([^\n]\\|\n[ \t]\\)+\n\n" nil t))) (defun message-in-body-p () "Return t if point is in the message body." - (let ((body (save-excursion (message-goto-body)))) - (>= (point) body))) + (>= (point) + (save-excursion + (goto-char (point-min)) + (or (search-forward (concat "\n" mail-header-separator "\n") nil t) + (search-forward-regexp "[^:]+:\\([^\n]\\|\n[ \t]\\)+\n\n" nil t)) + (point)))) (defun message-goto-eoh () "Move point to the end of the headers." @@ -3200,6 +3226,7 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." If there is no signature in the article, go to the end and return nil." (interactive) + (push-mark) (goto-char (point-min)) (if (re-search-forward message-signature-separator nil t) (forward-line 1) @@ -3317,11 +3344,33 @@ or in the synonym headers, defined by `message-header-synonyms'." (defun message-insert-newsgroups () "Insert the Newsgroups header from the article being replied to." (interactive) - (when (and (message-position-on-field "Newsgroups") - (mail-fetch-field "newsgroups") - (not (string-match "\\` *\\'" (mail-fetch-field "newsgroups")))) - (insert ",")) - (insert (or (message-fetch-reply-field "newsgroups") ""))) + (let ((old-newsgroups (mail-fetch-field "newsgroups")) + (new-newsgroups (message-fetch-reply-field "newsgroups")) + (first t) + insert-newsgroups) + (message-position-on-field "Newsgroups") + (cond + ((not new-newsgroups) + (error "No Newsgroups to insert")) + ((not old-newsgroups) + (insert new-newsgroups)) + (t + (setq new-newsgroups (split-string new-newsgroups "[, ]+") + old-newsgroups (split-string old-newsgroups "[, ]+")) + (dolist (group new-newsgroups) + (unless (member group old-newsgroups) + (push group insert-newsgroups))) + (if (null insert-newsgroups) + (error "Newgroup%s already in the header" + (if (> (length new-newsgroups) 1) + "s" "")) + (when old-newsgroups + (setq first nil)) + (dolist (group insert-newsgroups) + (unless first + (insert ",")) + (setq first nil) + (insert group))))))) @@ -3823,7 +3872,9 @@ prefix, and don't delete any headers." (interactive "P") ;; eval the let forms contained in message-cite-style (eval - `(let ,message-cite-style + `(let ,(if (symbolp message-cite-style) + (symbol-value message-cite-style) + message-cite-style) (message--yank-original-internal ',arg)))) (defun message-yank-buffer (buffer) @@ -3839,7 +3890,7 @@ prefix, and don't delete any headers." (save-current-buffer (dolist (buffer (buffer-list t)) (set-buffer buffer) - (when (and (eq major-mode 'message-mode) + (when (and (derived-mode-p 'message-mode) (null message-sent-message-via)) (push (buffer-name buffer) buffers)))) (nreverse buffers))) @@ -3952,18 +4003,19 @@ See `message-citation-line-format'." (let ((i ?A) lst) (when (stringp name) ;; Guess first name and last name: - (cond ((string-match - "\\`\\(\\w\\|[-.]\\)+ \\(\\w\\|[-.]\\)+\\'" name) - (setq fname (nth 0 (split-string name "[ \t]+")) - lname (nth 1 (split-string name "[ \t]+")))) - ((string-match - "\\`\\(\\w\\|[-.]\\)+, \\(\\w\\|[-.]\\)+\\'" name) - (setq fname (nth 1 (split-string name "[ \t,]+")) - lname (nth 0 (split-string name "[ \t,]+")))) - ((string-match - "\\`\\(\\w\\|[-.]\\)+\\'" name) - (setq fname name - lname "")))) + (let* ((names (delq nil (mapcar (lambda (x) + (if (string-match "\\`\\(\\w\\|[-.]\\)+\\'" x) x nil)) + (split-string name "[ \t]+")))) + (count (length names))) + (cond ((= count 1) (setq fname (car names) + lname "")) + ((or (= count 2) (= count 3)) (setq fname (car names) + lname (mapconcat 'identity (cdr names) " "))) + ((> count 3) (setq fname (mapconcat 'identity (butlast names (- count 2)) " ") + lname (mapconcat 'identity (nthcdr 2 names) " "))) ) + (when (string-match "\\(.*\\),\\'" fname) + (let ((newlname (match-string 1 fname))) + (setq fname lname lname newlname))))) ;; The following letters are not used in `format-time-string': (push ?E lst) (push "" lst) (push ?F lst) (push fname lst) @@ -4039,28 +4091,6 @@ This function strips off the signature from the original message." (forward-char -1) nil)))) -(defun message-remove-signature () - "Remove the signature from the text between point and mark. -The text will also be indented the normal way." - (save-excursion - (let ((start (point)) - mark) - (if (not (re-search-forward message-signature-separator (mark t) t)) - ;; No signature here, so we just indent the cited text. - (message-indent-citation) - ;; Find the last non-empty line. - (forward-line -1) - (while (looking-at "[ \t]*$") - (forward-line -1)) - (forward-line 1) - (setq mark (set-marker (make-marker) (point))) - (goto-char start) - (message-indent-citation) - ;; Enable undoing the deletion. - (undo-boundary) - (delete-region mark (mark t)) - (set-marker mark nil))))) - ;;; @@ -4126,11 +4156,12 @@ Instead, just auto-save the buffer and then bury it." (defun message-bury (buffer) "Bury this mail BUFFER." + ;; Note that this is not quite the same as (bury-buffer buffer), + ;; since bury-buffer does extra stuff with a nil argument. + ;; Eg http://lists.gnu.org/archive/html/emacs-devel/2014-01/msg00539.html + (with-current-buffer buffer (bury-buffer)) (if message-return-action - (progn - (bury-buffer buffer) - (apply (car message-return-action) (cdr message-return-action))) - (with-current-buffer buffer (bury-buffer)))) + (apply (car message-return-action) (cdr message-return-action)))) (defun message-send (&optional arg) "Send the message in the current buffer. @@ -4522,8 +4553,9 @@ This function could be useful in `message-setup-hook'." (end-of-line) (insert (format " (%d/%d)" n total)) (widen) - (funcall (or message-send-mail-real-function - message-send-mail-function))) + (if message-send-mail-real-function + (funcall message-send-mail-real-function) + (message-multi-smtp-send-mail))) (setq n (+ n 1)) (setq p (pop plist)) (erase-buffer))) @@ -4677,8 +4709,9 @@ If you always want Gnus to send messages in one piece, set "))) (progn (message "Sending via mail...") - (funcall (or message-send-mail-real-function - message-send-mail-function))) + (if message-send-mail-real-function + (funcall message-send-mail-real-function) + (message-multi-smtp-send-mail))) (message-send-mail-partially)) (setq options message-options)) (kill-buffer tembuf)) @@ -4687,6 +4720,28 @@ If you always want Gnus to send messages in one piece, set (push 'mail message-sent-message-via))) (defvar sendmail-program) +(defvar smtpmail-smtp-user) + +(defun message-multi-smtp-send-mail () + "Send the current buffer to `message-send-mail-function'. +Or, if there's a header that specifies a different method, use +that instead." + (let ((method (message-field-value "X-Message-SMTP-Method"))) + (if (not method) + (funcall message-send-mail-function) + (message-remove-header "X-Message-SMTP-Method") + (setq method (split-string method)) + (cond + ((equal (car method) "sendmail") + (message-send-mail-with-sendmail)) + ((equal (car method) "smtp") + (require 'smtpmail) + (let ((smtpmail-smtp-server (nth 1 method)) + (smtpmail-smtp-service (nth 2 method)) + (smtpmail-smtp-user (or (nth 3 method) smtpmail-smtp-user))) + (message-smtpmail-send-it))) + (t + (error "Unknown method %s" method)))))) (defun message-send-mail-with-sendmail () "Send off the prepared buffer with sendmail." @@ -4744,7 +4799,9 @@ If you always want Gnus to send messages in one piece, set (list resend-to-addresses) '("-t")))))) (unless (or (null cpr) (and (numberp cpr) (zerop cpr))) - (if errbuf (pop-to-buffer errbuf)) + (when errbuf + (pop-to-buffer errbuf) + (setq errbuf nil)) (error "Sending...failed with exit value %d" cpr))) (when message-interactive (with-current-buffer errbuf @@ -4843,9 +4900,7 @@ Do not use this for anything important, it is cryptographically weak." (require 'sha1) (let (sha1-maximum-internal-length) (sha1 (concat (message-unique-id) - (format "%x%x%x" (random) - (progn (random t) (random)) - (random)) + (format "%x%x%x" (random) (random) (random)) (prin1-to-string (recent-keys)) (prin1-to-string (garbage-collect)))))) @@ -5548,7 +5603,6 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." ;; You might for example insert a "." somewhere (not next to another dot ;; or string boundary), or modify the "fsf" string. (defun message-unique-id () - (random t) ;; Don't use microseconds from (current-time), they may be unsupported. ;; Instead we use this randomly inited counter. (setq message-unique-id-char @@ -5809,12 +5863,6 @@ give as trustworthy answer as possible." (concat system-name ".i-did-not-set--mail-host-address--so-tickle-me"))))) -(defun message-make-host-name () - "Return the name of the host." - (let ((fqdn (message-make-fqdn))) - (string-match "^[^.]+\\." fqdn) - (substring fqdn 0 (1- (match-end 0))))) - (defun message-make-domain () "Return the domain name." (or mail-host-address @@ -6131,20 +6179,13 @@ Headers already prepared in the buffer are not modified." (while (and (not (= (point) end)) (or (not (eq char ?,)) quoted)) - (skip-chars-forward "^,\"" (point-max)) + (skip-chars-forward "^,\"" end) (when (eq (setq char (following-char)) ?\") (setq quoted (not quoted))) (unless (= (point) end) (forward-char 1))) (skip-chars-forward " \t\n"))) -(defun message-fill-address (header value) - (insert (capitalize (symbol-name header)) - ": " - (if (consp value) (car value) value) - "\n") - (message-fill-field-address)) - (defun message-split-line () "Split current line, moving portion beyond point vertically down. If the current line has `message-yank-prefix', insert it on the new line." @@ -6175,17 +6216,22 @@ If the current line has `message-yank-prefix', insert it on the new line." (point-max)))) (defun message-fill-field-address () - (while (not (eobp)) - (message-skip-to-next-address) - (let (last) - (if (and (> (current-column) 78) - last) - (progn - (save-excursion - (goto-char last) - (insert "\n\t")) - (setq last (1+ (point)))) - (setq last (1+ (point))))))) + (let (end last) + (while (not end) + (message-skip-to-next-address) + (cond ((bolp) + (end-of-line 0) + (setq end 1)) + ((eobp) + (setq end 0))) + (when (and (> (current-column) 78) + last) + (save-excursion + (goto-char last) + (delete-char (- (skip-chars-backward " \t"))) + (insert "\n\t"))) + (setq last (point))) + (forward-line end))) (defun message-fill-field-general () (let ((begin (point)) @@ -6287,6 +6333,9 @@ they are." :link '(custom-manual "(message)Movement") :type 'boolean) +(defvar visual-line-mode) +(declare-function beginning-of-visual-line "simple" (&optional n)) + (defun message-beginning-of-line (&optional n) "Move point to beginning of header value or to beginning of line. The prefix argument N is passed directly to `beginning-of-line'. @@ -6313,7 +6362,9 @@ between beginning of field and beginning of line." (goto-char (if (and eoh (or (< eoh here) (= bol here))) eoh bol))) - (beginning-of-line n))) + (if (and (boundp 'visual-line-mode) visual-line-mode) + (beginning-of-visual-line n) + (beginning-of-line n)))) (defun message-buffer-name (type &optional to group) "Return a new (unique) buffer name based on TYPE and TO." @@ -6736,11 +6787,16 @@ The function is called with one parameter, a cons cell ..." ", ")) mct (message-fetch-field "mail-copies-to") author (or (message-fetch-field "mail-reply-to") - (message-fetch-field "reply-to") - (message-fetch-field "from") - "") + (message-fetch-field "reply-to")) mft (and message-use-mail-followup-to - (message-fetch-field "mail-followup-to")))) + (message-fetch-field "mail-followup-to"))) + ;; Make sure this message goes to the author if this is a wide + ;; reply, since Reply-To address may be a list address a mailing + ;; list server added. + (when (and wide author) + (setq cc (concat author ", " cc))) + (when (or wide (not author)) + (setq author (or (message-fetch-field "from") "")))) ;; Handle special values of Mail-Copies-To. (when mct @@ -6806,9 +6862,9 @@ want to get rid of this query permanently."))) ;; Squeeze whitespace. (while (string-match "[ \t][ \t]+" recipients) (setq recipients (replace-match " " t t recipients))) - ;; Remove addresses that match `rmail-dont-reply-to-names'. - (let ((rmail-dont-reply-to-names (message-dont-reply-to-names))) - (setq recipients (rmail-dont-reply-to recipients))) + ;; Remove addresses that match `mail-dont-reply-to-names'. + (let ((mail-dont-reply-to-names (message-dont-reply-to-names))) + (setq recipients (mail-dont-reply-to recipients))) ;; Perhaps "Mail-Copies-To: never" removed the only address? (if (string-equal recipients "") (setq recipients author)) @@ -7156,7 +7212,7 @@ If ARG, allow editing of the cancellation message." (erase-buffer) (insert "Newsgroups: " newsgroups "\n" "From: " from "\n" - "Subject: cmsg cancel " message-id "\n" + "Subject: cancel " message-id "\n" "Control: cancel " message-id "\n" (if distribution (concat "Distribution: " distribution "\n") @@ -7216,7 +7272,7 @@ header line with the old Message-ID." (let ((buffer-read-only nil)) (erase-buffer) (insert-file-contents file-name nil))) - (t (error "message-recover cancelled"))))) + (t (error "message-recover canceled"))))) ;;; Washing Subject: @@ -7375,24 +7431,33 @@ Optional DIGEST will use digest to forward." (message-remove-ignored-headers b e))) (defun message-remove-ignored-headers (b e) - (when message-forward-ignored-headers + (when (or message-forward-ignored-headers + message-forward-included-headers) (save-restriction (narrow-to-region b e) (goto-char b) (narrow-to-region (point) (or (search-forward "\n\n" nil t) (point))) - (let ((ignored (if (stringp message-forward-ignored-headers) - (list message-forward-ignored-headers) - message-forward-ignored-headers))) - (dolist (elem ignored) - (message-remove-header elem t)))))) - -(defun message-forward-make-body-mime (forward-buffer) + (when message-forward-ignored-headers + (let ((ignored (if (stringp message-forward-ignored-headers) + (list message-forward-ignored-headers) + message-forward-ignored-headers))) + (dolist (elem ignored) + (message-remove-header elem t)))) + (when message-forward-included-headers + (message-remove-header + (if (listp message-forward-included-headers) + (regexp-opt message-forward-included-headers) + message-forward-included-headers) + t nil t))))) + +(defun message-forward-make-body-mime (forward-buffer &optional beg end) (let ((b (point))) (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n") (save-restriction (narrow-to-region (point) (point)) - (mml-insert-buffer forward-buffer) + (insert-buffer-substring forward-buffer beg end) + (mml-quote-region (point-min) (point-max)) (goto-char (point-min)) (when (looking-at "From ") (replace-match "X-From-Line: ")) @@ -7432,8 +7497,7 @@ Optional DIGEST will use digest to forward." (goto-char (point-max)))) (setq e (point)) (insert "<#/mml>\n") - (when (and (not message-forward-decoded-p) - message-forward-ignored-headers) + (when (not message-forward-decoded-p) (message-remove-ignored-headers b e)))) (defun message-forward-make-body-digest-plain (forward-buffer) @@ -7573,7 +7637,7 @@ is for the internal use." (message "Resending message to %s..." address) (save-excursion (let ((cur (current-buffer)) - beg) + gcc beg) ;; We first set up a normal mail buffer. (unless (message-mail-user-agent) (set-buffer (get-buffer-create " *message resend*")) @@ -7586,6 +7650,8 @@ is for the internal use." ;; Insert our usual headers. (message-generate-headers '(From Date To Message-ID)) (message-narrow-to-headers) + (when (setq gcc (mail-fetch-field "gcc" nil t)) + (message-remove-header "gcc")) ;; Remove X-Draft-From header etc. (message-remove-header message-ignored-mail-headers t) ;; Rename them all to "Resent-*". @@ -7627,6 +7693,10 @@ is for the internal use." message-generate-hashcash rfc2047-encode-encoded-words) (message-send-mail)) + (when gcc + (message-goto-eoh) + (insert "Gcc: " gcc "\n")) + (run-hooks 'message-sent-hook) (kill-buffer (current-buffer))) (message "Resending message to %s...done" address))) @@ -7922,8 +7992,9 @@ If nil, the function bound in `text-mode-map' or `global-map' is executed." (defun message-tab () "Complete names according to `message-completion-alist'. -Execute function specified by `message-tab-body-function' when not in -those headers." +Execute function specified by `message-tab-body-function' when +not in those headers. If that variable is nil, indent with the +regular text mode tabbing command." (interactive) (cond ((if (and (boundp 'completion-fail-discreetly) @@ -7951,37 +8022,36 @@ those headers." ;; falling back to message-tab-body-function. (lambda () (funcall fun) 'completion-attempted))))) -(eval-and-compile - (condition-case nil - (with-temp-buffer - (let ((standard-output (current-buffer))) - (eval '(display-completion-list nil ""))) - (defalias 'message-display-completion-list 'display-completion-list)) - (error ;; Don't use `wrong-number-of-arguments' here because of XEmacs. - (defun message-display-completion-list (completions &optional ignore) - "Display the list of completions, COMPLETIONS, using `standard-output'." - (display-completion-list completions))))) - (defun message-expand-group () "Expand the group name under point." - (let* ((b (save-excursion - (save-restriction - (narrow-to-region - (save-excursion - (beginning-of-line) - (skip-chars-forward "^:") - (1+ (point))) - (point)) - (skip-chars-backward "^, \t\n") (point)))) - (completion-ignore-case t) - (e (progn (skip-chars-forward "^,\t\n ") (point))) - (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb))) - (message-completion-in-region e b hashtb))) + (let ((b (save-excursion + (save-restriction + (narrow-to-region + (save-excursion + (beginning-of-line) + (skip-chars-forward "^:") + (1+ (point))) + (point)) + (skip-chars-backward "^, \t\n") (point)))) + (completion-ignore-case t) + (e (progn (skip-chars-forward "^,\t\n ") (point))) + group collection) + (when (and (boundp 'gnus-active-hashtb) + gnus-active-hashtb) + (mapatoms + (lambda (symbol) + (setq group (symbol-name symbol)) + (push (if (string-match "[^\000-\177]" group) + (gnus-group-decoded-name group) + group) + collection)) + gnus-active-hashtb)) + (message-completion-in-region b e collection))) (defalias 'message-completion-in-region (if (fboundp 'completion-in-region) 'completion-in-region - (lambda (e b hashtb) + (lambda (b e hashtb) (let* ((string (buffer-substring b e)) (completions (all-completions string hashtb)) comp) @@ -8006,8 +8076,7 @@ those headers." (let ((buffer-read-only nil)) (erase-buffer) (let ((standard-output (current-buffer))) - (message-display-completion-list (sort completions 'string<) - string)) + (display-completion-list (sort completions 'string<))) (setq buffer-read-only nil) (goto-char (point-min)) (delete-region (point) @@ -8136,7 +8205,7 @@ regexp VARSTR." (if (fboundp 'mail-abbrevs-setup) (let ((minibuffer-setup-hook 'mail-abbrevs-setup) (minibuffer-local-map message-minibuffer-local-map)) - (flet ((mail-abbrev-in-expansion-header-p nil t)) + (gmm-flet ((mail-abbrev-in-expansion-header-p nil t)) (read-from-minibuffer prompt initial-contents))) (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook) (minibuffer-local-map message-minibuffer-local-map)) @@ -8417,6 +8486,17 @@ Used in `message-simplify-recipients'." (message-fetch-field hdr) t)) ", ")))) +;;; multipart/related and HTML support. + +(defun message-make-html-message-with-image-files (files) + (interactive (list (dired-get-marked-files nil current-prefix-arg))) + (message-mail) + (message-goto-body) + (insert "<#part type=text/html>\n\n") + (dolist (file files) + (insert (format "\n\n" file))) + (message-goto-to)) + (when (featurep 'xemacs) (require 'messagexmas) (message-xmas-redefine)) @@ -8426,7 +8506,7 @@ Used in `message-simplify-recipients'." (run-hooks 'message-load-hook) ;; Local Variables: -;; coding: iso-8859-1 +;; coding: utf-8 ;; End: ;;; message.el ends here