aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--lisp/gnus/message.el97
1 files changed, 14 insertions, 83 deletions
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index a871ff89f40..77e471ffb5f 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -1923,63 +1923,6 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'."
1923(defvar message-bogus-system-names "\\`localhost\\.\\|\\.local\\'" 1923(defvar message-bogus-system-names "\\`localhost\\.\\|\\.local\\'"
1924 "The regexp of bogus system names.") 1924 "The regexp of bogus system names.")
1925 1925
1926(defcustom message-valid-fqdn-regexp
1927 (concat "[a-z0-9][-.a-z0-9]+\\." ;; [hostname.subdomain.]domain.
1928 ;; valid TLDs:
1929 "\\([a-z][a-z]\\|" ;; two letter country TDLs
1930 "aero\\|arpa\\|asia\\|bitnet\\|biz\\|bofh\\|"
1931 "cat\\|com\\|coop\\|edu\\|gov\\|"
1932 "info\\|int\\|jobs\\|"
1933 "mil\\|mobi\\|museum\\|name\\|net\\|"
1934 "org\\|pro\\|tel\\|travel\\|uucp\\|"
1935 ;; ICANN-era generic top-level domains
1936 "academy\\|actor\\|agency\\|airforce\\|archi\\|associates\\|axa\\|"
1937 "bar\\|bargains\\|bayern\\|beer\\|berlin\\|best\\|bid\\|bike\\|"
1938 "biz\\|black\\|blackfriday\\|blue\\|boutique\\|build\\|builders\\|"
1939 "buzz\\|cab\\|camera\\|camp\\|capital\\|cards\\|care\\|career\\|"
1940 "careers\\|cash\\|catering\\|center\\|ceo\\|cheap\\|christmas\\|"
1941 "church\\|citic\\|cleaning\\|clinic\\|clothing\\|club\\|codes\\|"
1942 "coffee\\|college\\|cologne\\|com\\|community\\|company\\|computer\\|"
1943 "construction\\|contractors\\|cooking\\|cool\\|country\\|creditcard\\|"
1944 "cruises\\|dance\\|dating\\|democrat\\|dental\\|desi\\|design\\|"
1945 "diamonds\\|directory\\|discount\\|domains\\|education\\|email\\|"
1946 "engineering\\|enterprises\\|equipment\\|estate\\|eus\\|events\\|"
1947 "exchange\\|expert\\|exposed\\|fail\\|farm\\|feedback\\|finance\\|"
1948 "financial\\|fish\\|fishing\\|fitness\\|flights\\|florist\\|foo\\|"
1949 "foundation\\|frogans\\|fund\\|furniture\\|futbol\\|gal\\|"
1950 "gallery\\|gift\\|glass\\|globo\\|gmo\\|gop\\|graphics\\|gratis\\|"
1951 "gripe\\|guide\\|guitars\\|guru\\|hamburg\\|haus\\|hiphop\\|"
1952 "holdings\\|holiday\\|homes\\|horse\\|house\\|immobilien\\|"
1953 "industries\\|info\\|ink\\|institute\\|insure\\|international\\|"
1954 "investments\\|jetzt\\|juegos\\|kaufen\\|kim\\|kitchen\\|kiwi\\|"
1955 "koeln\\|kred\\|land\\|lat\\|latino\\|lease\\|life\\|lighting\\|"
1956 "limited\\|limo\\|link\\|loans\\|london\\|luxe\\|luxury\\|"
1957 "management\\|mango\\|marketing\\|media\\|meet\\|menu\\|miami\\|"
1958 "moda\\|moe\\|monash\\|moscow\\|motorcycles\\|nagoya\\|name\\|"
1959 "net\\|neustar\\|ninja\\|nyc\\|okinawa\\|onl\\|org\\|paris\\|"
1960 "partners\\|parts\\|photo\\|photography\\|photos\\|pics\\|"
1961 "pictures\\|pink\\|plumbing\\|pro\\|productions\\|properties\\|"
1962 "pub\\|qpon\\|quebec\\|recipes\\|red\\|reisen\\|ren\\|rentals\\|"
1963 "repair\\|report\\|rest\\|reviews\\|rich\\|rocks\\|rodeo\\|"
1964 "ruhr\\|ryukyu\\|saarland\\|schule\\|scot\\|services\\|sexy\\|"
1965 "shiksha\\|shoes\\|singles\\|social\\|sohu\\|solar\\|solutions\\|"
1966 "soy\\|supplies\\|supply\\|support\\|surgery\\|systems\\|tattoo\\|"
1967 "tax\\|technology\\|tienda\\|tips\\|today\\|tokyo\\|tools\\|"
1968 "town\\|toys\\|trade\\|training\\|university\\|uno\\|vacations\\|"
1969 "vegas\\|ventures\\|viajes\\|villas\\|vision\\|vodka\\|vote\\|"
1970 "voting\\|voto\\|voyage\\|wang\\|watch\\|webcam\\|wed\\|wien\\|"
1971 "wiki\\|works\\|wtc\\|wtf\\|xyz\\|yachts\\|yokohama\\|you\\|"
1972 "zone\\)")
1973 ;; http://en.wikipedia.org/wiki/List_of_Internet_top-level_domains
1974 ;; http://en.wikipedia.org/wiki/GTLD
1975 ;; `approved, but not yet in operation': .xxx
1976 ;; "dead" nato bitnet uucp
1977 "Regular expression that matches a valid FQDN."
1978 ;; see also: gnus-button-valid-fqdn-regexp
1979 :version "25.1"
1980 :group 'message-headers
1981 :type 'regexp)
1982
1983(autoload 'gnus-alive-p "gnus-util") 1926(autoload 'gnus-alive-p "gnus-util")
1984(autoload 'gnus-delay-article "gnus-delay") 1927(autoload 'gnus-delay-article "gnus-delay")
1985(autoload 'gnus-extract-address-components "gnus-util") 1928(autoload 'gnus-extract-address-components "gnus-util")
@@ -4369,8 +4312,7 @@ conformance."
4369 (const "invalid") 4312 (const "invalid")
4370 (const :tag "duplicate @" "@@") 4313 (const :tag "duplicate @" "@@")
4371 (const :tag "non-ascii local part" "[^[:ascii:]].*@") 4314 (const :tag "non-ascii local part" "[^[:ascii:]].*@")
4372 ;; Already caught by `message-valid-fqdn-regexp' 4315 (const :tag "`_' in domain part" "@.*_")
4373 ;; (const :tag "`_' in domain part" "@.*_")
4374 (const :tag "whitespace" "[ \t]")) 4316 (const :tag "whitespace" "[ \t]"))
4375 (repeat :inline t 4317 (repeat :inline t
4376 :tag "Other" 4318 :tag "Other"
@@ -4476,31 +4418,24 @@ conformance."
4476RECIPIENTS is a mail header. Return a list of potentially bogus 4418RECIPIENTS is a mail header. Return a list of potentially bogus
4477addresses. If none is found, return nil. 4419addresses. If none is found, return nil.
4478 4420
4479An address might be bogus if the domain part is not fully 4421An address might be bogus if if there's a matching entry in
4480qualified, see `message-valid-fqdn-regexp', or if there's a 4422`message-bogus-addresses'."
4481matching entry in `message-bogus-addresses'."
4482 ;; FIXME: How about "foo@subdomain", when the MTA adds ".domain.tld"? 4423 ;; FIXME: How about "foo@subdomain", when the MTA adds ".domain.tld"?
4483 (let (found) 4424 (let (found)
4484 (mapc (lambda (address) 4425 (mapc (lambda (address)
4485 (setq address (or (cadr address) "")) 4426 (setq address (or (cadr address) ""))
4486 (when 4427 (when (or (string= "" address)
4487 (or (string= "" address)
4488 (not
4489 (or
4490 (not (string-match "@" address)) 4428 (not (string-match "@" address))
4491 (string-match 4429 (string-match "@.*@" address)
4492 (concat ".@.*\\(" 4430 (and message-bogus-addresses
4493 message-valid-fqdn-regexp "\\)\\'") address))) 4431 (let ((re
4494 (and message-bogus-addresses 4432 (if (listp message-bogus-addresses)
4495 (let ((re 4433 (mapconcat 'identity
4496 (if (listp message-bogus-addresses) 4434 message-bogus-addresses
4497 (mapconcat 'identity 4435 "\\|")
4498 message-bogus-addresses 4436 message-bogus-addresses)))
4499 "\\|") 4437 (string-match re address))))
4500 message-bogus-addresses)))
4501 (string-match re address))))
4502 (push address found))) 4438 (push address found)))
4503 ;;
4504 (mail-extract-address-components recipients t)) 4439 (mail-extract-address-components recipients t))
4505 found)) 4440 found))
4506 4441
@@ -5912,24 +5847,20 @@ give as trustworthy answer as possible."
5912 (cond 5847 (cond
5913 ((and message-user-fqdn 5848 ((and message-user-fqdn
5914 (stringp message-user-fqdn) 5849 (stringp message-user-fqdn)
5915 (string-match message-valid-fqdn-regexp message-user-fqdn)
5916 (not (string-match message-bogus-system-names message-user-fqdn))) 5850 (not (string-match message-bogus-system-names message-user-fqdn)))
5917 ;; `message-user-fqdn' seems to be valid 5851 ;; `message-user-fqdn' seems to be valid
5918 message-user-fqdn) 5852 message-user-fqdn)
5919 ((and (string-match message-valid-fqdn-regexp sysname) 5853 ((and (string-match message-bogus-system-names sysname))
5920 (not (string-match message-bogus-system-names sysname)))
5921 ;; `system-name' returned the right result. 5854 ;; `system-name' returned the right result.
5922 sysname) 5855 sysname)
5923 ;; Try `mail-host-address'. 5856 ;; Try `mail-host-address'.
5924 ((and (boundp 'mail-host-address) 5857 ((and (boundp 'mail-host-address)
5925 (stringp mail-host-address) 5858 (stringp mail-host-address)
5926 (string-match message-valid-fqdn-regexp mail-host-address)
5927 (not (string-match message-bogus-system-names mail-host-address))) 5859 (not (string-match message-bogus-system-names mail-host-address)))
5928 mail-host-address) 5860 mail-host-address)
5929 ;; We try `user-mail-address' as a backup. 5861 ;; We try `user-mail-address' as a backup.
5930 ((and user-domain 5862 ((and user-domain
5931 (stringp user-domain) 5863 (stringp user-domain)
5932 (string-match message-valid-fqdn-regexp user-domain)
5933 (not (string-match message-bogus-system-names user-domain))) 5864 (not (string-match message-bogus-system-names user-domain)))
5934 user-domain) 5865 user-domain)
5935 ;; Default to this bogus thing. 5866 ;; Default to this bogus thing.