regexp))
(defcustom message-subject-re-regexp
- "^[ \t]*\\([Rr][Ee]\\(\\[[0-9]*\\]\\)*:[ \t]*\\)*[ \t]*"
+ "^[ \t]*\\([Rr][Ee]\\(\\[[0-9]*\\]\\)* ?:[ \t]*\\)*[ \t]*"
"*Regexp matching \"Re: \" in the subject line."
:group 'message-various
:link '(custom-manual "(message)Message Headers")
(defcustom message-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."
+This can be a regexp, a list of regexps or a predicate function.
+Also, a value of nil means exclude your own user name only.
+
+If a function email is passed as the argument."
:version "24.3"
:group 'message
:link '(custom-manual "(message)Wide Reply")
(repeat :tag "Regexp List" regexp)))
(defsubst message-dont-reply-to-names ()
- (gmm-regexp-concat message-dont-reply-to-names))
+ (cond ((functionp message-dont-reply-to-names)
+ message-dont-reply-to-names)
+ ((stringp message-dont-reply-to-names)
+ (gmm-regexp-concat message-dont-reply-to-names))))
(defvar message-shoot-gnksa-feet nil
"*A list of GNKSA feet you are allowed to shoot.
(integer 1000000)))
(defcustom message-alternative-emails nil
- "*Regexp matching alternative email addresses.
+ "*Regexp or predicate function matching alternative email addresses.
The first address in the To, Cc or From headers of the original
article matching this variable is used as the From field of
outgoing messages.
+If a function, an email string is passed as the argument.
+
This variable has precedence over posting styles and anything that runs
off `message-setup-hook'."
:group 'message-headers
:link '(custom-manual "(message)Message Headers")
:type '(choice (const :tag "Always use primary" nil)
- regexp))
+ regexp
+ function))
(defcustom message-hierarchical-addresses nil
"A list of hierarchical mail address definitions.
(defvar message-bogus-system-names "\\`localhost\\.\\|\\.local\\'"
"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
- "aero\\|arpa\\|asia\\|bitnet\\|biz\\|bofh\\|"
- "cat\\|com\\|coop\\|edu\\|gov\\|"
- "info\\|int\\|jobs\\|"
- "mil\\|mobi\\|museum\\|name\\|net\\|"
- "org\\|pro\\|tel\\|travel\\|uucp\\|"
- ;; ICANN-era generic top-level domains
- "academy\\|actor\\|agency\\|airforce\\|archi\\|associates\\|axa\\|"
- "bar\\|bargains\\|bayern\\|beer\\|berlin\\|best\\|bid\\|bike\\|"
- "biz\\|black\\|blackfriday\\|blue\\|boutique\\|build\\|builders\\|"
- "buzz\\|cab\\|camera\\|camp\\|capital\\|cards\\|care\\|career\\|"
- "careers\\|cash\\|catering\\|center\\|ceo\\|cheap\\|christmas\\|"
- "church\\|citic\\|cleaning\\|clinic\\|clothing\\|club\\|codes\\|"
- "coffee\\|college\\|cologne\\|com\\|community\\|company\\|computer\\|"
- "construction\\|contractors\\|cooking\\|cool\\|country\\|creditcard\\|"
- "cruises\\|dance\\|dating\\|democrat\\|dental\\|desi\\|design\\|"
- "diamonds\\|directory\\|discount\\|domains\\|education\\|email\\|"
- "engineering\\|enterprises\\|equipment\\|estate\\|eus\\|events\\|"
- "exchange\\|expert\\|exposed\\|fail\\|farm\\|feedback\\|finance\\|"
- "financial\\|fish\\|fishing\\|fitness\\|flights\\|florist\\|foo\\|"
- "foundation\\|frogans\\|fund\\|furniture\\|futbol\\|gal\\|"
- "gallery\\|gift\\|glass\\|globo\\|gmo\\|gop\\|graphics\\|gratis\\|"
- "gripe\\|guide\\|guitars\\|guru\\|hamburg\\|haus\\|hiphop\\|"
- "holdings\\|holiday\\|homes\\|horse\\|house\\|immobilien\\|"
- "industries\\|info\\|ink\\|institute\\|insure\\|international\\|"
- "investments\\|jetzt\\|juegos\\|kaufen\\|kim\\|kitchen\\|kiwi\\|"
- "koeln\\|kred\\|land\\|lat\\|latino\\|lease\\|life\\|lighting\\|"
- "limited\\|limo\\|link\\|loans\\|london\\|luxe\\|luxury\\|"
- "management\\|mango\\|marketing\\|media\\|meet\\|menu\\|miami\\|"
- "moda\\|moe\\|monash\\|moscow\\|motorcycles\\|nagoya\\|name\\|"
- "net\\|neustar\\|ninja\\|nyc\\|okinawa\\|onl\\|org\\|paris\\|"
- "partners\\|parts\\|photo\\|photography\\|photos\\|pics\\|"
- "pictures\\|pink\\|plumbing\\|pro\\|productions\\|properties\\|"
- "pub\\|qpon\\|quebec\\|recipes\\|red\\|reisen\\|ren\\|rentals\\|"
- "repair\\|report\\|rest\\|reviews\\|rich\\|rocks\\|rodeo\\|"
- "ruhr\\|ryukyu\\|saarland\\|schule\\|scot\\|services\\|sexy\\|"
- "shiksha\\|shoes\\|singles\\|social\\|sohu\\|solar\\|solutions\\|"
- "soy\\|supplies\\|supply\\|support\\|surgery\\|systems\\|tattoo\\|"
- "tax\\|technology\\|tienda\\|tips\\|today\\|tokyo\\|tools\\|"
- "town\\|toys\\|trade\\|training\\|university\\|uno\\|vacations\\|"
- "vegas\\|ventures\\|viajes\\|villas\\|vision\\|vodka\\|vote\\|"
- "voting\\|voto\\|voyage\\|wang\\|watch\\|webcam\\|wed\\|wien\\|"
- "wiki\\|works\\|wtc\\|wtf\\|xyz\\|yachts\\|yokohama\\|you\\|"
- "zone\\)")
- ;; http://en.wikipedia.org/wiki/List_of_Internet_top-level_domains
- ;; http://en.wikipedia.org/wiki/GTLD
- ;; `approved, but not yet in operation': .xxx
- ;; "dead" nato bitnet uucp
- "Regular expression that matches a valid FQDN."
- ;; see also: gnus-button-valid-fqdn-regexp
- :version "25.1"
- :group 'message-headers
- :type 'regexp)
-
(autoload 'gnus-alive-p "gnus-util")
(autoload 'gnus-delay-article "gnus-delay")
(autoload 'gnus-extract-address-components "gnus-util")
(defun message-point-in-header-p ()
"Return t if point is in the header."
(save-excursion
- (and
- (not
- (re-search-backward
- (concat "^" (regexp-quote mail-header-separator) "\n") nil t))
- (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "\n") nil t))))
+ (save-restriction
+ (widen)
+ (let ((bound (+ (point-at-eol) 1)) case-fold-search)
+ (goto-char (point-min))
+ (not (search-forward (concat "\n" mail-header-separator "\n")
+ bound t))))))
(defun message-do-auto-fill ()
"Like `do-auto-fill', but don't fill in message header."
(const "invalid")
(const :tag "duplicate @" "@@")
(const :tag "non-ascii local part" "[^[:ascii:]].*@")
- ;; Already caught by `message-valid-fqdn-regexp'
- ;; (const :tag "`_' in domain part" "@.*_")
+ (const :tag "`_' in domain part" "@.*_")
(const :tag "whitespace" "[ \t]"))
(repeat :inline t
:tag "Other"
RECIPIENTS is a mail header. Return a list of potentially bogus
addresses. If none is found, return nil.
-An address might be bogus if the domain part is not fully
-qualified, see `message-valid-fqdn-regexp', or if there's a
-matching entry in `message-bogus-addresses'."
+An address might be bogus if if there's a matching entry in
+`message-bogus-addresses'."
;; FIXME: How about "foo@subdomain", when the MTA adds ".domain.tld"?
(let (found)
(mapc (lambda (address)
(setq address (or (cadr address) ""))
- (when
- (or (string= "" address)
- (not
- (or
+ (when (or (string= "" address)
(not (string-match "@" address))
- (string-match
- (concat ".@.*\\("
- message-valid-fqdn-regexp "\\)\\'") address)))
- (and message-bogus-addresses
- (let ((re
- (if (listp message-bogus-addresses)
- (mapconcat 'identity
- message-bogus-addresses
- "\\|")
- message-bogus-addresses)))
- (string-match re address))))
+ (string-match "@.*@" address)
+ (and message-bogus-addresses
+ (let ((re
+ (if (listp message-bogus-addresses)
+ (mapconcat 'identity
+ message-bogus-addresses
+ "\\|")
+ message-bogus-addresses)))
+ (string-match re address))))
(push address found)))
- ;;
(mail-extract-address-components recipients t))
found))
(cond
((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' seems to be valid
message-user-fqdn)
- ((and (string-match message-valid-fqdn-regexp sysname)
- (not (string-match message-bogus-system-names sysname)))
+ ((and (string-match message-bogus-system-names sysname))
;; `system-name' returned the right result.
sysname)
;; Try `mail-host-address'.
((and (boundp 'mail-host-address)
(stringp 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-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.
(defvar visual-line-mode)
(declare-function beginning-of-visual-line "simple" (&optional n))
+(defun message-beginning-of-header (handle-folded)
+ "Move point to beginning of header’s value.
+
+When point is at the first header line, moves it after the colon
+and spaces separating header name and header value.
+
+When point is in a continuation line of a folded header (i.e. the
+line starts with a space), the behaviour depends on HANDLE-FOLDED
+argument. If it’s nil, function moves the point to the start of
+the header continuation; otherwise, function locates the
+beginning of the header and moves point past the colon as is the
+case of single-line headers.
+
+No check whether point is inside of a header or body of the
+message is performed.
+
+Returns point or nil if beginning of header’s value could not be
+found. In the latter case, the point is still moved to the
+beginning of line (possibly after attempting to move it to the
+beginning of a folded header)."
+ ;; https://www.rfc-editor.org/rfc/rfc2822.txt, section 2.2.3. says that when
+ ;; unfolding a single WSP should be consumed. WSP is defined as a space
+ ;; character or a horizontal tab.
+ (beginning-of-line)
+ (when handle-folded
+ (while (and (> (point) (point-min))
+ (or (eq (char-after) ?\s) (eq (char-after) ?\t)))
+ (beginning-of-line 0)))
+ (when (or (eq (char-after) ?\s) (eq (char-after) ?\t)
+ (search-forward ":" (point-at-eol) t))
+ ;; We are a bit more lacks than the RFC and allow any positive number of WSP
+ ;; characters.
+ (skip-chars-forward " \t" (point-at-eol))
+ (point)))
+
(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'.
This command is identical to `beginning-of-line' if point is
-outside the message header or if the option `message-beginning-of-line'
-is nil.
-
-If point is in the message header and on a (non-continued) header
-line, move point to the beginning of the header value or the beginning of line,
-whichever is closer. If point is already at beginning of line, move point to
-beginning of header value. Therefore, repeated calls will toggle point
-between beginning of field and beginning of line."
+outside the message header or if the option
+`message-beginning-of-line' is nil.
+
+If point is in the message header and on a header line, move
+point to the beginning of the header value or the beginning of
+line, whichever is closer. If point is already at beginning of
+line, move point to beginning of header value. Therefore,
+repeated calls will toggle point between beginning of field and
+beginning of line.
+
+When called without a prefix argument, header value spanning
+multiple lines is treated as a single line. Otherwise, even if
+N is 1, when point is on a continuation header line, it will be
+moved to the beginning "
(interactive "p")
(let ((zrs 'zmacs-region-stays))
(when (and (featurep 'xemacs) (interactive-p) (boundp zrs))
(set zrs t)))
- (if (and message-beginning-of-line
- (message-point-in-header-p))
- (let* ((here (point))
- (bol (progn (beginning-of-line n) (point)))
- (eol (point-at-eol))
- (eoh (re-search-forward ": *" eol t)))
- (goto-char
- (if (and eoh (or (< eoh here) (= bol here)))
- eoh bol)))
- (if (and (boundp 'visual-line-mode) visual-line-mode)
- (beginning-of-visual-line n)
- (beginning-of-line n))))
+ (cond
+ ;; Go to beginning of header or beginning of line.
+ ((and message-beginning-of-line (message-point-in-header-p))
+ (let* ((point (point))
+ (bol (progn (beginning-of-line n) (point)))
+ (boh (message-beginning-of-header (and (boundp 'visual-line-mode)
+ visual-line-mode))))
+ (goto-char (if (and boh (or (< boh point) (= bol point))) boh bol))))
+ ;; Go to beginning of visual line
+ ((and (boundp 'visual-line-mode) visual-line-mode)
+ (beginning-of-visual-line n))
+ ;; Go to beginning of line.
+ ((beginning-of-line n))))
(defun message-buffer-name (type &optional to group)
"Return a new (unique) buffer name based on TYPE and TO."
;; Squeeze whitespace.
(while (string-match "[ \t][ \t]+" recipients)
(setq recipients (replace-match " " t t 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)))
+ ;; Remove addresses that match `message-dont-reply-to-names'.
+ (setq recipients
+ (cond ((functionp message-dont-reply-to-names)
+ (mapconcat
+ 'identity
+ (delq nil
+ (mapcar (lambda (mail)
+ (unless (funcall message-dont-reply-to-names
+ (mail-strip-quoted-names mail))
+ mail))
+ (message-tokenize-header recipients)))
+ ", "))
+ (t (let ((mail-dont-reply-to-names (message-dont-reply-to-names)))
+ (mail-dont-reply-to recipients)))))
;; Perhaps "Mail-Copies-To: never" removed the only address?
(if (string-equal recipients "")
(setq recipients author))
If you have added `cancel-messages' to `message-shoot-gnksa-feet', all articles
are yours except those that have Cancel-Lock header not belonging to you.
Instead of shooting GNKSA feet, you should modify `message-alternative-emails'
-regexp to match all of yours addresses."
+to match all of yours addresses."
;; Canlock-logic as suggested by Per Abrahamsen
;; <abraham@dina.kvl.dk>
;;
(downcase (car (mail-header-parse-address
(message-make-from))))))
;; Email address in From field matches
- ;; 'message-alternative-emails' regexp
+ ;; 'message-alternative-emails' regexp or function.
(and from
message-alternative-emails
- (string-match
- message-alternative-emails
- (car (mail-header-parse-address from))))))))))
+ (cond ((functionp message-alternative-emails)
+ (funcall message-alternative-emails
+ (mail-header-parse-address from)))
+ (t (string-match message-alternative-emails
+ (car (mail-header-parse-address from))))))))))))
;;;###autoload
(defun message-cancel-news (&optional arg)
(require 'mail-utils)
(let* ((fields '("To" "Cc" "From"))
(emails
- (split-string
+ (message-tokenize-header
(mail-strip-quoted-names
- (mapconcat 'message-fetch-reply-field fields ","))
- "[ \f\t\n\r\v,]+"))
- email)
- (while emails
- (if (string-match message-alternative-emails (car emails))
- (setq email (car emails)
- emails nil))
- (pop emails))
+ (mapconcat 'message-fetch-reply-field fields ","))))
+ (email (cond ((functionp message-alternative-emails)
+ (car (cl-remove-if-not message-alternative-emails emails)))
+ (t (loop for email in emails
+ if (string-match-p message-alternative-emails email)
+ return email)))))
(unless (or (not email) (equal email user-mail-address))
(message-remove-header "From")
(goto-char (point-max))