X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=1dc96a284c770cb8f35df043be4ca59ba1dc48b7;hb=162880cc7957dd33ca0c09573dc8ff526f3c8d69;hp=8e9882d4f1f7b0e35f388c77cb11abeb3d88fb8c;hpb=88a2cbade926ab994768b63e407390a44762941c;p=elisp%2Fgnus.git- diff --git a/lisp/message.el b/lisp/message.el index 8e9882d..1dc96a2 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -144,7 +144,8 @@ If this variable is nil, no such courtesy message will be added." :group 'message-sending :type 'string) -(defcustom message-ignored-bounced-headers "^\\(Received\\|Return-Path\\):" +(defcustom message-ignored-bounced-headers + "^\\(Received\\|Return-Path\\|Delivered-To\\):" "*Regexp that matches headers to be removed in resent bounced mail." :group 'message-interface :type 'regexp) @@ -193,7 +194,8 @@ Checks include `subject-cmsg', `multiple-headers', `sendsys', :group 'message-news :type '(repeat sexp)) ; Fixme: improve this -(defcustom message-required-headers '((optional . References) From) +(defcustom message-required-headers '((optional . References) + From) "*Headers to be generated or prompted for when sending a message. Also see `message-required-news-headers' and `message-required-mail-headers'." @@ -302,6 +304,8 @@ few false positives here." :group 'message-various :type 'regexp) +;; Fixme: Why are all these things autoloaded? + ;;; marking inserted text ;;;###autoload @@ -432,7 +436,7 @@ If t, use `message-user-organization-file'." :group 'message-headers) (defcustom message-make-forward-subject-function - 'message-forward-subject-author-subject + 'message-forward-subject-name-subject "*List of functions called to generate subject headers for forwarded messages. The subject generated by the previous function is passed into each successive function. @@ -441,6 +445,8 @@ The provided functions are: * `message-forward-subject-author-subject' (Source of article (author or newsgroup)), in brackets followed by the subject +* `message-forward-subject-name-subject' (Source of article (name of author + or newsgroup)), in brackets followed by the subject * `message-forward-subject-fwd' (Subject of article with 'Fwd:' prepended to it." :group 'message-forwarding @@ -636,6 +642,15 @@ Doing so would be even more evil than leaving it out." :group 'message-sending :type 'boolean) +(defcustom message-sendmail-envelope-from nil + "*Envelope-from when sending mail with sendmail. +If this is nil, use `user-mail-address'. If it is the symbol +`header', use the From: header of the message." + :type '(choice (string :tag "From name") + (const :tag "Use From: header from message" header) + (const :tag "Use `user-mail-address'" nil)) + :group 'message-sending) + ;; qmail-related stuff (defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject" "Location of the qmail-inject program." @@ -679,7 +694,11 @@ variable isn't used." ;; create a dependence to `gnus.el'. :type 'sexp) -(defcustom message-generate-headers-first nil +;; FIXME: This should be a temporary workaround until someone implements a +;; proper solution. If a crash happens while replying, the auto-save file +;; will *not* have a `References:' header if `message-generate-headers-first' +;; is nil. See: http://article.gmane.org/gmane.emacs.gnus.general/51138 +(defcustom message-generate-headers-first '(references) "*If non-nil, generate all required headers before composing. The variables `message-required-news-headers' and `message-required-mail-headers' specify which headers to generate. @@ -691,6 +710,7 @@ are to be deleted and then re-generated before sending, so this variable will not have a visible effect for those headers." :group 'message-headers :type '(choice (const :tag "None" nil) + (const :tag "References" '(references)) (const :tag "All" t) (repeat (sexp :tag "Header")))) @@ -973,6 +993,13 @@ candidates: (or (not (listp message-shoot-gnksa-feet)) (memq feature message-shoot-gnksa-feet))) +(defcustom message-hidden-headers nil + "Regexp of headers to be hidden when composing new messages. +This can also be a list of regexps to match headers. Or a list +starting with `not' and followed by regexps.." + :group 'message + :type '(repeat regexp)) + ;;; Internal variables. ;;; Well, not really internal. @@ -1273,6 +1300,22 @@ no, only reply back to the author." :group 'message-headers :type 'boolean) +(defcustom message-user-fqdn nil + "*Domain part of Messsage-Ids." + :group 'message-headers + :link '(custom-manual "(message)News Headers") + :type 'string) + +(defcustom message-use-idna (and (condition-case nil (require 'idna) + (file-error)) + (mm-coding-system-p 'utf-8) + 'ask) + "Whether to encode non-ASCII in domain names into ASCII according to IDNA." + :group 'message-headers + :type '(choice (const :tag "Ask" ask) + (const :tag "Never" nil) + (const :tag "Always" t))) + ;;; Internal variables. (defvar message-sending-message "Sending...") @@ -1319,7 +1362,7 @@ no, only reply back to the author." ;; We want to match the results of any of these manglings. ;; The following regexp rejects names whose first characters are ;; obviously bogus, but after that anything goes. - "\\([^\0-\b\n-\r\^?].*\\)? " + "\\([^\0-\b\n-\r\^?].*\\)?" ;; The time the message was sent. "\\([^\0-\r \^?]+\\) +" ; day of the week @@ -1381,6 +1424,19 @@ no, only reply back to the author." (defvar message-bogus-system-names "^localhost\\." "The regexp of bogus system names.") +(defcustom message-valid-fqdn-regexp + (concat "[a-z0-9][-.a-z0-9]+\\." ;; [hostname.subdomain.]domain. + ;; valid TLDs: + "\\([a-z][a-z]" ;; two letter country TDLs + "\\|biz\\|com\\|edu\\|gov\\|int\\|mil\\|net\\|org" + "\\|aero\\|coop\\|info\\|name\\|museum" + "\\|arpa\\|pro\\|uucp\\|bitnet\\|bofh" ;; old style? + "\\)") + "Regular expression that matches a valid FQDN." + ;; see also: gnus-button-valid-fqdn-regexp + :group 'message-headers + :type 'regexp) + (eval-and-compile (autoload 'message-setup-toolbar "messagexmas") (autoload 'mh-new-draft-name "mh-comp") @@ -1399,7 +1455,8 @@ no, only reply back to the author." (autoload 'gnus-group-name-decode "gnus-group") (autoload 'gnus-groups-from-server "gnus") (autoload 'rmail-output "rmailout") - (autoload 'gnus-delay-article "gnus-delay")) + (autoload 'gnus-delay-article "gnus-delay") + (autoload 'gnus-make-local-hook "gnus-util")) @@ -1439,8 +1496,8 @@ is used by default." (beg 1) (first t) quoted elems paren) - (save-excursion - (message-set-work-buffer) + (with-temp-buffer + (mm-enable-multibyte) (insert header) (goto-char (point-min)) (while (not (eobp)) @@ -1533,15 +1590,6 @@ is used by default." (mail-narrow-to-head) (message-fetch-field header)))) -(defun message-set-work-buffer () - (if (get-buffer " *message work*") - (progn - (set-buffer " *message work*") - (erase-buffer)) - (set-buffer (get-buffer-create " *message work*")) - (kill-all-local-variables) - (mm-enable-multibyte))) - (defun message-functionp (form) "Return non-nil if FORM is funcallable." (or (and (symbolp form) (fboundp form)) @@ -1711,7 +1759,7 @@ With prefix-argument just set Follow-Up, don't cross-post." (not (string-match (regexp-quote target-group) (message-fetch-field "Newsgroups")))) (end-of-line) - (insert-string (concat "," target-group)))) + (insert (concat "," target-group)))) (end-of-line) ; ensure Followup: comes after Newsgroups: ;; unless new followup would be identical to Newsgroups line ;; make a new Followup-To line @@ -2052,6 +2100,7 @@ Point is left at the beginning of the narrowed-to 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 "\M-q" 'message-fill-paragraph) + (define-key message-mode-map [remap split-line] 'message-split-line) (define-key message-mode-map "\C-c\C-a" 'mml-attach-file) @@ -2144,6 +2193,7 @@ Point is left at the beginning of the narrowed-to region." ["Reduce To: to Cc:" message-reduce-to-to-cc t] "----" ["Sort Headers" message-sort-headers t] + ["Encode non-ASCII domain names" message-idna-to-ascii-rhs t] ["Goto Body" message-goto-body t] ["Goto Signature" message-goto-signature t])) @@ -2175,7 +2225,7 @@ message composition doesn't break too bad." ;; No reason this should be clutter up customize. We make it a ;; property list (rather than a list of property symbols), to be ;; directly useful for `remove-text-properties'. - '(field nil read-only nil intangible nil invisible nil + '(field nil read-only nil invisible nil intangible nil mouse-face nil modification-hooks nil insert-in-front-hooks nil insert-behind-hooks nil point-entered nil point-left nil) ;; Other special properties: @@ -2206,7 +2256,11 @@ This function is intended to be called from `after-change-functions'. See also `message-forbidden-properties'." (when (and message-strip-special-text-properties (message-tamago-not-in-use-p begin)) - (remove-text-properties begin end message-forbidden-properties))) + (while (not (= begin end)) + (when (not (get-text-property begin 'message-hidden)) + (remove-text-properties begin (1+ begin) + message-forbidden-properties)) + (incf begin)))) ;;;###autoload (define-derived-mode message-mode text-mode "Message" @@ -2270,6 +2324,11 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (set (make-local-variable 'message-checksum) nil) (set (make-local-variable 'message-mime-part) 0) (message-setup-fill-variables) + (set + (make-local-variable 'paragraph-separate) + (format "\\(%s\\)\\|\\(%s\\)" + paragraph-separate + "<#!*/?\\(multipart\\|part\\|external\\|mml\\|secure\\)")) ;; Allow using comment commands to add/remove quoting. (set (make-local-variable 'comment-start) message-yank-prefix) (if (featurep 'xemacs) @@ -2280,9 +2339,7 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (set (make-local-variable 'tool-bar-map) (message-tool-bar-map)))) (easy-menu-add message-mode-menu message-mode-map) (easy-menu-add message-mode-field-menu message-mode-map) - ;; make-local-hook is harmless though obsolete in Emacs 21. - ;; Emacs 20 and XEmacs need make-local-hook. - (make-local-hook 'after-change-functions) + (gnus-make-local-hook 'after-change-functions) ;; Mmmm... Forbidden properties... (add-hook 'after-change-functions 'message-strip-forbidden-properties nil 'local) @@ -2562,7 +2619,7 @@ With the prefix argument FORCE, insert the header anyway." (let ((point (point))) (message-goto-signature) (unless (eobp) - (forward-line -2)) + (end-of-line -1)) (kill-region point (point)) (unless (bolp) (insert "\n")))) @@ -2645,6 +2702,7 @@ Prefix arg means justify as well." (delete-region (point) (re-search-forward "[ \t]*")) (when (and quoted (not bolp)) (insert quoted leading-space))) + (undo-boundary) (if quoted (let* ((adaptive-fill-regexp (regexp-quote (concat quoted leading-space))) @@ -2657,7 +2715,7 @@ Prefix arg means justify as well." (defun message-fill-paragraph (&optional arg) "Like `fill-paragraph'." (interactive (list (if current-prefix-arg 'full))) - (if (and (boundp 'filladapt-mode) filladapt-mode) + (if (if (boundp 'filladapt-mode) filladapt-mode) nil (message-newline-and-reformat arg t) t)) @@ -3226,14 +3284,22 @@ It should typically alter the sending method in some way or other." (goto-char (point-max)) (unless (bolp) (insert "\n")) - ;; Delete all invisible text. + ;; Make the hidden headers visible. + (let ((points (message-text-with-property 'message-hidden))) + (when points + (goto-char (car points)) + (dolist (point points) + (add-text-properties point (1+ point) + '(invisible nil intangible nil))))) + ;; Make invisible text visible. (message-check 'invisible-text (let ((points (message-text-with-property 'invisible))) (when points (goto-char (car points)) (dolist (point points) (add-text-properties point (1+ point) - '(invisible nil highlight t))) + '(invisible nil face highlight + font-lock-face highlight))) (unless (yes-or-no-p "Invisible text found and made visible; continue posting? ") (error "Invisible text found and made visible"))))) @@ -3248,14 +3314,15 @@ It should typically alter the sending method in some way or other." (memq (char-charset char) '(eight-bit-control eight-bit-graphic control-1))))) - (add-text-properties (point) (1+ (point)) '(highlight t)) + (add-text-properties (point) (1+ (point)) + '(font-lock-face highlight face highlight)) (setq found t)) (forward-char) (skip-chars-forward mm-7bit-chars)) (when found (setq choice (gnus-multiple-choice - "Illegible text found. Continue posting? " + "Illegible text found. Continue posting?" '((?d "Remove and continue posting") (?r "Replace with dots and continue posting") (?i "Ignore and continue posting") @@ -3272,10 +3339,11 @@ It should typically alter the sending method in some way or other." '(eight-bit-control eight-bit-graphic control-1))))) (if (eq choice ?i) - (remove-text-properties (point) (1+ (point)) '(highlight t)) + (remove-text-properties (point) (1+ (point)) + '(font-lock-face highlight face highlight)) (delete-char 1) - (if (eq choice ?r) - (insert ".")))) + (when (eq choice ?r) + (insert ".")))) (forward-char) (skip-chars-forward mm-7bit-chars)))))) @@ -3355,7 +3423,7 @@ It should typically alter the sending method in some way or other." (message-remove-header "Lines") (goto-char (point-max)) (insert "Mime-Version: 1.0\n") - (setq header (buffer-substring (point-min) (point-max)))) + (setq header (buffer-string))) (goto-char (point-max)) (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n\n" id n total)) @@ -3436,6 +3504,7 @@ It should typically alter the sending method in some way or other." (message-narrow-to-headers) (and news (or (message-fetch-field "cc") + (message-fetch-field "bcc") (message-fetch-field "to")) (let ((content-type (message-fetch-field "content-type"))) (or @@ -3467,7 +3536,7 @@ sent in one piece. The size limit is controlled by `message-send-mail-partially-limit'. If you always want Gnus to send messages in one piece, set -`message-send-mail-partially-limit' to `nil'. +`message-send-mail-partially-limit' to nil. "))) (mm-with-unibyte-current-buffer (message "Sending via mail...") @@ -3523,7 +3592,7 @@ If you always want Gnus to send messages in one piece, set ;; But some systems are more broken with -f, so ;; we'll let users override this. (if (null message-sendmail-f-is-evil) - (list "-f" (message-make-address))) + (list "-f" (message-sendmail-envelope-from))) ;; These mean "report errors by mail" ;; and "deliver in background". (if (null message-interactive) '("-oem" "-odb")) @@ -3545,7 +3614,7 @@ If you always want Gnus to send messages in one piece, set (replace-match "; ")) (if (not (zerop (buffer-size))) (error "Sending...failed to %s" - (buffer-substring (point-min) (point-max))))))) + (buffer-string)))))) (when (bufferp errbuf) (kill-buffer errbuf))))) @@ -3852,7 +3921,7 @@ Otherwise, generate and save a value for `canlock-password' first." (length (setq to (completing-read "Followups to (default: no Followup-To header) " - (mapcar (lambda (g) (list g)) + (mapcar #'list (cons "poster" (message-tokenize-header newsgroups))))))))) @@ -3862,7 +3931,7 @@ Otherwise, generate and save a value for `canlock-password' first." ;; Check "Shoot me". (message-check 'shoot (if (re-search-forward - "Message-ID.*.i-did-not-set--mail-host-address--so-shoot-me" nil t) + "Message-ID.*.i-did-not-set--mail-host-address--so-tickle-me" nil t) (y-or-n-p "You appear to have a misconfigured system. Really post? ") t)) ;; Check for Approved. @@ -3915,8 +3984,9 @@ Otherwise, generate and save a value for `canlock-password' first." (gnus-groups-from-server method))) errors) (while groups - (unless (or (equal (car groups) "poster") - (member (car groups) known-groups)) + (when (and (not (equal (car groups) "poster")) + (not (member (car groups) known-groups)) + (not (member (car groups) errors))) (push (car groups) errors)) (pop groups)) (cond @@ -3931,7 +4001,7 @@ Otherwise, generate and save a value for `canlock-password' first." errors) (y-or-n-p (format - "Really post to %s possibly unknown group%s: %s? " + "Really use %s possibly unknown group%s: %s? " (if (= (length errors) 1) "this" "these") (if (= (length errors) 1) "" "s") (mapconcat 'identity errors ", ")))) @@ -4313,9 +4383,9 @@ If NOW, use that time instead." (lsh (% message-unique-id-char 25) 16)) 4) (message-number-base36 (+ (nth 1 tm) (lsh (/ message-unique-id-char 25) 16)) 4) - ;; Append the newsreader name, because while the generated - ;; ID is unique to this newsreader, other newsreaders might - ;; otherwise generate the same ID via another algorithm. + ;; Append a given name, because while the generated ID is unique + ;; to this newsreader, other newsreaders might otherwise generate + ;; the same ID via another algorithm. ".fsf"))) (defun message-number-base36 (num len) @@ -4334,8 +4404,8 @@ If NOW, use that time instead." (if (message-functionp message-user-organization) (funcall message-user-organization) message-user-organization)))) - (save-excursion - (message-set-work-buffer) + (with-temp-buffer + (mm-enable-multibyte) (cond ((stringp organization) (insert organization)) ((and (eq t organization) @@ -4374,12 +4444,10 @@ If NOW, use that time instead." (date (mail-header-date message-reply-headers)) (msg-id (mail-header-message-id message-reply-headers))) (when from - (let ((stop-pos - (string-match " *at \\| *@ \\| *(\\| *<" from))) + (let ((name (mail-extract-address-components from))) (concat msg-id (if msg-id " (") - (if (and stop-pos - (not (zerop stop-pos))) - (substring from 0 stop-pos) from) + (or (car name) + (nth 1 name)) "'s message of \"" (if (or (not date) (string= date "")) "(unknown date)" date) @@ -4421,8 +4489,8 @@ If NOW, use that time instead." (user-full-name)))) (when (string= fullname "&") (setq fullname (user-login-name))) - (save-excursion - (message-set-work-buffer) + (with-temp-buffer + (mm-enable-multibyte) (cond ((or (null style) (equal fullname "")) @@ -4473,30 +4541,53 @@ give as trustworthy answer as possible." (defun message-user-mail-address () "Return the pertinent part of `user-mail-address'." - (when user-mail-address + (when (and user-mail-address + (string-match "@.*\\." user-mail-address)) (if (string-match " " user-mail-address) (nth 1 (mail-extract-address-components user-mail-address)) user-mail-address))) +(defun message-sendmail-envelope-from () + "Return the envelope from." + (cond ((eq message-sendmail-envelope-from 'header) + (nth 1 (mail-extract-address-components + (message-fetch-field "from")))) + ((stringp message-sendmail-envelope-from) + message-sendmail-envelope-from) + (t + (message-make-address)))) + (defun message-make-fqdn () "Return user's fully qualified domain name." - (let ((system-name (system-name)) - (user-mail (message-user-mail-address))) + (let* ((system-name (system-name)) + (user-mail (message-user-mail-address)) + (user-domain + (if (and user-mail + (string-match "@\\(.*\\)\\'" user-mail)) + (match-string 1 user-mail)))) (cond - ((and (string-match "[^.]\\.[^.]" system-name) + ((and message-user-fqdn + (stringp message-user-fqdn) + (string-match message-valid-fqdn-regexp message-user-fqdn) + (not (string-match message-bogus-system-names message-user-fqdn))) + message-user-fqdn) + ;; `message-user-fqdn' seems to be valid + ((and (string-match message-valid-fqdn-regexp system-name) (not (string-match message-bogus-system-names system-name))) ;; `system-name' returned the right result. system-name) ;; Try `mail-host-address'. ((and (boundp 'mail-host-address) (stringp mail-host-address) - (string-match "\\." mail-host-address)) + (string-match message-valid-fqdn-regexp mail-host-address) + (not (string-match message-bogus-system-names mail-host-address))) mail-host-address) ;; We try `user-mail-address' as a backup. - ((and user-mail - (string-match "\\." user-mail) - (string-match "@\\(.*\\)\\'" user-mail)) - (match-string 1 user-mail)) + ((and user-domain + (stringp user-domain) + (string-match message-valid-fqdn-regexp user-domain) + (not (string-match message-bogus-system-names user-domain))) + user-domain) ;; Default to this bogus thing. (t (concat system-name ".i-did-not-set--mail-host-address--so-tickle-me"))))) @@ -4568,6 +4659,70 @@ subscribed address (and not the additional To and Cc header contents)." list msg-recipients)))))) +(defun message-idna-inside-rhs-p () + "Return t iff point is inside a RHS (heuristically). +Only works properly if header contains mailbox-list or address-list. +I.e., calling it on a Subject: header is useless." + (save-restriction + (narrow-to-region (save-excursion (or (re-search-backward "^[^ \t]" nil t) + (point-min))) + (save-excursion (or (re-search-forward "^[^ \t]" nil t) + (point-max)))) + (if (re-search-backward "[\\\n\r\t ]" + (save-excursion (search-backward "@" nil t)) t) + ;; whitespace between @ and point + nil + (let ((dquote 1) (paren 1)) + (while (save-excursion (re-search-backward "[^\\]\"" nil t dquote)) + (incf dquote)) + (while (save-excursion (re-search-backward "[^\\]\(" nil t paren)) + (incf paren)) + (and (= (% dquote 2) 1) (= (% paren 2) 1)))))) + +(autoload 'idna-to-ascii "idna") + +(defun message-idna-to-ascii-rhs-1 (header) + "Interactively potentially IDNA encode domain names in HEADER." + (let (rhs ace start startpos endpos ovl) + (goto-char (point-min)) + (while (re-search-forward (concat "^" header) nil t) + (while (re-search-forward "@\\([^ \t\r\n>]+\\)" + (or (save-excursion + (re-search-forward "^[^ \t]" nil t)) + (point-max)) + t) + (setq rhs (match-string-no-properties 1) + startpos (match-beginning 1) + endpos (match-end 1)) + (when (save-match-data + (and (message-idna-inside-rhs-p) + (setq ace (idna-to-ascii rhs)) + (not (string= rhs ace)) + (if (eq message-use-idna 'ask) + (unwind-protect + (progn + (setq ovl (message-make-overlay startpos + endpos)) + (message-overlay-put ovl 'face 'highlight) + (y-or-n-p + (format "Replace with `%s'? " ace))) + (message "") + (message-delete-overlay ovl)) + message-use-idna))) + (replace-match (concat "@" ace))))))) + +(defun message-idna-to-ascii-rhs () + "Possibly IDNA encode non-ASCII domain names in From:, To: and Cc: headers. +See `message-idna-encode'." + (interactive) + (when message-use-idna + (save-excursion + (save-restriction + (message-narrow-to-head) + (message-idna-to-ascii-rhs-1 "From") + (message-idna-to-ascii-rhs-1 "To") + (message-idna-to-ascii-rhs-1 "Cc"))))) + (defun message-generate-headers (headers) "Prepare article HEADERS. Headers already prepared in the buffer are not modified." @@ -4719,7 +4874,9 @@ Headers already prepared in the buffer are not modified." (beginning-of-line)) (when (or (message-news-p) (string-match "@.+\\.." secure-sender)) - (insert "Sender: " secure-sender "\n"))))))) + (insert "Sender: " secure-sender "\n")))) + ;; Check for IDNA + (message-idna-to-ascii-rhs)))) (defun message-insert-courtesy-copy () "Insert a courtesy message in mail copies of combined messages." @@ -4772,6 +4929,16 @@ Headers already prepared in the buffer are not modified." (widen) (forward-line 1))) +(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." + (interactive "*") + (condition-case nil + (split-line message-yank-prefix) ;; Emacs 21.3.50+ supports arg. + (error + (split-line)))) + + (defun message-fill-header (header value) (let ((begin (point)) (fill-column 78) @@ -5086,6 +5253,10 @@ are not included." (when message-default-mail-headers (insert message-default-mail-headers) (or (bolp) (insert ?\n))) + (save-restriction + (message-narrow-to-headers) + (if message-alternative-emails + (message-use-alternative-email-as-from))) (when message-generate-headers-first (message-generate-headers (message-headers-to-generate @@ -5097,8 +5268,6 @@ are not included." (message-insert-signature) (save-restriction (message-narrow-to-headers) - (if message-alternative-emails - (message-use-alternative-email-as-from)) (run-hooks 'message-header-setup-hook)) (set-buffer-modified-p nil) (setq buffer-undo-list nil) @@ -5675,6 +5844,23 @@ the list of newsgroups is was posted to." (mail-decode-encoded-word-string prefix))) "] " subject)) +(defun message-forward-subject-name-subject (subject) + "Generate a SUBJECT for a forwarded message. +The form is: [Source] Subject, where if the original message was mail, +Source is the name of the sender, and if the original message was +news, Source is the list of newsgroups is was posted to." + (concat "[" + (let ((prefix + (or (message-fetch-field "newsgroups") + (let ((from (message-fetch-field "from"))) + (and from + (cdr (mail-header-parse-address from)))) + "(nowhere)"))) + (if message-forward-decoded-p + prefix + (mail-decode-encoded-word-string prefix))) + "] " subject)) + (defun message-forward-subject-fwd (subject) "Generate a SUBJECT for a forwarded message. The form is: Fwd: Subject, where Subject is the original subject of @@ -5752,11 +5938,11 @@ Optional DIGEST will use digest to forward." (not message-forward-decoded-p)) (insert (with-temp-buffer - (mm-disable-multibyte-mule4) + (mm-disable-multibyte) (insert (with-current-buffer forward-buffer - (mm-with-unibyte-current-buffer-mule4 (buffer-string)))) - (mm-enable-multibyte-mule4) + (mm-with-unibyte-current-buffer (buffer-string)))) + (mm-enable-multibyte) (mime-to-mml) (goto-char (point-min)) (when (looking-at "From ") @@ -5827,12 +6013,16 @@ Optional DIGEST will use digest to forward." (unless (message-mail-user-agent) (set-buffer (get-buffer-create " *message resend*")) (erase-buffer)) - (let ((message-this-is-mail t)) + (let ((message-this-is-mail t) + message-setup-hook) (message-setup `((To . ,address)))) ;; Insert our usual headers. (message-generate-headers '(From Date To)) (message-narrow-to-headers) + ;; Remove X-Draft-From header etc. + (message-remove-header message-ignored-mail-headers t) ;; Rename them all to "Resent-*". + (goto-char (point-min)) (while (re-search-forward "^[A-Za-z]" nil t) (forward-char -1) (insert "Resent-")) @@ -6001,6 +6191,9 @@ which specify the range to operate on." (delete-char -2)))))) (defalias 'message-exchange-point-and-mark 'exchange-point-and-mark) +(defalias 'message-make-overlay 'make-overlay) +(defalias 'message-delete-overlay 'delete-overlay) +(defalias 'message-overlay-put 'overlay-put) ;; Support for toolbar (eval-when-compile @@ -6197,11 +6390,6 @@ regexp varstr." (cdr local))))) locals))) -;;; Miscellaneous functions - -(defsubst message-replace-chars-in-string (string from to) - (mm-subst-char-in-string from to string)) - ;;; ;;; MIME functions ;;; @@ -6313,6 +6501,39 @@ regexp varstr." (if (and (or to cc) bcc) ", ") (or bcc ""))))))) +(defun message-hide-headers () + "Hide headers based on the `message-hidden-headers' variable." + (let ((regexps (if (stringp message-hidden-headers) + (list message-hidden-headers) + message-hidden-headers)) + (inhibit-point-motion-hooks t) + (after-change-functions nil)) + (when regexps + (save-excursion + (save-restriction + (message-narrow-to-headers) + (goto-char (point-min)) + (while (not (eobp)) + (if (not (message-hide-header-p regexps)) + (message-next-header) + (let ((begin (point))) + (message-next-header) + (add-text-properties + begin (point) + '(invisible t message-hidden t)))))))))) + +(defun message-hide-header-p (regexps) + (let ((result nil) + (reverse nil)) + (when (eq (car regexps) 'not) + (setq reverse t) + (pop regexps)) + (dolist (regexp regexps) + (setq result (or result (looking-at regexp)))) + (if reverse + (not result) + result))) + (when (featurep 'xemacs) (require 'messagexmas) (message-xmas-redefine))