;;; message.el --- composing mail and news messages
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
(require 'mail-parse)
(require 'mml)
(require 'rfc822)
-(eval-and-compile
- (autoload 'sha1 "sha1-el")
- (autoload 'gnus-find-method-for-group "gnus")
- (autoload 'nnvirtual-find-group-art "nnvirtual")
- (autoload 'gnus-group-decoded-name "gnus-group"))
(defgroup message '((user-mail-address custom-variable)
(user-full-name custom-variable))
(if (string-match "[[:digit:]]" "1") ;; support POSIX?
"\\([ \t]*[-_.[:word:]]+>+\\|[ \t]*[]>|}+]\\)+"
;; ?-, ?_ or ?. MUST NOT be in syntax entry w.
- (let ((old-table (syntax-table))
- non-word-constituents)
- (set-syntax-table text-mode-syntax-table)
- (setq non-word-constituents
- (concat
- (if (string-match "\\w" "-") "" "-")
- (if (string-match "\\w" "_") "" "_")
- (if (string-match "\\w" ".") "" ".")))
- (set-syntax-table old-table)
+ (let (non-word-constituents)
+ (with-syntax-table text-mode-syntax-table
+ (setq non-word-constituents
+ (concat
+ (if (string-match "\\w" "-") "" "-")
+ (if (string-match "\\w" "_") "" "_")
+ (if (string-match "\\w" ".") "" "."))))
(if (equal non-word-constituents "")
"\\([ \t]*\\(\\w\\)+>+\\|[ \t]*[]>|}+]\\)+"
(concat "\\([ \t]*\\(\\w\\|["
:type '(choice (function)
(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.")
-
(eval-when-compile
(defvar gnus-post-method)
(defvar gnus-select-method))
;; is nil. See: http://article.gmane.org/gmane.emacs.gnus.general/51138
(defcustom message-generate-headers-first '(references)
"Which headers should be generated before starting to compose a message.
-If `t', generate all required headers. This can also be a list of headers to
+If t, generate all required headers. This can also be a list of headers to
generate. The variables `message-required-news-headers' and
`message-required-mail-headers' specify which headers to generate.
"^|? *---+ +Message text follows: +---+ *|?$")
"A regexp that matches the separator before the text of a failed message.")
+(defvar message-field-fillers
+ '((To message-fill-field-address)
+ (Cc message-fill-field-address)
+ (From message-fill-field-address))
+ "Alist of header names/filler functions.")
+
(defvar message-header-format-alist
`((Newsgroups)
- (To . message-fill-address)
- (Cc . message-fill-address)
+ (To)
+ (Cc)
(Subject)
(In-Reply-To)
(Fcc)
:type 'regexp)
(eval-and-compile
- (autoload 'message-setup-toolbar "messagexmas")
- (autoload 'mh-new-draft-name "mh-comp")
- (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 'nndraft-request-associate-buffer "nndraft")
- (autoload 'nndraft-request-expire-articles "nndraft")
- (autoload 'gnus-open-server "gnus-int")
- (autoload 'gnus-request-post "gnus-int")
(autoload 'gnus-alive-p "gnus-util")
- (autoload 'gnus-server-string "gnus")
+ (autoload 'gnus-delay-article "gnus-delay")
+ (autoload 'gnus-extract-address-components "gnus-util")
+ (autoload 'gnus-find-method-for-group "gnus")
+ (autoload 'gnus-group-decoded-name "gnus-group")
(autoload 'gnus-group-name-charset "gnus-group")
(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-make-local-hook "gnus-util")
- (autoload 'gnus-extract-address-components "gnus-util"))
+ (autoload 'gnus-open-server "gnus-int")
+ (autoload 'gnus-output-to-mail "gnus-util")
+ (autoload 'gnus-output-to-rmail "gnus-util")
+ (autoload 'gnus-request-post "gnus-int")
+ (autoload 'gnus-server-string "gnus")
+ (autoload 'idna-to-ascii "idna")
+ (autoload 'message-setup-toolbar "messagexmas")
+ (autoload 'mh-new-draft-name "mh-comp")
+ (autoload 'mh-send-letter "mh-comp")
+ (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-msg-restore-non-pruned-header "rmail")
+ (autoload 'rmail-output "rmailout"))
+
+(eval-when-compile
+ (autoload 'sha1 "sha1-el"))
\f
The buffer is expected to be narrowed to just the header of the message;
see `message-narrow-to-headers-or-head'."
(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)
(defun message-narrow-to-field ()
"Narrow the buffer to the header on the current line."
(beginning-of-line)
+ (while (looking-at "[ \t]")
+ (forward-line -1))
(narrow-to-region
(point)
(progn
(forward-line 1)
(if (re-search-forward "^[^ \n\t]" nil t)
- (progn
- (beginning-of-line)
- (point))
+ (point-at-bol)
(point-max))))
(goto-char (point-min)))
(1+ max)))))
(message-sort-headers-1))))
+(defun message-kill-address ()
+ "Kill the address under point."
+ (interactive)
+ (let ((start (point)))
+ (message-skip-to-next-address)
+ (kill-region start (point))))
\f
(define-key message-mode-map "\C-c\C-d" 'message-dont-send)
(define-key message-mode-map "\C-c\n" 'gnus-delay-article)
+ (define-key message-mode-map "\C-c\M-k" 'message-kill-address)
(define-key message-mode-map "\C-c\C-e" 'message-elide-region)
(define-key message-mode-map "\C-c\C-v" 'message-delete-not-region)
(define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature)
(define-key message-mode-map "\M-\r" 'message-newline-and-reformat)
- ;;(define-key message-mode-map "\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)
(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)
"---+$\\|" ; delimiters for forwarded messages
page-delimiter "$\\|" ; spoiler warnings
".*wrote:$\\|" ; attribution lines
- quote-prefix-regexp "$")) ; empty lines in quoted text
+ quote-prefix-regexp "$\\|" ; empty lines in quoted text
+ ; mml tags
+ "<#!*/?\\(multipart\\|part\\|external\\|mml\\|secure\\)"))
(setq paragraph-separate paragraph-start)
(setq adaptive-fill-regexp
(concat quote-prefix-regexp "\\|" adaptive-fill-regexp))
(message-get-reply-headers t))))
(message-carefully-insert-headers headers)))
-(defvar message-header-synonyms
+(defcustom message-header-synonyms
'((To Cc Bcc))
"List of lists of header synonyms.
E.g., if this list contains a member list with elements `Cc' and `To',
then `message-carefully-insert-headers' will not insert a `To' header
-when the message is already `Cc'ed to the recipient.")
+when the message is already `Cc'ed to the recipient."
+ :group 'message-headers
+ :link '(custom-manual "(message)Message Headers")
+ :type '(repeat sexp))
(defun message-carefully-insert-headers (headers)
"Insert the HEADERS, an alist, into the message buffer.
Does not insert the headers when they are already present there
or in the synonym headers, defined by `message-header-synonyms'."
+ ;; FIXME: Should compare only the address and not the full name. Comparison
+ ;; should be done case-folded (and with `string=' rather than
+ ;; `string-match').
(dolist (header headers)
(let* ((header-name (symbol-name (car header)))
(new-header (cdr header))
(when (message-goto-signature)
(forward-line -2)))
-(defun message-kill-to-signature ()
- "Deletes all text up to the signature."
- (interactive)
- (let ((point (point)))
- (message-goto-signature)
- (unless (eobp)
- (end-of-line -1))
- (kill-region point (point))
- (unless (bolp)
- (insert "\n"))))
+(defun message-kill-to-signature (&optional arg)
+ "Kill all text up to the signature.
+If a numberic argument or prefix arg is given, leave that number
+of lines before the signature intact."
+ (interactive "p")
+ (save-excursion
+ (save-restriction
+ (let ((point (point)))
+ (narrow-to-region point (point-max))
+ (message-goto-signature)
+ (unless (eobp)
+ (if (and arg (numberp arg))
+ (forward-line (- -1 arg))
+ (end-of-line -1)))
+ (unless (= point (point))
+ (kill-region point (point))
+ (insert "\n"))))))
(defun message-newline-and-reformat (&optional arg not-break)
"Insert four newlines, and then reformat if inside quoted text.
(interactive (list (if current-prefix-arg 'full)))
(if (if (boundp 'filladapt-mode) filladapt-mode)
nil
- (message-newline-and-reformat arg t)
+ (if (message-point-in-header-p)
+ (message-fill-field)
+ (message-newline-and-reformat arg t))
t))
;; Is it better to use `mail-header-end'?
"Send the prepared message buffer with `smtpmail-send-it'.
This only differs from `smtpmail-send-it' that this command evaluates
`message-send-mail-hook' just before sending a message. It is useful
-if your ISP requires the POP-before-SMTP authentication. See the
-documentation for the function `mail-source-touch-pop'."
+if your ISP requires the POP-before-SMTP authentication. See the Gnus
+manual for details."
(run-hooks 'message-send-mail-hook)
(smtpmail-send-it))
(defun message-canlock-generate ()
"Return a string that is non-trivial to guess.
Do not use this for anything important, it is cryptographically weak."
+ (require 'sha1-el)
(let (sha1-maximum-internal-length)
(sha1 (concat (message-unique-id)
(format "%x%x%x" (random) (random t) (random))
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)))))))
+ (let ((field (message-fetch-field header))
+ rhs ace address)
+ (when field
+ (dolist (address (mail-header-parse-addresses field))
+ (setq address (car address)
+ rhs (downcase (cadr (split-string address "@")))
+ ace (downcase (idna-to-ascii rhs)))
+ (when (and (not (equal rhs ace))
+ (or (not (eq message-use-idna 'ask))
+ (y-or-n-p (format "Replace %s with %s? " rhs ace))))
+ (goto-char (point-min))
+ (while (re-search-forward (concat "^" header ":") nil t)
+ (message-narrow-to-field)
+ (while (search-forward (concat "@" rhs) nil t)
+ (replace-match (concat "@" ace) t t))
+ (goto-char (point-max))
+ (widen)))))))
(defun message-idna-to-ascii-rhs ()
"Possibly IDNA encode non-ASCII domain names in From:, To: and Cc: headers.
(if formatter
(funcall formatter header value)
(insert header-string ": " value))
+ (goto-char (message-fill-field))
;; We check whether the value was ended by a
- ;; newline. If now, we insert one.
+ ;; newline. If not, we insert one.
(unless (bolp)
(insert "\n"))
(forward-line -1)))
;; The value of this header was empty, so we clear
;; totally and insert the new value.
- (delete-region (point) (gnus-point-at-eol))
+ (delete-region (point) (point-at-eol))
;; If the header is optional, and the header was
;; empty, we con't insert it anyway.
(unless optionalp
(push header-string message-inserted-headers)
- (insert value)))
+ (insert value)
+ (message-fill-field)))
;; Add the deletable property to the headers that require it.
(and (memq header message-deletable-headers)
(progn (beginning-of-line) (looking-at "[^:]+: "))
;;; Setting up a message buffer
;;;
+(defun message-skip-to-next-address ()
+ (let ((end (save-excursion
+ (message-next-header)
+ (point)))
+ quoted char)
+ (when (looking-at ",")
+ (forward-char 1))
+ (while (and (not (= (point) end))
+ (or (not (eq char ?,))
+ quoted))
+ (skip-chars-forward "^,\"" (point-max))
+ (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)
- (save-restriction
- (narrow-to-region (point) (point))
- (insert (capitalize (symbol-name header))
- ": "
- (if (consp value) (car value) value)
- "\n")
- (narrow-to-region (point-min) (1- (point-max)))
- (let (quoted last)
- (goto-char (point-min))
- (while (not (eobp))
- (skip-chars-forward "^,\"" (point-max))
- (if (or (eq (char-after) ?,)
- (eobp))
- (when (not quoted)
- (if (and (> (current-column) 78)
- last)
- (progn
- (save-excursion
- (goto-char last)
- (insert "\n\t"))
- (setq last (1+ (point))))
- (setq last (1+ (point)))))
- (setq quoted (not quoted)))
- (unless (eobp)
- (forward-char 1))))
- (goto-char (point-max))
- (widen)
- (forward-line 1)))
+ (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.
(split-line message-yank-prefix) ;; Emacs 21.3.50+ supports arg.
(error
(split-line))))
-
-(defun message-fill-header (header value)
+(defun message-insert-header (header value)
+ (insert (capitalize (symbol-name header))
+ ": "
+ (if (consp value) (car value) value)))
+
+(defun message-field-name ()
+ (save-excursion
+ (goto-char (point-min))
+ (when (looking-at "\\([^:]+\\):")
+ (intern (capitalize (match-string 1))))))
+
+(defun message-fill-field ()
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-field)
+ (let ((field-name (message-field-name)))
+ (funcall (or (cadr (assq field-name message-field-fillers))
+ 'message-fill-field-general)))
+ (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)))))))
+
+(defun message-fill-field-general ()
(let ((begin (point))
(fill-column 78)
(fill-prefix "\t"))
- (insert (capitalize (symbol-name header))
- ": "
- (if (consp value) (car value) value)
- "\n")
- (save-restriction
- (narrow-to-region begin (point))
- (fill-region-as-paragraph begin (point))
- ;; Tapdance around looong Message-IDs.
- (forward-line -1)
- (when (looking-at "[ \t]*$")
- (message-delete-line))
- (goto-char begin)
- (re-search-forward ":" nil t)
- (when (looking-at "\n[ \t]+")
- (replace-match " " t t))
- (goto-char (point-max)))))
+ (while (and (search-forward "\n" nil t)
+ (not (eobp)))
+ (replace-match " " t t))
+ (fill-region-as-paragraph begin (point-max))
+ ;; Tapdance around looong Message-IDs.
+ (forward-line -1)
+ (when (looking-at "[ \t]*$")
+ (message-delete-line))
+ (goto-char begin)
+ (re-search-forward ":" nil t)
+ (when (looking-at "\n[ \t]+")
+ (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."
(defun message-shorten-references (header references)
"Trim REFERENCES to be 21 Message-ID long or less, 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."
+When sending via news, also check that the REFERENCES are less
+than 988 characters long, and if they are not, trim them until
+they are."
(let ((maxcount 21)
(count 0)
(cut 2)
(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.
+ ;; When sending via news, make sure the total folded length will
+ ;; be less than 998 characters. This is to cater to broken INN
+ ;; 2.3 which counts the total number of characters in a header
+ ;; rather than the physical line length of each line, as it shuld.
;;
- ;; 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))))
-
+ ;; This hack should be removed when it's believed than INN 2.3 is
+ ;; no longer widely used.
+ ;;
+ ;; At this point the headers have not been generated, thus we use
+ ;; message-this-is-news directly.
+ (when message-this-is-news
+ (while (< 998
+ (with-temp-buffer
+ (message-insert-header
+ header (mapconcat #'identity refs " "))
+ (buffer-size)))
+ (message-shorten-1 refs cut 1)))
;; 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)))))
+ (message-insert-header header (mapconcat #'identity refs " "))))
(defun message-position-point ()
"Move point to where the user probably wants to find it."
(message-point-in-header-p))
(let* ((here (point))
(bol (progn (beginning-of-line n) (point)))
- (eol (gnus-point-at-eol))
+ (eol (point-at-eol))
(eoh (re-search-forward ": *" eol t)))
(if (or (not eoh) (equal here eoh))
(goto-char bol)
(when message-default-headers
(insert message-default-headers)
(or (bolp) (insert ?\n)))
- (put-text-property
- (point)
- (progn
- (insert mail-header-separator "\n")
- (1- (point)))
- 'read-only nil)
+ (insert mail-header-separator "\n")
(forward-line -1)
(when (message-news-p)
(when message-default-news-headers
;; Find all relevant headers we need.
(save-restriction
(message-narrow-to-headers-or-head)
- (setq to (message-fetch-field "to")
+ ;; Gmane renames "To". Look at "Original-To", too, if it is present in
+ ;; message-header-synonyms.
+ (setq to (or (message-fetch-field "to")
+ (and (loop for synonym in message-header-synonyms
+ when (memq 'Original-To synonym)
+ return t)
+ (message-fetch-field "original-to")))
cc (message-fetch-field "cc")
mct (message-fetch-field "mail-copies-to")
author (or (message-fetch-field "mail-reply-to")
(defun message-forward-rmail-make-body (forward-buffer)
(save-window-excursion
(set-buffer forward-buffer)
- ;; Rmail doesn't have rmail-msg-restore-non-pruned-header in Emacs
- ;; 20. FIXIT, or we drop support for rmail in Emacs 20.
(if (rmail-msg-is-pruned)
(rmail-msg-restore-non-pruned-header)))
(message-forward-make-body forward-buffer))
(if (eq (char-after) (char-after (- (point) 2)))
(delete-char -2))))))
-(defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)
+(defun message-exchange-point-and-mark ()
+ "Exchange point and mark, but don't activate region if it was inactive."
+ (unless (prog1
+ (message-mark-active-p)
+ (exchange-point-and-mark))
+ (setq mark-active nil)))
+
(defalias 'message-make-overlay 'make-overlay)
(defalias 'message-delete-overlay 'delete-overlay)
(defalias 'message-overlay-put 'overlay-put)
(delete-region (point) (progn (forward-line 3) (point))))))))))
(defun message-expand-name ()
- (if (fboundp 'bbdb-complete-name)
- (bbdb-complete-name)
- (expand-abbrev)))
+ (cond ((when (boundp 'eudc-protocol) eudc-protocol)
+ (eudc-expand-inline))
+ ((fboundp 'bbdb-complete-name)
+ (bbdb-complete-name))
+ (t
+ (expand-abbrev))))
;;; Help stuff.
;; coding: iso-8859-1
;; End:
+;;; arch-tag: 94b32cac-4504-4b6c-8181-030ebf380ee0
;;; message.el ends here
projects / gnus / blobdiff