[COMMIIT mail-lib] Make `mail-extr-all-top-level-domains' into a hash-table literal, mail-extr.el
7 years, 6 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1490219755 0
# Wed Mar 22 21:55:55 2017 +0000
# Node ID d85eeaca795d9c459be7f6b369b8a544a7de56d5
# Parent 7c59d90e8c3957eb3dc3ac85e732c42ac448ed1f
Make `mail-extr-all-top-level-domains' into a hash-table literal, mail-extr.el
ChangeLog addition:
2017-03-22 Aidan Kehoe <kehoea(a)parhasard.net>
* mail-extr.el:
* mail-extr.el (require):
* mail-extr.el (mail-extract-address-components):
* mail-extr.el (mail-extr-all-top-level-domains):
* mail-extr.el (what-domain):
Make `mail-extr-all-top-level-domains' into a hash-table literal
created at macro-expansion time, rather than an obarray created at
load time, for the sake of not calling #'format a bunch of times
at load time, something that recently started complaining about
extra arguments on debug XEmacs builds. This also gives a slight
speedup.
Use the hash table functions in order to do this.
Handle those versions of XEmacs where #'completing-read isn't
compatible with a hash-table COLLECTION within
diff -r 7c59d90e8c39 -r d85eeaca795d ChangeLog
--- a/ChangeLog Wed Mar 22 20:43:34 2017 +0000
+++ b/ChangeLog Wed Mar 22 21:55:55 2017 +0000
＠＠ -1,3 +1,20 ＠＠
+2017-03-22 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * mail-extr.el:
+ * mail-extr.el (require):
+ * mail-extr.el (mail-extract-address-components):
+ * mail-extr.el (mail-extr-all-top-level-domains):
+ * mail-extr.el (what-domain):
+ Make `mail-extr-all-top-level-domains' into a hash-table literal
+ created at macro-expansion time, rather than an obarray created at
+ load time, for the sake of not calling #'format a bunch of times
+ at load time, something that recently started complaining about
+ extra arguments on debug XEmacs builds. This also gives a slight
+ speedup.
+ Use the hash table functions in order to do this.
+ Handle those versions of XEmacs where #'completing-read isn't
+ compatible with a hash-table COLLECTION within
+
2017-03-22 Aidan Kehoe <kehoea(a)parhasard.net>
* mail-extr.el:
diff -r 7c59d90e8c39 -r d85eeaca795d mail-extr.el
--- a/mail-extr.el Wed Mar 22 20:43:34 2017 +0000
+++ b/mail-extr.el Wed Mar 22 21:55:55 2017 +0000
＠＠ -212,6 +212,8 ＠＠
(if (featurep 'xemacs) ;; Purespace obsolete in XEmacs.
(define-compiler-macro purecopy (&whole form argument) argument)))
+(eval-when-compile (require 'cl))
+
(defgroup mail-extr nil
"Extract full name and address from RFC 822 mail header."
:prefix "mail-extr-"
＠＠ -1201,10 +1203,8 ＠＠
(setq \.-pos (eq ?. (preceding-char))))
(when (and \.-pos
;; #### string consing
- (let ((s (intern-soft
- (buffer-substring domain-pos (point))
- mail-extr-all-top-level-domains)))
- (and s (get s 'domain-name))))
+ (gethash (buffer-substring domain-pos (point))
+ mail-extr-all-top-level-domains))
(narrow-to-region (point-min) (point))
(goto-char (car temp))
(delete-char 1)
＠＠ -1883,308 +1883,315 ＠＠
;; Latest change: 2007/11/15
(defconst mail-extr-all-top-level-domains
- (let ((ob (make-vector 739 0)))
- (mapc
- (lambda (x)
- (put (intern (downcase (car x)) ob)
- 'domain-name
- (if (nth 2 x)
- (format (nth 2 x) (nth 1 x))
- (nth 1 x))))
- '(
- ;; ISO 3166 codes:
- ("ac" "Ascension Island")
- ("ad" "Andorra")
- ("ae" "United Arab Emirates")
- ("af" "Afghanistan")
- ("ag" "Antigua and Barbuda")
- ("ai" "Anguilla")
- ("al" "Albania")
- ("am" "Armenia")
- ("an" "Netherlands Antilles")
- ("ao" "Angola")
- ("aq" "Antarctica") ; continent
- ("ar" "Argentina" "Argentine Republic")
- ("as" "American Samoa")
- ("at" "Austria" "The Republic of %s")
- ("au" "Australia")
- ("aw" "Aruba")
- ("ax" "Aland Islands")
- ("az" "Azerbaijan")
- ("ba" "Bosnia-Herzegovina")
- ("bb" "Barbados")
- ("bd" "Bangladesh")
- ("be" "Belgium" "The Kingdom of %s")
- ("bf" "Burkina Faso")
- ("bg" "Bulgaria")
- ("bh" "Bahrain")
- ("bi" "Burundi")
- ("bj" "Benin")
- ("bl" "Saint Barthelemy")
- ("bm" "Bermuda")
- ("bn" "Brunei Darussalam")
- ("bo" "Bolivia" "Republic of %s")
- ("br" "Brazil" "The Federative Republic of %s")
- ("bs" "Bahamas")
- ("bt" "Bhutan")
- ("bv" "Bouvet Island")
- ("bw" "Botswana")
- ("by" "Belarus")
- ("bz" "Belize")
- ("ca" "Canada")
- ("cc" "Cocos (Keeling) Islands")
- ("cd" "Congo" "The Democratic Republic of the %s")
- ("cf" "Central African Republic")
- ("cg" "Congo")
- ("ch" "Switzerland" "The Swiss Confederation")
- ("ci" "Ivory Coast") ; Cote D'ivoire
- ("ck" "Cook Islands")
- ("cl" "Chile" "The Republic of %s")
- ("cm" "Cameroon") ; In .fr domain
- ("cn" "China" "The People's Republic of %s")
- ("co" "Colombia")
- ("cr" "Costa Rica" "The Republic of %s")
- ("cu" "Cuba")
- ("cv" "Cape Verde")
- ("cx" "Christmas Island")
- ("cy" "Cyprus")
- ("cz" "Czech Republic")
- ("de" "Germany")
- ("dj" "Djibouti")
- ("dk" "Denmark")
- ("dm" "Dominica")
- ("do" "Dominican Republic" "The %s")
- ("dz" "Algeria")
- ("ec" "Ecuador" "The Republic of %s")
- ("ee" "Estonia")
- ("eg" "Egypt" "The Arab Republic of %s")
- ("eh" "Western Sahara")
- ("er" "Eritrea")
- ("es" "Spain" "The Kingdom of %s")
- ("et" "Ethiopia")
- ("eu" "European Union")
- ("fi" "Finland" "The Republic of %s")
- ("fj" "Fiji")
- ("fk" "Falkland Islands (Malvinas)")
- ("fm" "Micronesia" "Federated States of %s")
- ("fo" "Faroe Islands")
- ("fr" "France")
- ("ga" "Gabon")
- ("gb" "United Kingdom")
- ("gd" "Grenada")
- ("ge" "Georgia")
- ("gf" "French Guiana")
- ("gg" "Guernsey")
- ("gh" "Ghana")
- ("gi" "Gibraltar")
- ("gl" "Greenland")
- ("gm" "Gambia")
- ("gn" "Guinea")
- ("gp" "Guadeloupe (Fr.)")
- ("gq" "Equatorial Guinea")
- ("gr" "Greece" "The Hellenic Republic (%s)")
- ("gs" "South Georgia and The South Sandwich Islands")
- ("gt" "Guatemala")
- ("gu" "Guam (U.S.)")
- ("gw" "Guinea-Bissau")
- ("gy" "Guyana")
- ("hk" "Hong Kong")
- ("hm" "Heard Island and McDonald Islands")
- ("hn" "Honduras")
- ("hr" "Croatia" "Croatia (Hrvatska)")
- ("ht" "Haiti")
- ("hu" "Hungary" "The Hungarian Republic")
- ("id" "Indonesia")
- ("ie" "Ireland")
- ("il" "Israel" "The State of %s")
- ("im" "Isle of Man" "The %s") ; NOT in ISO 3166-1 of 2001-02-26
- ("in" "India" "The Republic of %s")
- ("io" "British Indian Ocean Territory")
- ("iq" "Iraq")
- ("ir" "Iran" "Islamic Republic of %s")
- ("is" "Iceland" "The Republic of %s")
- ("it" "Italy" "The Italian Republic")
- ("je" "Jersey")
- ("jm" "Jamaica")
- ("jo" "Jordan")
- ("jp" "Japan")
- ("ke" "Kenya")
- ("kg" "Kyrgyzstan")
- ("kh" "Cambodia")
- ("ki" "Kiribati")
- ("km" "Comoros")
- ("kn" "Saint Kitts and Nevis")
- ("kp" "Korea (North)" "Democratic People's Republic of Korea")
- ("kr" "Korea (South)" "Republic of Korea")
- ("kw" "Kuwait")
- ("ky" "Cayman Islands")
- ("kz" "Kazakhstan")
- ("la" "Lao People's Democratic Republic")
- ("lb" "Lebanon")
- ("lc" "Saint Lucia")
- ("li" "Liechtenstein")
- ("lk" "Sri Lanka" "The Democratic Socialist Republic of %s")
- ("lr" "Liberia")
- ("ls" "Lesotho")
- ("lt" "Lithuania")
- ("lu" "Luxembourg")
- ("lv" "Latvia")
- ("ly" "Libyan Arab Jamahiriya")
- ("ma" "Morocco")
- ("mc" "Monaco")
- ("md" "Moldova" "The Republic of %s")
- ("me" "Montenegro")
- ("mf" "Saint Martin (French part)")
- ("mg" "Madagascar")
- ("mh" "Marshall Islands")
- ("mk" "Macedonia" "The Former Yugoslav Republic of %s")
- ("ml" "Mali")
- ("mm" "Myanmar")
- ("mn" "Mongolia")
- ("mo" "Macao")
- ("mp" "Northern Mariana Islands")
- ("mq" "Martinique")
- ("mr" "Mauritania")
- ("ms" "Montserrat")
- ("mt" "Malta")
- ("mu" "Mauritius")
- ("mv" "Maldives")
- ("mw" "Malawi")
- ("mx" "Mexico" "The United Mexican States")
- ("my" "Malaysia")
- ("mz" "Mozambique")
- ("na" "Namibia")
- ("nc" "New Caledonia (Fr.)")
- ("ne" "Niger") ; In .fr domain
- ("nf" "Norfolk Island")
- ("ng" "Nigeria")
- ("ni" "Nicaragua" "The Republic of %s")
- ("nl" "Netherlands" "The Kingdom of the %s")
- ("no" "Norway" "The Kingdom of %s")
- ("np" "Nepal") ; Via .in domain
- ("nr" "Nauru")
- ("nu" "Niue")
- ("nz" "New Zealand")
- ("om" "Oman")
- ("pa" "Panama")
- ("pe" "Peru")
- ("pf" "French Polynesia")
- ("pg" "Papua New Guinea")
- ("ph" "Philippines" "The Republic of the %s")
- ("pk" "Pakistan")
- ("pl" "Poland")
- ("pm" "Saint Pierre and Miquelon")
- ("pn" "Pitcairn")
- ("pr" "Puerto Rico (U.S.)")
- ("ps" "Palestinian Territory, Occupied")
- ("pt" "Portugal" "The Portuguese Republic")
- ("pw" "Palau")
- ("py" "Paraguay")
- ("qa" "Qatar")
- ("re" "Reunion (Fr.)") ; In .fr domain
- ("ro" "Romania")
- ("rs" "Serbia")
- ("ru" "Russia" "Russian Federation")
- ("rw" "Rwanda")
- ("sa" "Saudi Arabia")
- ("sb" "Solomon Islands")
- ("sc" "Seychelles")
- ("sd" "Sudan")
- ("se" "Sweden" "The Kingdom of %s")
- ("sg" "Singapore" "The Republic of %s")
- ("sh" "Saint Helena")
- ("si" "Slovenia")
- ("sj" "Svalbard and Jan Mayen") ; In .no domain
- ("sk" "Slovakia" "The Slovak Republic")
- ("sl" "Sierra Leone")
- ("sm" "San Marino")
- ("sn" "Senegal")
- ("so" "Somalia")
- ("sr" "Suriname")
- ("st" "Sao Tome and Principe")
- ("su" "U.S.S.R." "The Union of Soviet Socialist Republics")
- ("sv" "El Salvador")
- ("sy" "Syrian Arab Republic")
- ("sz" "Swaziland")
- ("tc" "Turks and Caicos Islands")
- ("td" "Chad")
- ("tf" "French Southern Territories")
- ("tg" "Togo")
- ("th" "Thailand" "The Kingdom of %s")
- ("tj" "Tajikistan")
- ("tk" "Tokelau")
- ("tl" "East Timor")
- ("tm" "Turkmenistan")
- ("tn" "Tunisia")
- ("to" "Tonga")
- ("tp" "East Timor")
- ("tr" "Turkey" "The Republic of %s")
- ("tt" "Trinidad and Tobago")
- ("tv" "Tuvalu")
- ("tw" "Taiwan" "%s, Province of China")
- ("tz" "Tanzania" "United Republic of %s")
- ("ua" "Ukraine")
- ("ug" "Uganda")
- ("uk" "United Kingdom" "The %s of Great Britain and Northern Ireland")
- ("um" "United States Minor Outlying Islands")
- ("us" "United States" "The %s of America")
- ("uy" "Uruguay" "The Eastern Republic of %s")
- ("uz" "Uzbekistan")
- ("va" "Holy See (Vatican City State)")
- ("vc" "Saint Vincent and the Grenadines")
- ("ve" "Venezuela" "The Republic of %s")
- ("vg" "Virgin Islands, British")
- ("vi" "Virgin Islands, U.S.")
- ("vn" "Vietnam")
- ("vu" "Vanuatu")
- ("wf" "Wallis and Futuna")
- ("ws" "Samoa")
- ("ye" "Yemen")
- ("yt" "Mayotte")
- ("yu" "Yugoslavia" "Yugoslavia, AKA Serbia-Montenegro")
- ("za" "South Africa" "The Republic of %s")
- ("zm" "Zambia")
- ("zw" "Zimbabwe" "Republic of %s")
- ;; Generic Domains:
- ("aero" t "Air Transport Industry")
- ("asia" t "Pan-Asia and Asia Pacific community")
- ("biz" t "Businesses")
- ("cat" t "Catalan language and culture")
- ("com" t "Commercial")
- ("coop" t "Cooperative Associations")
- ("info" t "Info")
- ("jobs" t "Employment")
- ("mobi" t "Mobile products")
- ("museum" t "Museums")
- ("name" t "Individuals")
- ("net" t "Network")
- ("org" t "Non-profit Organization")
- ("pro" t "Credentialed professionals")
- ("tel" t "Contact data")
- ("travel" t "Travel industry")
- ;;("bitnet" t "Because It's Time NET")
- ("gov" t "United States Government")
- ("edu" t "Educational")
- ("mil" t "United States Military")
- ("int" t "International Treaties")
- ;;("nato" t "North Atlantic Treaty Organization")
- ("uucp" t "Unix to Unix CoPy")
- ;; Infrastructure Domains:
- ("arpa" t "Advanced Research Projects Agency (U.S. DoD)")
- ))
- ob))
-
+ ((macro
+ . (lambda (&rest details)
+ (let ((ob (make-hash-table :test 'equal)))
+ (mapc
+ (lambda (x)
+ (puthash (downcase (car x)) (if (find ?% (nth 2 x))
+ (format (nth 2 x) (nth 1 x))
+ (nth 1 x))
+ ob))
+ details)
+ ob)))
+ ;; ISO 3166 codes:
+ ("ac" "Ascension Island")
+ ("ad" "Andorra")
+ ("ae" "United Arab Emirates")
+ ("af" "Afghanistan")
+ ("ag" "Antigua and Barbuda")
+ ("ai" "Anguilla")
+ ("al" "Albania")
+ ("am" "Armenia")
+ ("an" "Netherlands Antilles")
+ ("ao" "Angola")
+ ("aq" "Antarctica") ; continent
+ ("ar" "Argentina" "Argentine Republic")
+ ("as" "American Samoa")
+ ("at" "Austria" "The Republic of %s")
+ ("au" "Australia")
+ ("aw" "Aruba")
+ ("ax" "Aland Islands")
+ ("az" "Azerbaijan")
+ ("ba" "Bosnia-Herzegovina")
+ ("bb" "Barbados")
+ ("bd" "Bangladesh")
+ ("be" "Belgium" "The Kingdom of %s")
+ ("bf" "Burkina Faso")
+ ("bg" "Bulgaria")
+ ("bh" "Bahrain")
+ ("bi" "Burundi")
+ ("bj" "Benin")
+ ("bl" "Saint Barthelemy")
+ ("bm" "Bermuda")
+ ("bn" "Brunei Darussalam")
+ ("bo" "Bolivia" "Republic of %s")
+ ("br" "Brazil" "The Federative Republic of %s")
+ ("bs" "Bahamas")
+ ("bt" "Bhutan")
+ ("bv" "Bouvet Island")
+ ("bw" "Botswana")
+ ("by" "Belarus")
+ ("bz" "Belize")
+ ("ca" "Canada")
+ ("cc" "Cocos (Keeling) Islands")
+ ("cd" "Congo" "The Democratic Republic of the %s")
+ ("cf" "Central African Republic")
+ ("cg" "Congo")
+ ("ch" "Switzerland" "The Swiss Confederation")
+ ("ci" "Ivory Coast") ; Cote D'ivoire
+ ("ck" "Cook Islands")
+ ("cl" "Chile" "The Republic of %s")
+ ("cm" "Cameroon") ; In .fr domain
+ ("cn" "China" "The People's Republic of %s")
+ ("co" "Colombia")
+ ("cr" "Costa Rica" "The Republic of %s")
+ ("cu" "Cuba")
+ ("cv" "Cape Verde")
+ ("cx" "Christmas Island")
+ ("cy" "Cyprus")
+ ("cz" "Czech Republic")
+ ("de" "Germany")
+ ("dj" "Djibouti")
+ ("dk" "Denmark")
+ ("dm" "Dominica")
+ ("do" "Dominican Republic" "The %s")
+ ("dz" "Algeria")
+ ("ec" "Ecuador" "The Republic of %s")
+ ("ee" "Estonia")
+ ("eg" "Egypt" "The Arab Republic of %s")
+ ("eh" "Western Sahara")
+ ("er" "Eritrea")
+ ("es" "Spain" "The Kingdom of %s")
+ ("et" "Ethiopia")
+ ("eu" "European Union")
+ ("fi" "Finland" "The Republic of %s")
+ ("fj" "Fiji")
+ ("fk" "Falkland Islands (Malvinas)")
+ ("fm" "Micronesia" "Federated States of %s")
+ ("fo" "Faroe Islands")
+ ("fr" "France")
+ ("ga" "Gabon")
+ ("gb" "United Kingdom")
+ ("gd" "Grenada")
+ ("ge" "Georgia")
+ ("gf" "French Guiana")
+ ("gg" "Guernsey")
+ ("gh" "Ghana")
+ ("gi" "Gibraltar")
+ ("gl" "Greenland")
+ ("gm" "Gambia")
+ ("gn" "Guinea")
+ ("gp" "Guadeloupe (Fr.)")
+ ("gq" "Equatorial Guinea")
+ ("gr" "Greece" "The Hellenic Republic (%s)")
+ ("gs" "South Georgia and The South Sandwich Islands")
+ ("gt" "Guatemala")
+ ("gu" "Guam (U.S.)")
+ ("gw" "Guinea-Bissau")
+ ("gy" "Guyana")
+ ("hk" "Hong Kong")
+ ("hm" "Heard Island and McDonald Islands")
+ ("hn" "Honduras")
+ ("hr" "Croatia" "Croatia (Hrvatska)")
+ ("ht" "Haiti")
+ ("hu" "Hungary" "The Hungarian Republic")
+ ("id" "Indonesia")
+ ("ie" "Ireland")
+ ("il" "Israel" "The State of %s")
+ ("im" "Isle of Man" "The %s") ; NOT in ISO 3166-1 of 2001-02-26
+ ("in" "India" "The Republic of %s")
+ ("io" "British Indian Ocean Territory")
+ ("iq" "Iraq")
+ ("ir" "Iran" "Islamic Republic of %s")
+ ("is" "Iceland" "The Republic of %s")
+ ("it" "Italy" "The Italian Republic")
+ ("je" "Jersey")
+ ("jm" "Jamaica")
+ ("jo" "Jordan")
+ ("jp" "Japan")
+ ("ke" "Kenya")
+ ("kg" "Kyrgyzstan")
+ ("kh" "Cambodia")
+ ("ki" "Kiribati")
+ ("km" "Comoros")
+ ("kn" "Saint Kitts and Nevis")
+ ("kp" "Korea (North)" "Democratic People's Republic of Korea")
+ ("kr" "Korea (South)" "Republic of Korea")
+ ("kw" "Kuwait")
+ ("ky" "Cayman Islands")
+ ("kz" "Kazakhstan")
+ ("la" "Lao People's Democratic Republic")
+ ("lb" "Lebanon")
+ ("lc" "Saint Lucia")
+ ("li" "Liechtenstein")
+ ("lk" "Sri Lanka" "The Democratic Socialist Republic of %s")
+ ("lr" "Liberia")
+ ("ls" "Lesotho")
+ ("lt" "Lithuania")
+ ("lu" "Luxembourg")
+ ("lv" "Latvia")
+ ("ly" "Libyan Arab Jamahiriya")
+ ("ma" "Morocco")
+ ("mc" "Monaco")
+ ("md" "Moldova" "The Republic of %s")
+ ("me" "Montenegro")
+ ("mf" "Saint Martin (French part)")
+ ("mg" "Madagascar")
+ ("mh" "Marshall Islands")
+ ("mk" "Macedonia" "The Former Yugoslav Republic of %s")
+ ("ml" "Mali")
+ ("mm" "Myanmar")
+ ("mn" "Mongolia")
+ ("mo" "Macao")
+ ("mp" "Northern Mariana Islands")
+ ("mq" "Martinique")
+ ("mr" "Mauritania")
+ ("ms" "Montserrat")
+ ("mt" "Malta")
+ ("mu" "Mauritius")
+ ("mv" "Maldives")
+ ("mw" "Malawi")
+ ("mx" "Mexico" "The United Mexican States")
+ ("my" "Malaysia")
+ ("mz" "Mozambique")
+ ("na" "Namibia")
+ ("nc" "New Caledonia (Fr.)")
+ ("ne" "Niger") ; In .fr domain
+ ("nf" "Norfolk Island")
+ ("ng" "Nigeria")
+ ("ni" "Nicaragua" "The Republic of %s")
+ ("nl" "Netherlands" "The Kingdom of the %s")
+ ("no" "Norway" "The Kingdom of %s")
+ ("np" "Nepal") ; Via .in domain
+ ("nr" "Nauru")
+ ("nu" "Niue")
+ ("nz" "New Zealand")
+ ("om" "Oman")
+ ("pa" "Panama")
+ ("pe" "Peru")
+ ("pf" "French Polynesia")
+ ("pg" "Papua New Guinea")
+ ("ph" "Philippines" "The Republic of the %s")
+ ("pk" "Pakistan")
+ ("pl" "Poland")
+ ("pm" "Saint Pierre and Miquelon")
+ ("pn" "Pitcairn")
+ ("pr" "Puerto Rico (U.S.)")
+ ("ps" "Palestinian Territory, Occupied")
+ ("pt" "Portugal" "The Portuguese Republic")
+ ("pw" "Palau")
+ ("py" "Paraguay")
+ ("qa" "Qatar")
+ ("re" "Reunion (Fr.)") ; In .fr domain
+ ("ro" "Romania")
+ ("rs" "Serbia")
+ ("ru" "Russia" "Russian Federation")
+ ("rw" "Rwanda")
+ ("sa" "Saudi Arabia")
+ ("sb" "Solomon Islands")
+ ("sc" "Seychelles")
+ ("sd" "Sudan")
+ ("se" "Sweden" "The Kingdom of %s")
+ ("sg" "Singapore" "The Republic of %s")
+ ("sh" "Saint Helena")
+ ("si" "Slovenia")
+ ("sj" "Svalbard and Jan Mayen") ; In .no domain
+ ("sk" "Slovakia" "The Slovak Republic")
+ ("sl" "Sierra Leone")
+ ("sm" "San Marino")
+ ("sn" "Senegal")
+ ("so" "Somalia")
+ ("sr" "Suriname")
+ ("st" "Sao Tome and Principe")
+ ("su" "U.S.S.R." "The Union of Soviet Socialist Republics")
+ ("sv" "El Salvador")
+ ("sy" "Syrian Arab Republic")
+ ("sz" "Swaziland")
+ ("tc" "Turks and Caicos Islands")
+ ("td" "Chad")
+ ("tf" "French Southern Territories")
+ ("tg" "Togo")
+ ("th" "Thailand" "The Kingdom of %s")
+ ("tj" "Tajikistan")
+ ("tk" "Tokelau")
+ ("tl" "East Timor")
+ ("tm" "Turkmenistan")
+ ("tn" "Tunisia")
+ ("to" "Tonga")
+ ("tp" "East Timor")
+ ("tr" "Turkey" "The Republic of %s")
+ ("tt" "Trinidad and Tobago")
+ ("tv" "Tuvalu")
+ ("tw" "Taiwan" "%s, Province of China")
+ ("tz" "Tanzania" "United Republic of %s")
+ ("ua" "Ukraine")
+ ("ug" "Uganda")
+ ("uk" "United Kingdom" "The %s of Great Britain and Northern Ireland")
+ ("um" "United States Minor Outlying Islands")
+ ("us" "United States" "The %s of America")
+ ("uy" "Uruguay" "The Eastern Republic of %s")
+ ("uz" "Uzbekistan")
+ ("va" "Holy See (Vatican City State)")
+ ("vc" "Saint Vincent and the Grenadines")
+ ("ve" "Venezuela" "The Republic of %s")
+ ("vg" "Virgin Islands, British")
+ ("vi" "Virgin Islands, U.S.")
+ ("vn" "Vietnam")
+ ("vu" "Vanuatu")
+ ("wf" "Wallis and Futuna")
+ ("ws" "Samoa")
+ ("ye" "Yemen")
+ ("yt" "Mayotte")
+ ("yu" "Yugoslavia" "Yugoslavia, AKA Serbia-Montenegro")
+ ("za" "South Africa" "The Republic of %s")
+ ("zm" "Zambia")
+ ("zw" "Zimbabwe" "Republic of %s")
+ ;; Generic Domains:
+ ("aero" "Air Transport Industry")
+ ("asia" "Pan-Asia and Asia Pacific community")
+ ("biz" "Businesses")
+ ("cat" "Catalan language and culture")
+ ("com" "Commercial")
+ ("coop" "Cooperative Associations")
+ ("info" "Info")
+ ("jobs" "Employment")
+ ("mobi" "Mobile products")
+ ("museum" "Museums")
+ ("name" "Individuals")
+ ("net" "Network")
+ ("org" "Non-profit Organization")
+ ("pro" "Credentialed professionals")
+ ("tel" "Contact data")
+ ("travel" "Travel industry")
+ ;;("bitnet" "Because It's Time NET")
+ ("gov" "United States Government")
+ ("edu" "Educational")
+ ("mil" "United States Military")
+ ("int" "International Treaties")
+ ;;("nato" "North Atlantic Treaty Organization")
+ ("uucp" "Unix to Unix CoPy")
+ ;; Infrastructure Domains:
+ ("arpa" "Advanced Research Projects Agency (U.S. DoD)")))
+
;;;###autoload
(defun what-domain (domain)
"Convert mail domain DOMAIN to the country it corresponds to."
(interactive
- (let ((completion-ignore-case t))
- (list (completing-read "Domain: "
- mail-extr-all-top-level-domains nil t))))
- (or (setq domain (intern-soft (downcase domain)
- mail-extr-all-top-level-domains))
- (error "No such domain"))
- (message "%s: %s" (upcase (symbol-name domain)) (get domain 'domain-name)))
+ (let ((completion-ignore-case t)
+ (table (if (fboundp 'exact-minibuffer-completion-p)
+ ;; XEmacs 21.4. Kludge; cons up a table at completion
+ ;; time. This is fine, #'what-domain isn't called
+ ;; interactively that often.
+ (let (alist)
+ (maphash #'(lambda (key value) (push (cons key t) alist))
+ mail-extr-all-top-level-domains)
+ alist)
+ mail-extr-all-top-level-domains)))
+ (list (completing-read "Domain: " table nil t))))
+ (let ((value (gethash (downcase domain) mail-extr-all-top-level-domains)))
+ (or value (error "No such domain"))
+ (message "%s: %s" (upcase domain) value)))
;(let ((all nil))
--
‘As I sat looking up at the Guinness ad, I could never figure out /
How your man stayed up on the surfboard after forty pints of stout’
(C. Moore)
- 1 participants
- 0 comments
[COMMIT mail-lib] Sync with current GNU version of mail-extr.el
7 years, 6 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1490215414 0
# Wed Mar 22 20:43:34 2017 +0000
# Node ID 7c59d90e8c3957eb3dc3ac85e732c42ac448ed1f
# Parent 93e16a72245c5ed1f649b92b905c117bec1e35fc
Sync with current GNU version of mail-extr.el
2017-03-22 Aidan Kehoe <kehoea(a)parhasard.net>
* mail-extr.el:
* mail-extr.el (if):
* mail-extr.el (mail-extr-guess-middle-initial):
* mail-extr.el (mail-extr-ignore-single-names):
* mail-extr.el (mail-extr-ignore-realname-equals-mailbox-name): New.
* mail-extr.el (mail-extr-full-name-prefixes):
* mail-extr.el (mail-extr-＠-binds-tighter-than-!):
* mail-extr.el (mail-extr-mangle-uucp):
* mail-extr.el (mail-extr-all-letters-but-separators):
* mail-extr.el (mail-extr-first-letters):
* mail-extr.el (mail-extr-last-letters): Removed.
* mail-extr.el (mail-extr-last-letter): New.
* mail-extr.el (mail-extr-hz-embedded-gb-encoded-chinese-pattern):
* mail-extr.el (lambda):
* mail-extr.el (mailextr-cbeg):
* mail-extr.el (cbeg): Removed.
* mail-extr.el (cend): Removed.
* mail-extr.el (mailextr-cbeg): New.
* mail-extr.el (mailextr-cend): New.
* mail-extr.el (mail-extr-all-top-level-domains)): New.
* mail-extr.el (mail-extract-address-components):
* mail-extr.el (mail-extr-voodoo):
* mail-extr.el (mail-extr-disable-voodoo): New.
* mail-extr.el (mail-extr-all-top-level-domains):
Sync with current GNU version of this file.
diff -r 93e16a72245c -r 7c59d90e8c39 ChangeLog
--- a/ChangeLog Sun Nov 20 22:02:17 2016 +0000
+++ b/ChangeLog Wed Mar 22 20:43:34 2017 +0000
＠＠ -1,3 +1,31 ＠＠
+2017-03-22 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * mail-extr.el:
+ * mail-extr.el (if):
+ * mail-extr.el (mail-extr-guess-middle-initial):
+ * mail-extr.el (mail-extr-ignore-single-names):
+ * mail-extr.el (mail-extr-ignore-realname-equals-mailbox-name): New.
+ * mail-extr.el (mail-extr-full-name-prefixes):
+ * mail-extr.el (mail-extr-＠-binds-tighter-than-!):
+ * mail-extr.el (mail-extr-mangle-uucp):
+ * mail-extr.el (mail-extr-all-letters-but-separators):
+ * mail-extr.el (mail-extr-first-letters):
+ * mail-extr.el (mail-extr-last-letters): Removed.
+ * mail-extr.el (mail-extr-last-letter): New.
+ * mail-extr.el (mail-extr-hz-embedded-gb-encoded-chinese-pattern):
+ * mail-extr.el (lambda):
+ * mail-extr.el (mailextr-cbeg):
+ * mail-extr.el (cbeg): Removed.
+ * mail-extr.el (cend): Removed.
+ * mail-extr.el (mailextr-cbeg): New.
+ * mail-extr.el (mailextr-cend): New.
+ * mail-extr.el (mail-extr-all-top-level-domains)): New.
+ * mail-extr.el (mail-extract-address-components):
+ * mail-extr.el (mail-extr-voodoo):
+ * mail-extr.el (mail-extr-disable-voodoo): New.
+ * mail-extr.el (mail-extr-all-top-level-domains):
+ Sync with current GNU version of this file.
+
2016-11-20 Aidan Kehoe <kehoea(a)parhasard.net>
* mail-abbrevs.el (mail-aliases-setup):
diff -r 93e16a72245c -r 7c59d90e8c39 mail-extr.el
--- a/mail-extr.el Sun Nov 20 22:02:17 2016 +0000
+++ b/mail-extr.el Wed Mar 22 20:43:34 2017 +0000
＠＠ -1,30 +1,27 ＠＠
;;; mail-extr.el --- extract full name and address from RFC 822 mail header
-;; Copyright (C) 1991, 1992, 1993, 1994, 1997, 2001
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1991-1994, 1997, 2001-2017 Free Software Foundation,
+;; Inc.
;; Author: Joe Wells <jbw(a)cs.bu.edu>
-;; Maintainer: FSF
+;; Maintainer: emacs-devel(a)gnu.org
;; Keywords: mail
-
-;; This file is part of XEmacs.
+;; Package: mail-utils
-;; XEmacs is free software; you can redistribute it and/or modify
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
-;; XEmacs is distributed in the hope that it will be useful,
+;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with XEmacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Synched up with: Emacs 21.3 CVS as of 2004-06-10.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
＠＠ -211,6 +208,10 ＠＠
;;; Code:
+(eval-and-compile
+ (if (featurep 'xemacs) ;; Purespace obsolete in XEmacs.
+ (define-compiler-macro purecopy (&whole form argument) argument)))
+
(defgroup mail-extr nil
"Extract full name and address from RFC 822 mail header."
:prefix "mail-extr-"
＠＠ -222,17 +223,25 ＠＠
;;
(defcustom mail-extr-guess-middle-initial nil
- "*Whether to try to guess middle initial from mail address.
+ "Whether to try to guess middle initial from mail address.
If true, then when we see an address like \"John Smith <jqs(a)host.com>\"
we will assume that \"John Q. Smith\" is the fellow's name."
:type 'boolean
:group 'mail-extr)
(defcustom mail-extr-ignore-single-names nil
- "*Whether to ignore a name that is just a single word.
+ "Whether to ignore a name that is just a single word.
If true, then when we see an address like \"Idiot <dumb(a)stupid.com>\"
we will act as though we couldn't find a full name in the address."
:type 'boolean
+ :version "22.1"
+ :group 'mail-extr)
+
+(defcustom mail-extr-ignore-realname-equals-mailbox-name t
+"Whether to ignore a name that is equal to the mailbox name.
+If true, then when the address is like \"Single <single(a)address.com>\"
+we will act as though we couldn't find a full name in the address."
+ :type 'boolean
:group 'mail-extr)
;; Matches a leading title that is not part of the name (does not
＠＠ -240,19 +249,19 ＠＠
(defcustom mail-extr-full-name-prefixes
(purecopy
"\\(Prof\\|D[Rr]\\|Mrs?\\|Rev\\|Rabbi\\|SysOp\\|LCDR\\)\\.?[ \t\n]")
- "*Matches prefixes to the full name that identify a person's position.
+ "Matches prefixes to the full name that identify a person's position.
These are stripped from the full name because they do not contribute to
uniquely identifying the person."
:type 'regexp
:group 'mail-extr)
(defcustom mail-extr-＠-binds-tighter-than-! nil
- "*Whether the local mail transport agent looks at ! before ＠."
+ "Whether the local mail transport agent looks at ! before ＠."
:type 'boolean
:group 'mail-extr)
(defcustom mail-extr-mangle-uucp nil
- "*Whether to throw away information in UUCP addresses
+ "Whether to throw away information in UUCP addresses
by translating things like \"foo!bar!baz＠host\" into \"baz(a)bar.UUCP\"."
:type 'boolean
:group 'mail-extr)
＠＠ -280,9 +289,11 ＠＠
;; Yes, there are weird people with digits in their names.
;; You will also notice the consideration for the
;; Swedish/Finnish/Norwegian character set.
-;; XEmacs: Add \200-\376 range (not \377 due to bug (?) in search.c...).
(defconst mail-extr-all-letters-but-separators
- (purecopy "][A-Za-z{|}'~0-9`\200-\376")) ;; XEmacs
+ (if (string-match "[[:alnum:]]" "z")
+ (purecopy "][[:alnum:]{|}'~`")
+ ;; XEmacs; support builds without [:alnum:]
+ "][A-Za-z{|}'~0-9`\200-\376"))
;; Any character that can occur in a name in an RFC822 address including
;; the separator (hyphen and possibly period) for multipart names.
＠＠ -292,11 +303,16 ＠＠
;; Any character that can start a name.
;; Keep this set as minimal as possible.
-(defconst mail-extr-first-letters (purecopy "A-Za-z")) ;; XEmacs
+(defconst mail-extr-first-letters (if (string-match "[[:alpha:]]" "z")
+ ;; XEmacs; see above.
+ (purecopy "[:alpha:]")
+ "A-Za-z"))
;; Any character that can end a name.
;; Keep this set as minimal as possible.
-(defconst mail-extr-last-letters (purecopy "[A-Za-z`'.")) ;; XEmacs
+(defconst mail-extr-last-letters (if (string-match "[[:alpha:]]" "z")
+ (purecopy "[:alpha:]`'.")
+ (purecopy "[A-Za-z]`'."))) ;; XEmacs
(defconst mail-extr-leading-garbage "\\W+")
＠＠ -325,7 +341,7 ＠＠
;; Matches an embedded or leading nickname that should be removed.
;; (defconst mail-extr-nickname-pattern
;; (purecopy
-;; (format "\\([ .]\\|\\`\\)[\"'`\[\(]\\([ .%s]+\\)[\]\"'\)] "
+;; (format "\\([ .]\\|\\`\\)[\"'`[(]\\([ .%s]+\\)[]\"')] "
;; mail-extr-all-letters)))
;; Matches the occurrence of a generational name suffix, and the last
＠＠ -391,7 +407,7 ＠＠
;; Matches ham radio call signs.
;; Help from: Mat Maessen N2NJZ <maessm(a)rpi.edu>, Mark Feit
;; <mark(a)era.com>, Michael Covington <mcovingt(a)ai.uga.edu>.
-;; Examples: DX504 DX515 K5MRU K8DHK KA9WGN KA9WGN KD3FU KD6EUI KD6HBW
+;; Examples: DX504 DX515 K5MRU K8DHK KA9WGN KD3FU KD6EUI KD6HBW
;; KE9TV KF0NV N1API N3FU N3GZE N3IGS N4KCC N7IKQ N9HHU W4YHF W6ANK WA2SUH
;; WB7VZI N2NJZ NR3G KJ4KK AB4UM AL7NI KH6OH WN3KBT N4TMI W1A N0NZO
(defconst mail-extr-ham-call-sign-pattern
＠＠ -452,7 +468,7 ＠＠
;; mode from GB back to ASCII. (Note that the escape-from-GB code '~}'
;; ($7E7D) is outside the defined GB range.)
(defconst mail-extr-hz-embedded-gb-encoded-chinese-pattern
- (purecopy "~{\\([^~].\\|~[^\}]\\)+~}"))
+ (purecopy "~{\\([^~].\\|~[^}]\\)+~}"))
;; The leading optional lowercase letters are for a bastardized version of
;; the encoding, as is the optional nature of the final slash.
＠＠ -539,8 +555,8 ＠＠
(?\t " ")
(?\r " ")
(?\n " ")
- (?\( "\(\)")
- (?\) "\)\(")
+ (?\( "()")
+ (?\) ")(")
(?\\ "\\"))
(mail-extr-address-domain-literal-syntax-table
(?\000 ?\377 "w")
＠＠ -549,8 +565,8 ＠＠
(?\t " ")
(?\r " ")
(?\n " ")
- (?\[ "\(\]") ;??????
- (?\] "\)\[") ;??????
+ (?\[ "(]") ;??????
+ (?\] ")[") ;??????
(?\\ "\\"))
(mail-extr-address-text-comment-syntax-table
(?\000 ?\377 "w")
＠＠ -559,16 +575,16 ＠＠
(?\t " ")
(?\r " ")
(?\n " ")
- (?\( "\(\)")
- (?\) "\)\(")
- (?\[ "\(\]")
- (?\] "\)\[")
- (?\{ "\(\}")
- (?\} "\)\{")
+ (?\( "()")
+ (?\) ")(")
+ (?\[ "(]")
+ (?\] ")[")
+ (?\{ "(}")
+ (?\} "){")
(?\\ "\\")
(?\" "\"")
- ;; (?\' "\)\`")
- ;; (?\` "\(\'")
+ ;; (?\' ")`")
+ ;; (?\` "('")
)
(mail-extr-address-text-syntax-table
(?\000 ?\177 ".")
＠＠ -687,15 +703,17 ＠＠
;;
(defvar disable-initial-guessing-flag) ; dynamic assignment
-(defvar cbeg) ; dynamic assignment
-(defvar cend) ; dynamic assignment
+(defvar mailextr-cbeg) ; dynamic assignment
+(defvar mailextr-cend) ; dynamic assignment
+(defvar mail-extr-all-top-level-domains) ; Defined below.
;;;###autoload
(defun mail-extract-address-components (address &optional all)
"Given an RFC-822 address ADDRESS, extract full name and canonical address.
-Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
-If no name can be extracted, FULL-NAME will be nil. Also see
-`mail-extr-ignore-single-names'.
+Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). If no
+name can be extracted, FULL-NAME will be nil. Also see
+`mail-extr-ignore-single-names' and
+`mail-extr-ignore-realname-equals-mailbox-name'.
If the optional argument ALL is non-nil, then ADDRESS can contain zero
or more recipients, separated by commas, and we return a list of
＠＠ -756,7 +774,8 ＠＠
record-pos-symbol
first-real-pos last-real-pos
phrase-beg phrase-end
- cbeg cend ; dynamically set from -voodoo
+ ;; Dynamically set in mail-extr-voodoo.
+ mailextr-cbeg mailextr-cend
quote-beg quote-end
atom-beg atom-end
mbox-beg mbox-end
＠＠ -790,19 +809,19 ＠＠
((eq char ?\()
(set-syntax-table mail-extr-address-comment-syntax-table)
;; only record the first non-empty comment's position
- (if (and (not cbeg)
+ (if (and (not mailextr-cbeg)
(save-excursion
(forward-char 1)
(mail-extr-skip-whitespace-forward)
(not (eq ?\) (char-after (point))))))
- (setq cbeg (point)))
+ (setq mailextr-cbeg (point)))
;; TODO: don't record if unbalanced
(or (mail-extr-safe-move-sexp 1)
(forward-char 1))
(set-syntax-table mail-extr-address-syntax-table)
- (if (and cbeg
- (not cend))
- (setq cend (point))))
+ (if (and mailextr-cbeg
+ (not mailextr-cend))
+ (setq mailextr-cend (point))))
;; quoted text
((eq char ?\")
;; only record the first non-empty quote's position
＠＠ -843,7 +862,7 ＠＠
(setq char ?\() ; HAVE I NO SHAME??
)
;; record the position of various interesting chars, determine
- ;; legality later.
+ ;; validity later.
((setq record-pos-symbol
(cdr (assq char
'((?< . <-pos) (?> . >-pos) (?＠ . ＠-pos)
＠＠ -855,9 +874,9 ＠＠
((eq char ?.)
(forward-char 1))
((memq char '(
- ;; comment terminator illegal
+ ;; comment terminator invalid
?\)
- ;; domain literal terminator illegal
+ ;; domain literal terminator invalid
?\]
;; \ allowed only within quoted strings,
;; domain literals, and comments
＠＠ -866,7 +885,17 ＠＠
(mail-extr-nuke-char-at (point))
(forward-char 1))
(t
- (forward-word 1)))
+ ;; Do `(forward-word 1)', recognizing non-ASCII characters
+ ;; except Latin-1 nbsp as words.
+ (while (progn
+ (skip-chars-forward "^\000-\177\240")
+ (and (not (eobp))
+ (eq ?w (char-syntax (char-after)))
+ (progn
+ (forward-word 1) ; (forward-word-strictly 1)
+ (and (not (eobp))
+ (> (char-after) ?\177)
+ (not (eq (char-after) ?\240)))))))))
(or (eq char ?\()
;; At the end of first address of a multiple address header.
(and (eq char ?,)
＠＠ -978,10 +1007,10 ＠＠
(> last-real-pos (1+ group-\;-pos))
(setq last-real-pos (1+ group-\;-pos)))
;; *** This may be wrong:
- (and cend
- (> cend group-\;-pos)
- (setq cend nil
- cbeg nil))
+ (and mailextr-cend
+ (> mailextr-cend group-\;-pos)
+ (setq mailextr-cend nil
+ mailextr-cbeg nil))
(and quote-end
(> quote-end group-\;-pos)
(setq quote-end nil
＠＠ -1212,8 +1241,8 ＠＠
(narrow-to-region phrase-beg phrase-end))
;; Example: fml(a)foo.bar.dom (First M. Last)
- (cbeg
- (narrow-to-region (1+ cbeg) (1- cend))
+ (mailextr-cbeg
+ (narrow-to-region (1+ mailextr-cbeg) (1- mailextr-cend))
(mail-extr-undo-backslash-quoting (point-min) (point-max))
;; Deal with spacing problems
＠＠ -1295,7 +1324,7 ＠＠
)
(t
(setq atom-beg (point))
- (forward-word 1)
+ (forward-word) ; (forward-word-strictly 1)
(setq atom-end (point))
(goto-char atom-beg)
(save-restriction
＠＠ -1389,24 +1418,26 ＠＠
(insert (upcase mi) ". ")))
;; Nuke name if it is the same as mailbox name.
- (let ((buffer-length (- (point-max) (point-min)))
- (i 0)
- (names-match-flag t))
- (when (and (> buffer-length 0)
- (eq buffer-length (- mbox-end mbox-beg)))
- (goto-char (point-max))
- (insert-buffer-substring canonicalization-buffer
- mbox-beg mbox-end)
- (while (and names-match-flag
- (< i buffer-length))
- (or (eq (downcase (char-after (+ i (point-min))))
- (downcase
- (char-after (+ i buffer-length (point-min)))))
- (setq names-match-flag nil))
- (setq i (1+ i)))
- (delete-region (+ (point-min) buffer-length) (point-max))
- (if names-match-flag
- (narrow-to-region (point) (point)))))
+ (when mail-extr-ignore-single-names
+ (let ((buffer-length (- (point-max) (point-min)))
+ (i 0)
+ (names-match-flag t))
+ (when (and (> buffer-length 0)
+ (eq buffer-length (- mbox-end mbox-beg)))
+ (goto-char (point-max))
+ (insert-buffer-substring canonicalization-buffer
+ mbox-beg mbox-end)
+ (while (and names-match-flag
+ (< i buffer-length))
+ (or (eq (downcase (char-after (+ i (point-min))))
+ (downcase
+ (char-after (+ i buffer-length (point-min)))))
+ (setq names-match-flag nil))
+ (setq i (1+ i)))
+ (delete-region (+ (point-min) buffer-length) (point-max))
+ (and names-match-flag
+ mail-extr-ignore-realname-equals-mailbox-name
+ (narrow-to-region (point) (point))))))
;; Nuke name if it's just one word.
(goto-char (point-min))
＠＠ -1436,374 +1467,401 ＠＠
(if all (nreverse value-list) (car value-list))
))
-(defun mail-extr-voodoo (mbox-beg mbox-end canonicalization-buffer)
- (let ((word-count 0)
- (case-fold-search nil)
- mixed-case-flag lower-case-flag ;;upper-case-flag
- suffix-flag last-name-comma-flag
- ;;cbeg cend
- initial
- begin-again-flag
- drop-this-word-if-trailing-flag
- drop-last-word-if-trailing-flag
- word-found-flag
- this-word-beg last-word-beg
- name-beg name-end
- name-done-flag
- )
- (save-excursion
- (set-syntax-table mail-extr-address-text-syntax-table)
-
- ;; Get rid of comments.
- (goto-char (point-min))
- (while (not (eobp))
- ;; Initialize for this iteration of the loop.
- (skip-chars-forward "^({[\"'`")
- (let ((cbeg (point)))
- (set-syntax-table mail-extr-address-text-comment-syntax-table)
- (if (memq (following-char) '(?\' ?\`))
- (search-forward "'" nil 'move
- (if (eq ?\' (following-char)) 2 1))
- (or (mail-extr-safe-move-sexp 1)
- (goto-char (point-max))))
- (set-syntax-table mail-extr-address-text-syntax-table)
- (when (eq (char-after cbeg) ?\()
- ;; Delete the comment itself.
- (delete-region cbeg (point))
- ;; Canonicalize whitespace where the comment was.
- (skip-chars-backward " \t")
- (if (looking-at "\\([ \t]+$\\|[ \t]+,\\)")
- (replace-match "")
- (setq cbeg (point))
- (skip-chars-forward " \t")
- (if (bobp)
- (delete-region (point) cbeg)
- (just-one-space))))))
+(defcustom mail-extr-disable-voodoo "\\cj"
+ "If it is a regexp, names matching it will never be modified.
+If it is neither nil nor a string, modifying of names will never take
+place. It affects how `mail-extract-address-components' works."
+ :type '(choice (regexp :size 0)
+ (const :tag "Always enabled" nil)
+ (const :tag "Always disabled" t))
+ :group 'mail-extr)
- ;; This was moved above.
- ;; Fix . used as space
- ;; But it belongs here because it occurs not only as
- ;; rypens(a)reks.uia.ac.be (Piet.Rypens)
- ;; but also as
- ;; "Piet.Rypens" <rypens(a)reks.uia.ac.be>
- ;;(goto-char (point-min))
- ;;(while (re-search-forward mail-extr-bad-dot-pattern nil t)
- ;; (replace-match "\\1 \\2" t))
-
- (unless (search-forward " " nil t)
- (goto-char (point-min))
- (cond ((search-forward "_" nil t)
- ;; Handle the *idiotic* use of underlines as spaces.
- ;; Example: fml(a)foo.bar.dom (First_M._Last)
- (goto-char (point-min))
- (while (search-forward "_" nil t)
- (replace-match " " t)))
- ((search-forward "." nil t)
- ;; Fix . used as space
- ;; Example: danj1(a)cb.att.com (daniel.jacobson)
- (goto-char (point-min))
- (while (re-search-forward mail-extr-bad-dot-pattern nil t)
- (replace-match "\\1 \\2" t)))))
-
- ;; Loop over the words (and other junk) in the name.
- (goto-char (point-min))
- (while (not name-done-flag)
+(defun mail-extr-voodoo (mbox-beg mbox-end canonicalization-buffer)
+ (unless (and mail-extr-disable-voodoo
+ (or (not (stringp mail-extr-disable-voodoo))
+ (progn
+ (goto-char (point-min))
+ (re-search-forward mail-extr-disable-voodoo nil t))))
+ (let ((word-count 0)
+ (case-fold-search nil)
+ mixed-case-flag lower-case-flag ;;upper-case-flag
+ suffix-flag last-name-comma-flag
+ initial
+ begin-again-flag
+ drop-this-word-if-trailing-flag
+ drop-last-word-if-trailing-flag
+ word-found-flag
+ this-word-beg last-word-beg
+ name-beg name-end
+ name-done-flag
+ )
+ (save-excursion
+ (set-syntax-table mail-extr-address-text-syntax-table)
- (when word-found-flag
- ;; Last time through this loop we skipped over a word.
- (setq last-word-beg this-word-beg)
- (setq drop-last-word-if-trailing-flag
- drop-this-word-if-trailing-flag)
- (setq word-found-flag nil))
+ ;; Get rid of comments.
+ (goto-char (point-min))
+ (while (not (eobp))
+ ;; Initialize for this iteration of the loop.
+ (skip-chars-forward "^({[\"'`")
+ (let ((cbeg (point))) ;; Not used dynamically in this sexp
+ (set-syntax-table mail-extr-address-text-comment-syntax-table)
+ (if (memq (following-char) '(?\' ?\`))
+ (search-forward "'" nil 'move
+ (if (eq ?\' (following-char)) 2 1))
+ (or (mail-extr-safe-move-sexp 1)
+ (goto-char (point-max))))
+ (set-syntax-table mail-extr-address-text-syntax-table)
+ (when (eq (char-after cbeg) ?\()
+ ;; Delete the comment itself.
+ (delete-region cbeg (point))
+ ;; Canonicalize whitespace where the comment was.
+ (skip-chars-backward " \t")
+ (if (looking-at "\\([ \t]+$\\|[ \t]+,\\)")
+ (replace-match "")
+ (setq cbeg (point))
+ (skip-chars-forward " \t")
+ (if (bobp)
+ (delete-region (point) cbeg)
+ (just-one-space))))))
- (when begin-again-flag
- ;; Last time through the loop we found something that
- ;; indicates we should pretend we are beginning again from
- ;; the start.
- (setq word-count 0)
- (setq last-word-beg nil)
- (setq drop-last-word-if-trailing-flag nil)
- (setq mixed-case-flag nil)
- (setq lower-case-flag nil)
- ;; (setq upper-case-flag nil)
- (setq begin-again-flag nil))
+ ;; This was moved above.
+ ;; Fix . used as space
+ ;; But it belongs here because it occurs not only as
+ ;; rypens(a)reks.uia.ac.be (Piet.Rypens)
+ ;; but also as
+ ;; "Piet.Rypens" <rypens(a)reks.uia.ac.be>
+ ;;(goto-char (point-min))
+ ;;(while (re-search-forward mail-extr-bad-dot-pattern nil t)
+ ;; (replace-match "\\1 \\2" t))
- ;; Initialize for this iteration of the loop.
- (mail-extr-skip-whitespace-forward)
- (if (eq word-count 0) (narrow-to-region (point) (point-max)))
- (setq this-word-beg (point))
- (setq drop-this-word-if-trailing-flag nil)
+ (unless (search-forward " " nil t)
+ (goto-char (point-min))
+ (cond ((search-forward "_" nil t)
+ ;; Handle the *idiotic* use of underlines as spaces.
+ ;; Example: fml(a)foo.bar.dom (First_M._Last)
+ (goto-char (point-min))
+ (while (search-forward "_" nil t)
+ (replace-match " " t)))
+ ((search-forward "." nil t)
+ ;; Fix . used as space
+ ;; Example: danj1(a)cb.att.com (daniel.jacobson)
+ (goto-char (point-min))
+ (while (re-search-forward mail-extr-bad-dot-pattern nil t)
+ (replace-match "\\1 \\2" t)))))
- ;; Decide what to do based on what we are looking at.
- (cond
+ ;; Loop over the words (and other junk) in the name.
+ (goto-char (point-min))
+ (while (not name-done-flag)
- ;; Delete title
- ((and (eq word-count 0)
- (looking-at mail-extr-full-name-prefixes))
- (goto-char (match-end 0))
+ (when word-found-flag
+ ;; Last time through this loop we skipped over a word.
+ (setq last-word-beg this-word-beg)
+ (setq drop-last-word-if-trailing-flag
+ drop-this-word-if-trailing-flag)
+ (setq word-found-flag nil))
+
+ (when begin-again-flag
+ ;; Last time through the loop we found something that
+ ;; indicates we should pretend we are beginning again from
+ ;; the start.
+ (setq word-count 0)
+ (setq last-word-beg nil)
+ (setq drop-last-word-if-trailing-flag nil)
+ (setq mixed-case-flag nil)
+ (setq lower-case-flag nil)
+ ;; (setq upper-case-flag nil)
+ (setq begin-again-flag nil))
+
+ ;; Initialize for this iteration of the loop.
+ (mail-extr-skip-whitespace-forward)
+ (if (eq word-count 0) (narrow-to-region (point) (point-max)))
+ (setq this-word-beg (point))
+ (setq drop-this-word-if-trailing-flag nil)
+
+ ;; Decide what to do based on what we are looking at.
+ (cond
+
+ ;; Delete title
+ ((and (eq word-count 0)
+ (looking-at mail-extr-full-name-prefixes))
+ (goto-char (match-end 0))
+ (narrow-to-region (point) (point-max)))
+
+ ;; Stop after name suffix
+ ((and (>= word-count 2)
+ (looking-at mail-extr-full-name-suffix-pattern))
+ (mail-extr-skip-whitespace-backward)
+ (setq suffix-flag (point))
+ (if (eq ?, (following-char))
+ (forward-char 1)
+ (insert ?,))
+ ;; Enforce at least one space after comma
+ (or (eq ?\ (following-char))
+ (insert ?\ ))
+ (mail-extr-skip-whitespace-forward)
+ (cond ((memq (following-char) '(?j ?J ?s ?S))
+ (capitalize-word 1)
+ (if (eq (following-char) ?.)
+ (forward-char 1)
+ (insert ?.)))
+ (t
+ (upcase-word 1)))
+ (setq word-found-flag t)
+ (setq name-done-flag t))
+
+ ;; Handle SCA names
+ ((looking-at "MKA \\(.+\\)") ; "Mundanely Known As"
+ (goto-char (match-beginning 1))
+ (narrow-to-region (point) (point-max))
+ (setq begin-again-flag t))
+
+ ;; Check for initial last name followed by comma
+ ((and (eq ?, (following-char))
+ (eq word-count 1))
+ (forward-char 1)
+ (setq last-name-comma-flag t)
+ (or (eq ?\ (following-char))
+ (insert ?\ )))
+
+ ;; Stop before trailing comma-separated comment
+ ;; THIS CASE MUST BE AFTER THE PRECEDING CASES.
+ ;; *** This case is redundant???
+ ;;((eq ?, (following-char))
+ ;; (setq name-done-flag t))
+
+ ;; Delete parenthesized/quoted comment/nickname
+ ((memq (following-char) '(?\( ?\{ ?\[ ?\" ?\' ?\`))
+ (setq mailextr-cbeg (point))
+ (set-syntax-table mail-extr-address-text-comment-syntax-table)
+ (cond ((memq (following-char) '(?\' ?\`))
+ (or (search-forward "'" nil t
+ (if (eq ?\' (following-char)) 2 1))
+ (delete-char 1)))
+ (t
+ (or (mail-extr-safe-move-sexp 1)
+ (goto-char (point-max)))))
+ (set-syntax-table mail-extr-address-text-syntax-table)
+ (setq mailextr-cend (point))
+ (cond
+ ;; Handle case of entire name being quoted
+ ((and (eq word-count 0)
+ (looking-at " *\\'")
+ (>= (- mailextr-cend mailextr-cbeg) 2))
+ (narrow-to-region (1+ mailextr-cbeg) (1- mailextr-cend))
+ (goto-char (point-min)))
+ (t
+ ;; Handle case of quoted initial
+ (if (and (or (= 3 (- mailextr-cend mailextr-cbeg))
+ (and (= 4 (- mailextr-cend mailextr-cbeg))
+ (eq ?. (char-after (+ 2 mailextr-cbeg)))))
+ (not (looking-at " *\\'")))
+ (setq initial (char-after (1+ mailextr-cbeg)))
+ (setq initial nil))
+ (delete-region mailextr-cbeg mailextr-cend)
+ (if initial
+ (insert initial ". ")))))
+
+ ;; Handle *Stupid* VMS date stamps
+ ((looking-at mail-extr-stupid-vms-date-stamp-pattern)
+ (replace-match "" t))
+
+ ;; Handle Chinese characters.
+ ((looking-at mail-extr-hz-embedded-gb-encoded-chinese-pattern)
+ (goto-char (match-end 0))
+ (setq word-found-flag t))
+
+ ;; Skip initial garbage characters.
+ ;; THIS CASE MUST BE AFTER THE PRECEDING CASES.
+ ((and (eq word-count 0)
+ (looking-at mail-extr-leading-garbage))
+ (goto-char (match-end 0))
+ ;; *** Skip backward over these???
+ ;; (skip-chars-backward "& \"")
+ (narrow-to-region (point) (point-max)))
+
+ ;; Various stopping points
+ ((or
+
+ ;; Stop before ALL CAPS acronyms, if preceded by mixed-case
+ ;; words. Example: XT-DEM.
+ (and (>= word-count 2)
+ mixed-case-flag
+ (looking-at mail-extr-weird-acronym-pattern)
+ (not (looking-at mail-extr-roman-numeral-pattern)))
+
+ ;; Stop before trailing alternative address
+ (looking-at mail-extr-alternative-address-pattern)
+
+ ;; Stop before trailing comment not introduced by comma
+ ;; THIS CASE MUST BE AFTER AN EARLIER CASE.
+ (looking-at mail-extr-trailing-comment-start-pattern)
+
+ ;; Stop before telephone numbers
+ (and (>= word-count 1)
+ (looking-at mail-extr-telephone-extension-pattern)))
+ (setq name-done-flag t))
+
+ ;; Delete ham radio call signs
+ ((looking-at mail-extr-ham-call-sign-pattern)
+ (delete-region (match-beginning 0) (match-end 0)))
+
+ ;; Fixup initials
+ ((looking-at mail-extr-initial-pattern)
+ (or (eq (following-char) (upcase (following-char)))
+ (setq lower-case-flag t))
+ (forward-char 1)
+ (if (eq ?. (following-char))
+ (forward-char 1)
+ (insert ?.))
+ (or (eq ?\ (following-char))
+ (insert ?\ ))
+ (setq word-found-flag t))
+
+ ;; Handle BITNET LISTSERV list names.
+ ((and (eq word-count 0)
+ (looking-at mail-extr-listserv-list-name-pattern))
+ (narrow-to-region (match-beginning 1) (match-end 1))
+ (setq word-found-flag t)
+ (setq name-done-flag t))
+
+ ;; Handle & substitution, when & is last and is not first.
+ ((and (> word-count 0)
+ (eq ?\ (preceding-char))
+ (eq (following-char) ?&)
+ (eq (1+ (point)) (point-max)))
+ (delete-char 1)
+ (capitalize-region
+ (point)
+ (progn
+ (insert-buffer-substring canonicalization-buffer
+ mbox-beg mbox-end)
+ (point)))
+ (setq disable-initial-guessing-flag t)
+ (setq word-found-flag t))
+
+ ;; Handle & between names, as in "Bob & Susie".
+ ((and (> word-count 0) (eq (following-char) ?\&))
+ (setq name-beg (point))
+ (setq name-end (1+ name-beg))
+ (setq word-found-flag t)
+ (goto-char name-end))
+
+ ;; Regular name words
+ ((looking-at mail-extr-name-pattern)
+ (setq name-beg (point))
+ (setq name-end (match-end 0))
+
+ ;; Certain words will be dropped if they are at the end.
+ (and (>= word-count 2)
+ (not lower-case-flag)
+ (or
+ ;; Trailing 4-or-more letter lowercase words preceded by
+ ;; mixed case or uppercase words will be dropped.
+ (looking-at (load-time-value
+ (if (string-match "[[:lower:]]" "z")
+ "[[:lower:]]\\{4,\\}[ \t]*\\'"
+ ;; XEmacs 21.4
+ "[a-z][a-z][a-z][a-z]+[ \t]*\\'")))
+ ;; Drop a trailing word which is terminated with a period.
+ (eq ?. (char-after (1- name-end))))
+ (setq drop-this-word-if-trailing-flag t))
+
+ ;; Set the flags that indicate whether we have seen a lowercase
+ ;; word, a mixed case word, and an uppercase word.
+ (if (re-search-forward
+ (load-time-value (if (string-match "[[:lower:]]" "z")
+ "[[:lower:]]"
+ ;; XEmacs 21.4
+ "[a-z]"))
+ name-end t)
+ (if (progn
+ (goto-char name-beg)
+ (re-search-forward
+ (load-time-value (if (string-match "[[:upper:]]" "Z")
+ "[[:upper:]]"
+ ;; XEmacs 21.4
+ "[A-Z]"))
+ name-end t))
+ (setq mixed-case-flag t)
+ (setq lower-case-flag t))
+ ;; (setq upper-case-flag t)
+ )
+
+ (goto-char name-end)
+ (setq word-found-flag t))
+
+ ;; Allow a number as a word, if it doesn't mean anything else.
+ ((looking-at "[0-9]+\\>")
+ (setq name-beg (point))
+ (setq name-end (match-end 0))
+ (goto-char name-end)
+ (setq word-found-flag t))
+
+ (t
+ (setq name-done-flag t)
+ ))
+
+ ;; Count any word that we skipped over.
+ (if word-found-flag
+ (setq word-count (1+ word-count))))
+
+ ;; If the last thing in the name is 2 or more periods, or one or more
+ ;; other sentence terminators (but not a single period) then keep them
+ ;; and the preceding word. This is for the benefit of whole sentences
+ ;; in the name field: it's better behavior than dropping the last word
+ ;; of the sentence...
+ (if (and (not suffix-flag)
+ (looking-at "\\(\\.+\\|[?!;:.][?!;:.]+\\|[?!;:][?!;:.]*\\)\\'"))
+ (goto-char (setq suffix-flag (point-max))))
+
+ ;; Drop everything after point and certain trailing words.
+ (narrow-to-region (point-min)
+ (or (and drop-last-word-if-trailing-flag
+ last-word-beg)
+ (point)))
+
+ ;; Xerox's mailers SUCK!!!!!!
+ ;; We simply refuse to believe that any last name is PARC or ADOC.
+ ;; If it looks like that is the last name, that there is no meaningful
+ ;; here at all. Actually I guess it would be best to map patterns
+ ;; like foo.hoser(a)xerox.com into foo(a)hoser.xerox.com, but I don't
+ ;; actually know that that is what's going on.
+ (unless suffix-flag
+ (goto-char (point-min))
+ (let ((case-fold-search t))
+ (if (looking-at "[-A-Za-z_]+[. ]\\(PARC\\|ADOC\\)\\'")
+ (erase-buffer))))
+
+ ;; If last name first put it at end (but before suffix)
+ (when last-name-comma-flag
+ (goto-char (point-min))
+ (search-forward ",")
+ (setq name-end (1- (point)))
+ (goto-char (or suffix-flag (point-max)))
+ (or (eq ?\ (preceding-char))
+ (insert ?\ ))
+ (insert-buffer-substring (current-buffer) (point-min) name-end)
+ (goto-char name-end)
+ (skip-chars-forward "\t ,")
(narrow-to-region (point) (point-max)))
- ;; Stop after name suffix
- ((and (>= word-count 2)
- (looking-at mail-extr-full-name-suffix-pattern))
- (mail-extr-skip-whitespace-backward)
- (setq suffix-flag (point))
- (if (eq ?, (following-char))
- (forward-char 1)
- (insert ?,))
- ;; Enforce at least one space after comma
- (or (eq ?\ (following-char))
- (insert ?\ ))
- (mail-extr-skip-whitespace-forward)
- (cond ((memq (following-char) '(?j ?J ?s ?S))
- (capitalize-word 1)
- (if (eq (following-char) ?.)
- (forward-char 1)
- (insert ?.)))
- (t
- (upcase-word 1)))
- (setq word-found-flag t)
- (setq name-done-flag t))
-
- ;; Handle SCA names
- ((looking-at "MKA \\(.+\\)") ; "Mundanely Known As"
- (goto-char (match-beginning 1))
- (narrow-to-region (point) (point-max))
- (setq begin-again-flag t))
-
- ;; Check for initial last name followed by comma
- ((and (eq ?, (following-char))
- (eq word-count 1))
- (forward-char 1)
- (setq last-name-comma-flag t)
- (or (eq ?\ (following-char))
- (insert ?\ )))
-
- ;; Stop before trailing comma-separated comment
- ;; THIS CASE MUST BE AFTER THE PRECEDING CASES.
- ;; *** This case is redundant???
- ;;((eq ?, (following-char))
- ;; (setq name-done-flag t))
-
- ;; Delete parenthesized/quoted comment/nickname
- ((memq (following-char) '(?\( ?\{ ?\[ ?\" ?\' ?\`))
- (setq cbeg (point))
- (set-syntax-table mail-extr-address-text-comment-syntax-table)
- (cond ((memq (following-char) '(?\' ?\`))
- (or (search-forward "'" nil t
- (if (eq ?\' (following-char)) 2 1))
- (delete-char 1)))
- (t
- (or (mail-extr-safe-move-sexp 1)
- (goto-char (point-max)))))
- (set-syntax-table mail-extr-address-text-syntax-table)
- (setq cend (point))
- (cond
- ;; Handle case of entire name being quoted
- ((and (eq word-count 0)
- (looking-at " *\\'")
- (>= (- cend cbeg) 2))
- (narrow-to-region (1+ cbeg) (1- cend))
- (goto-char (point-min)))
- (t
- ;; Handle case of quoted initial
- (if (and (or (= 3 (- cend cbeg))
- (and (= 4 (- cend cbeg))
- (eq ?. (char-after (+ 2 cbeg)))))
- (not (looking-at " *\\'")))
- (setq initial (char-after (1+ cbeg)))
- (setq initial nil))
- (delete-region cbeg cend)
- (if initial
- (insert initial ". ")))))
-
- ;; Handle *Stupid* VMS date stamps
- ((looking-at mail-extr-stupid-vms-date-stamp-pattern)
- (replace-match "" t))
-
- ;; Handle Chinese characters.
- ((looking-at mail-extr-hz-embedded-gb-encoded-chinese-pattern)
- (goto-char (match-end 0))
- (setq word-found-flag t))
-
- ;; Skip initial garbage characters.
- ;; THIS CASE MUST BE AFTER THE PRECEDING CASES.
- ((and (eq word-count 0)
- (looking-at mail-extr-leading-garbage))
- (goto-char (match-end 0))
- ;; *** Skip backward over these???
- ;; (skip-chars-backward "& \"")
- (narrow-to-region (point) (point-max)))
-
- ;; Various stopping points
- ((or
-
- ;; Stop before ALL CAPS acronyms, if preceded by mixed-case
- ;; words. Example: XT-DEM.
- (and (>= word-count 2)
- mixed-case-flag
- (looking-at mail-extr-weird-acronym-pattern)
- (not (looking-at mail-extr-roman-numeral-pattern)))
-
- ;; Stop before trailing alternative address
- (looking-at mail-extr-alternative-address-pattern)
-
- ;; Stop before trailing comment not introduced by comma
- ;; THIS CASE MUST BE AFTER AN EARLIER CASE.
- (looking-at mail-extr-trailing-comment-start-pattern)
-
- ;; Stop before telephone numbers
- (and (>= word-count 1)
- (looking-at mail-extr-telephone-extension-pattern)))
- (setq name-done-flag t))
-
- ;; Delete ham radio call signs
- ((looking-at mail-extr-ham-call-sign-pattern)
- (delete-region (match-beginning 0) (match-end 0)))
-
- ;; Fixup initials
- ((looking-at mail-extr-initial-pattern)
- (or (eq (following-char) (upcase (following-char)))
- (setq lower-case-flag t))
- (forward-char 1)
- (if (eq ?. (following-char))
- (forward-char 1)
- (insert ?.))
- (or (eq ?\ (following-char))
- (insert ?\ ))
- (setq word-found-flag t))
+ ;; Delete leading and trailing junk characters.
+ ;; *** This is probably completely unneeded now.
+ ;;(goto-char (point-max))
+ ;;(skip-chars-backward mail-extr-non-end-name-chars)
+ ;;(if (eq ?. (following-char))
+ ;; (forward-char 1))
+ ;;(narrow-to-region (point)
+ ;; (progn
+ ;; (goto-char (point-min))
+ ;; (skip-chars-forward mail-extr-non-begin-name-chars)
+ ;; (point)))
- ;; Handle BITNET LISTSERV list names.
- ((and (eq word-count 0)
- (looking-at mail-extr-listserv-list-name-pattern))
- (narrow-to-region (match-beginning 1) (match-end 1))
- (setq word-found-flag t)
- (setq name-done-flag t))
-
- ;; Handle & substitution, when & is last and is not first.
- ((and (> word-count 0)
- (eq ?\ (preceding-char))
- (eq (following-char) ?&)
- (eq (1+ (point)) (point-max)))
- (delete-char 1)
- (capitalize-region
- (point)
- (progn
- (insert-buffer-substring canonicalization-buffer
- mbox-beg mbox-end)
- (point)))
- (setq disable-initial-guessing-flag t)
- (setq word-found-flag t))
-
- ;; Handle & between names, as in "Bob & Susie".
- ((and (> word-count 0) (eq (following-char) ?\&))
- (setq name-beg (point))
- (setq name-end (1+ name-beg))
- (setq word-found-flag t)
- (goto-char name-end))
-
- ;; Regular name words
- ((looking-at mail-extr-name-pattern)
- (setq name-beg (point))
- (setq name-end (match-end 0))
-
- ;; Certain words will be dropped if they are at the end.
- (and (>= word-count 2)
- (not lower-case-flag)
- (or
- ;; Trailing 4-or-more letter lowercase words preceded by
- ;; mixed case or uppercase words will be dropped.
- (looking-at "[a-z][a-z][a-z][a-z]+[ \t]*\\'") ;; XEmacs
- ;; Drop a trailing word which is terminated with a period.
- (eq ?. (char-after (1- name-end))))
- (setq drop-this-word-if-trailing-flag t))
-
- ;; Set the flags that indicate whether we have seen a lowercase
- ;; word, a mixed case word, and an uppercase word.
- (if (re-search-forward "[a-z]" name-end t)
- (if (progn
- (goto-char name-beg)
- (re-search-forward "[A-Z]" name-end t))
- (setq mixed-case-flag t)
- (setq lower-case-flag t))
-;; (setq upper-case-flag t)
- )
-
- (goto-char name-end)
- (setq word-found-flag t))
-
- ;; Allow a number as a word, if it doesn't mean anything else.
- ((looking-at "[0-9]+\\>")
- (setq name-beg (point))
- (setq name-end (match-end 0))
- (goto-char name-end)
- (setq word-found-flag t))
-
- (t
- (setq name-done-flag t)
- ))
-
- ;; Count any word that we skipped over.
- (if word-found-flag
- (setq word-count (1+ word-count))))
-
- ;; If the last thing in the name is 2 or more periods, or one or more
- ;; other sentence terminators (but not a single period) then keep them
- ;; and the preceding word. This is for the benefit of whole sentences
- ;; in the name field: it's better behavior than dropping the last word
- ;; of the sentence...
- (if (and (not suffix-flag)
- (looking-at "\\(\\.+\\|[?!;:.][?!;:.]+\\|[?!;:][?!;:.]*\\)\\'"))
- (goto-char (setq suffix-flag (point-max))))
-
- ;; Drop everything after point and certain trailing words.
- (narrow-to-region (point-min)
- (or (and drop-last-word-if-trailing-flag
- last-word-beg)
- (point)))
-
- ;; Xerox's mailers SUCK!!!!!!
- ;; We simply refuse to believe that any last name is PARC or ADOC.
- ;; If it looks like that is the last name, that there is no meaningful
- ;; here at all. Actually I guess it would be best to map patterns
- ;; like foo.hoser(a)xerox.com into foo(a)hoser.xerox.com, but I don't
- ;; actually know that that is what's going on.
- (unless suffix-flag
+ ;; Compress whitespace
(goto-char (point-min))
- (let ((case-fold-search t))
- (if (looking-at "[-A-Za-z_]+[. ]\\(PARC\\|ADOC\\)\\'")
- (erase-buffer))))
-
- ;; If last name first put it at end (but before suffix)
- (when last-name-comma-flag
- (goto-char (point-min))
- (search-forward ",")
- (setq name-end (1- (point)))
- (goto-char (or suffix-flag (point-max)))
- (or (eq ?\ (preceding-char))
- (insert ?\ ))
- (insert-buffer-substring (current-buffer) (point-min) name-end)
- (goto-char name-end)
- (skip-chars-forward "\t ,")
- (narrow-to-region (point) (point-max)))
-
- ;; Delete leading and trailing junk characters.
- ;; *** This is probably completely unneeded now.
- ;;(goto-char (point-max))
- ;;(skip-chars-backward mail-extr-non-end-name-chars)
- ;;(if (eq ?. (following-char))
- ;; (forward-char 1))
- ;;(narrow-to-region (point)
- ;; (progn
- ;; (goto-char (point-min))
- ;; (skip-chars-forward mail-extr-non-begin-name-chars)
- ;; (point)))
-
- ;; Compress whitespace
- (goto-char (point-min))
- (while (re-search-forward "[ \t\n]+" nil t)
- (replace-match (if (eobp) "" " ") t))
- )))
+ (while (re-search-forward "[ \t\n]+" nil t)
+ (replace-match (if (eobp) "" " ") t))
+ ))))
＠＠ -1822,7 +1880,7 ＠＠
;; http://www.iso.org/iso/en/prods-services/iso3166ma/02iso-3166-code-lists/...
;; http://www.iana.org/domain-names.htm
;; http://www.iana.org/cctld/cctld-whois.htm
-;; Latest change: Mon Jul 8 14:21:59 CEST 2002
+;; Latest change: 2007/11/15
(defconst mail-extr-all-top-level-domains
(let ((ob (make-vector 739 0)))
＠＠ -1835,6 +1893,7 ＠＠
(nth 1 x))))
'(
;; ISO 3166 codes:
+ ("ac" "Ascension Island")
("ad" "Andorra")
("ae" "United Arab Emirates")
("af" "Afghanistan")
＠＠ -1850,6 +1909,7 ＠＠
("at" "Austria" "The Republic of %s")
("au" "Australia")
("aw" "Aruba")
+ ("ax" "Aland Islands")
("az" "Azerbaijan")
("ba" "Bosnia-Herzegovina")
("bb" "Barbados")
＠＠ -1860,6 +1920,7 ＠＠
("bh" "Bahrain")
("bi" "Burundi")
("bj" "Benin")
+ ("bl" "Saint Barthelemy")
("bm" "Bermuda")
("bn" "Brunei Darussalam")
("bo" "Bolivia" "Republic of %s")
＠＠ -1901,6 +1962,7 ＠＠
("er" "Eritrea")
("es" "Spain" "The Kingdom of %s")
("et" "Ethiopia")
+ ("eu" "European Union")
("fi" "Finland" "The Republic of %s")
("fj" "Fiji")
("fk" "Falkland Islands (Malvinas)")
＠＠ -1912,6 +1974,7 ＠＠
("gd" "Grenada")
("ge" "Georgia")
("gf" "French Guiana")
+ ("gg" "Guernsey")
("gh" "Ghana")
("gi" "Gibraltar")
("gl" "Greenland")
＠＠ -1926,7 +1989,7 ＠＠
("gw" "Guinea-Bissau")
("gy" "Guyana")
("hk" "Hong Kong")
- ("hm" "Heard Island and Mcdonald Islands")
+ ("hm" "Heard Island and McDonald Islands")
("hn" "Honduras")
("hr" "Croatia" "Croatia (Hrvatska)")
("ht" "Haiti")
＠＠ -1941,6 +2004,7 ＠＠
("ir" "Iran" "Islamic Republic of %s")
("is" "Iceland" "The Republic of %s")
("it" "Italy" "The Italian Republic")
+ ("je" "Jersey")
("jm" "Jamaica")
("jo" "Jordan")
("jp" "Japan")
＠＠ -1969,6 +2033,8 ＠＠
("ma" "Morocco")
("mc" "Monaco")
("md" "Moldova" "The Republic of %s")
+ ("me" "Montenegro")
+ ("mf" "Saint Martin (French part)")
("mg" "Madagascar")
("mh" "Marshall Islands")
("mk" "Macedonia" "The Former Yugoslav Republic of %s")
＠＠ -2017,6 +2083,7 ＠＠
("qa" "Qatar")
("re" "Reunion (Fr.)") ; In .fr domain
("ro" "Romania")
+ ("rs" "Serbia")
("ru" "Russia" "Russian Federation")
("rw" "Rwanda")
("sa" "Saudi Arabia")
＠＠ -2080,15 +2147,21 ＠＠
("zw" "Zimbabwe" "Republic of %s")
;; Generic Domains:
("aero" t "Air Transport Industry")
+ ("asia" t "Pan-Asia and Asia Pacific community")
("biz" t "Businesses")
+ ("cat" t "Catalan language and culture")
("com" t "Commercial")
("coop" t "Cooperative Associations")
("info" t "Info")
+ ("jobs" t "Employment")
+ ("mobi" t "Mobile products")
("museum" t "Museums")
("name" t "Individuals")
("net" t "Network")
("org" t "Non-profit Organization")
- ;;("pro" t "Credentialed professionals")
+ ("pro" t "Credentialed professionals")
+ ("tel" t "Contact data")
+ ("travel" t "Travel industry")
;;("bitnet" t "Because It's Time NET")
("gov" t "United States Government")
("edu" t "Educational")
＠＠ -2128,5 +2201,4 ＠＠
(provide 'mail-extr)
-;;; arch-tag: 7785fade-1073-4ed6-b4f6-28db34a7982d
;;; mail-extr.el ends here
--
‘As I sat looking up at the Guinness ad, I could never figure out /
How your man stayed up on the surfboard after forty pints of stout’
(C. Moore)
- 1 participants
- 0 comments
[COMMIT] Increase GC_CONS_THRESHOLD to better reflect current RAM sizes.
7 years, 6 months
Aidan Kehoe
Aidan Kehoe
GNU’s current value for this is 400k. I actually run with a value of about 60
megabytes most of the time; this change is only to 32 megabytes.
APPROVE COMMIT
NOTE: This patch has been committed
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1489966027 0
# Sun Mar 19 23:27:07 2017 +0000
# Node ID 74b4d4c11264e149d03d748b9c34f253a69801bf
# Parent 0ae4d70fef9389d2d99dc048cc86bb5745854680
Increase GC_CONS_THRESHOLD to better reflect current RAM sizes.
src/ChangeLog addition:
2017-03-19 Aidan Kehoe <kehoea(a)parhasard.net>
* gc.c (GC_CONS_THRESHOLD):
Increase this (from about 2 megabytes to about 32) and the related
incremental-GC defaults, giving better performance with modern RAM
sizes.
diff -r 0ae4d70fef93 -r 74b4d4c11264 src/ChangeLog
--- a/src/ChangeLog Thu Mar 16 00:40:32 2017 +0000
+++ b/src/ChangeLog Sun Mar 19 23:27:07 2017 +0000
＠＠ -1,3 +1,10 ＠＠
+2017-03-19 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * gc.c (GC_CONS_THRESHOLD):
+ Increase this (from about 2 megabytes to about 32) and the related
+ incremental-GC defaults, giving better performance with modern RAM
+ sizes.
+
2017-03-15 Aidan Kehoe <kehoea(a)parhasard.net>
* lread.c (read1):
diff -r 0ae4d70fef93 -r 74b4d4c11264 src/gc.c
--- a/src/gc.c Thu Mar 16 00:40:32 2017 +0000
+++ b/src/gc.c Sun Mar 19 23:27:07 2017 +0000
＠＠ -361,14 +361,14 ＠＠
/* Number of bytes of consing since gc before a full gc should happen. */
-#define GC_CONS_THRESHOLD 2000000
-
+#define GC_CONS_THRESHOLD 32000000
+
/* Number of bytes of consing since gc before another cycle of the gc
should happen in incremental mode. */
-#define GC_CONS_INCREMENTAL_THRESHOLD 200000
+#define GC_CONS_INCREMENTAL_THRESHOLD 800000
/* Number of elements marked in one cycle of incremental GC. */
-#define GC_INCREMENTAL_TRAVERSAL_THRESHOLD 100000
+#define GC_INCREMENTAL_TRAVERSAL_THRESHOLD 400000
/* Number of bytes of consing done since the last GC. */
EMACS_INT consing_since_gc;
--
‘As I sat looking up at the Guinness ad, I could never figure out /
How your man stayed up on the surfboard after forty pints of stout’
(C. Moore)
- 1 participants
- 0 comments
[COMMIT] Avoid C overflow with #@FIXNUM-style docstrings. Thank you Hao Sun!
7 years, 7 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1489624832 0
# Thu Mar 16 00:40:32 2017 +0000
# Node ID 0ae4d70fef9389d2d99dc048cc86bb5745854680
# Parent 72c0d63b2ad689f80852f6195eda16128eb62081
Avoid C overflow with #＠FIXNUM-style docstrings. Thank you Hao Sun!
src/ChangeLog addition:
2017-03-15 Aidan Kehoe <kehoea(a)parhasard.net>
* lread.c (read1):
If a #＠INTEGER docstring comment has an unreasonably large
INTEGER, error, instead of silently wrapping. Thank you for the
bug report, Hao Sun.
tests/ChangeLog addition:
2017-03-16 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-reader-tests.el (args-out-of-range):
Test we don't wrap on reading a C integer with long #＠ comments.
lisp/ChangeLog addition:
2017-03-15 Aidan Kehoe <kehoea(a)parhasard.net>
* make-docfile.el:
Don't bother working around a berkeley-unix and next-mach bug
that is likely long fixed anyway.
Print the stderr of make-docfile to the terminal instead of simply
discarding it.
Pass through make-docfile's exit code.
lib-src/ChangeLog addition:
2017-03-15 Aidan Kehoe <kehoea(a)parhasard.net>
* make-docfile.c (scan_lisp_file):
Don't wrap the integer counter when reading the length of a #＠
comment. Thank you for the tracker bug report, Hao Sun in tracker
issue 870!
diff -r 72c0d63b2ad6 -r 0ae4d70fef93 lib-src/ChangeLog
--- a/lib-src/ChangeLog Wed Mar 15 22:54:10 2017 +0000
+++ b/lib-src/ChangeLog Thu Mar 16 00:40:32 2017 +0000
＠＠ -1,3 +1,10 ＠＠
+2017-03-15 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * make-docfile.c (scan_lisp_file):
+ Don't wrap the integer counter when reading the length of a #＠
+ comment. Thank you for the tracker bug report, Hao Sun in tracker
+ issue 870!
+
2015-03-08 Aidan Kehoe <kehoea(a)parhasard.net>
* gnuserv.c (echo_request):
diff -r 72c0d63b2ad6 -r 0ae4d70fef93 lib-src/make-docfile.c
--- a/lib-src/make-docfile.c Wed Mar 15 22:54:10 2017 +0000
+++ b/lib-src/make-docfile.c Thu Mar 16 00:40:32 2017 +0000
＠＠ -1099,15 +1099,25 ＠＠
c = getc_skipping_iso2022 (infile);
if (c == '＠')
{
- int length = 0;
- int i;
+ unsigned int nlength = 0, length = 0;
+ unsigned int i;
/* Read the length. */
while ((c = getc_skipping_iso2022 (infile),
c >= '0' && c <= '9'))
{
- length *= 10;
- length += c - '0';
+ length = nlength;
+ nlength *= 10;
+ nlength += c - '0';
+
+ if (length <= nlength)
+ {
+ length = nlength;
+ }
+ else
+ {
+ break; /* Overflow, stick with the old value. */
+ }
}
/* The next character is a space that is counted in the length
＠＠ -1120,7 +1130,15 ＠＠
free (saved_string);
saved_string = (char *) xmalloc (length);
for (i = 0; i < length; i++)
- saved_string[i] = getc (infile);
+ {
+ saved_string[i] = c = getc (infile);
+ if (c == EOF)
+ {
+ saved_string[i] = '\0';
+ fatal ("docstring ran off end of file: `%.50s ...'",
+ saved_string);
+ }
+ }
/* The last character is a ^_.
That is needed in the .elc file
but it is redundant in DOC. So get rid of it here. */
＠＠ -1129,7 +1147,7 ＠＠
while (c == '\n')
c = getc_skipping_iso2022 (infile);
/* Skip the following line. */
- while (c != '\n')
+ while (c != '\n' && c != EOF)
c = getc_skipping_iso2022 (infile);
}
continue;
＠＠ -1167,7 +1185,7 ＠＠
continue;
}
else
- while (c != ')')
+ while (c != ')' && c != EOF)
{
c = getc_skipping_iso2022 (infile);
if (c < 0)
diff -r 72c0d63b2ad6 -r 0ae4d70fef93 lisp/ChangeLog
--- a/lisp/ChangeLog Wed Mar 15 22:54:10 2017 +0000
+++ b/lisp/ChangeLog Thu Mar 16 00:40:32 2017 +0000
＠＠ -1,3 +1,12 ＠＠
+2017-03-15 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * make-docfile.el:
+ Don't bother working around a berkeley-unix and next-mach bug
+ that is likely long fixed anyway.
+ Print the stderr of make-docfile to the terminal instead of simply
+ discarding it.
+ Pass through make-docfile's exit code.
+
2017-03-13 Aidan Kehoe <kehoea(a)parhasard.net>
* ChangeLog:
diff -r 72c0d63b2ad6 -r 0ae4d70fef93 lisp/make-docfile.el
--- a/lisp/make-docfile.el Wed Mar 15 22:54:10 2017 +0000
+++ b/lisp/make-docfile.el Thu Mar 16 00:40:32 2017 +0000
＠＠ -50,7 +50,7 ＠＠
(defvar source-src (expand-file-name "../src" source-lisp))
(defun message (fmt &rest args)
- (write-sequence (apply #'format fmt args))
+ (apply #'format-into standard-output fmt args)
(write-char ?\n))
;; Gobble up the stuff we don't wish to pass on.
＠＠ -236,35 +236,25 ＠＠
(setq exec-path (list build-lib-src))
;; (locate-file-clear-hashing nil)
- (if (memq system-type '(berkeley-unix next-mach))
- ;; Suboptimal, but we have a unresolved bug somewhere in the
- ;; low-level process code. #### Now that we've switched to using
- ;; the regular asynch process code, we should try removing this.
- (call-process-internal
- "/bin/csh"
- nil
- t
- nil
- "-fc"
- (mapconcat
- #'identity
- (append
- (list (expand-file-name "make-docfile" build-lib-src))
- options processed)
- " "))
- ;; (message (prin1-to-string (append options processed)))
- (apply 'call-process-internal
- ;; exec-path is set.
- ;; (expand-file-name "make-docfile" build-lib-src)
- "make-docfile"
- nil
- t
- nil
- (append options processed)))
-
- (message "Spawning make-docfile ...done")
- ;; (write-region-internal (point-min) (point-max) "/tmp/DOC")
- )
+ ;; (message (prin1-to-string (append options processed)))
+ (let* ((standard-error (get-buffer-create
+ (generate-new-buffer-name "stderr")))
+ (status
+ (apply 'call-process-internal
+ ;; exec-path is set.
+ ;; (expand-file-name "make-docfile" build-lib-src)
+ "make-docfile"
+ nil
+ (list t standard-error)
+ nil
+ (append options processed))))
+ (if (equal status 0)
+ (message "%sSpawning make-docfile ...done"
+ (buffer-substring nil nil standard-error))
+ (message "%sSpawning make-docfile ... error, failed with status %d."
+ (buffer-substring nil nil standard-error)
+ status))
+ (kill-emacs status)))
(kill-emacs)
diff -r 72c0d63b2ad6 -r 0ae4d70fef93 src/ChangeLog
--- a/src/ChangeLog Wed Mar 15 22:54:10 2017 +0000
+++ b/src/ChangeLog Thu Mar 16 00:40:32 2017 +0000
＠＠ -1,3 +1,10 ＠＠
+2017-03-15 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * lread.c (read1):
+ If a #＠INTEGER docstring comment has an unreasonably large
+ INTEGER, error, instead of silently wrapping. Thank you for the
+ bug report, Hao Sun.
+
2017-03-13 Aidan Kehoe <kehoea(a)parhasard.net>
* data.c (Flsh):
diff -r 72c0d63b2ad6 -r 0ae4d70fef93 src/lread.c
--- a/src/lread.c Wed Mar 15 22:54:10 2017 +0000
+++ b/src/lread.c Thu Mar 16 00:40:32 2017 +0000
＠＠ -2638,12 +2638,26 ＠＠
/* #＠NUMBER is used to skip NUMBER following characters.
That's used in .elc files to skip over doc strings
and function definitions. */
- int i, nskip = 0;
+ UINT_32_BIT i, skip = 0, oskip = 0;
/* Read a decimal integer. */
while ((c = readchar (readcharfun)) >= 0
&& c >= '0' && c <= '9')
- nskip = (10 * nskip) + (c - '0');
+ {
+ skip = (10 * skip) + (c - '0');
+ if (oskip <= skip)
+ {
+ oskip = skip;
+ }
+ else
+ {
+ /* Overflow, error. */
+ args_out_of_range_3 (make_unsigned_integer (skip),
+ Qzero, make_fixnum (0x3fffffff));
+ break;
+ }
+ }
+
if (c >= 0)
unreadchar (readcharfun, c);
＠＠ -2652,7 +2666,7 ＠＠
losing. We handle this differently. */
/* Skip that many characters. */
- for (i = 0; i < nskip && c >= 0; i++)
+ for (i = 0; i < skip && c >= 0; i++)
c = readchar (readcharfun);
goto retry;
diff -r 72c0d63b2ad6 -r 0ae4d70fef93 tests/ChangeLog
--- a/tests/ChangeLog Wed Mar 15 22:54:10 2017 +0000
+++ b/tests/ChangeLog Thu Mar 16 00:40:32 2017 +0000
＠＠ -1,3 +1,8 ＠＠
+2017-03-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/lisp-reader-tests.el (args-out-of-range):
+ Test we don't wrap on reading a C integer with long #＠ comments.
+
2017-03-13 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/completion-tests.el (featurep):
diff -r 72c0d63b2ad6 -r 0ae4d70fef93 tests/automated/lisp-reader-tests.el
--- a/tests/automated/lisp-reader-tests.el Wed Mar 15 22:54:10 2017 +0000
+++ b/tests/automated/lisp-reader-tests.el Thu Mar 16 00:40:32 2017 +0000
＠＠ -346,4 +346,8 ＠＠
(Assert (equal "20000e-" (prin1-to-string '20000e-))
"checking Lisp printer recognises non-number syntax, trailing -")
+;; Checking we don't overflow on long #＠ comments.
+
+(Check-Error args-out-of-range (read "#＠4294967296 hello"))
+
;;; end of lisp-reader-tests.el
--
‘As I sat looking up at the Guinness ad, I could never figure out /
How your man stayed up on the surfboard after forty pints of stout’
(C. Moore)
- 1 participants
- 0 comments
[COMMIT] Silence warnings about _BSD_SOURCE, _SVID_SOURCE on glibc.
7 years, 7 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1489618450 0
# Wed Mar 15 22:54:10 2017 +0000
# Node ID 72c0d63b2ad689f80852f6195eda16128eb62081
# Parent b87475042f4709539c8000e20b87d8e50ab774f4
Silence warnings about _BSD_SOURCE, _SVID_SOURCE on glibc.
ChangeLog addition:
2017-03-15 Aidan Kehoe <kehoea(a)parhasard.net>
* configure.ac:
Don't #define _BSD_SOURCE or _SVID_SOURCE on glibc, even if xmkmf
asks us to. Silences a warning on Linux. Thank you Mats Lidell.
* configure: Regenerate.
diff -r b87475042f47 -r 72c0d63b2ad6 ChangeLog
--- a/ChangeLog Mon Mar 13 22:19:58 2017 +0000
+++ b/ChangeLog Wed Mar 15 22:54:10 2017 +0000
＠＠ -9,6 +9,13 ＠＠
were checking for.
* configure: Rebuild.
+2017-03-15 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * configure.ac:
+ Don't #define _BSD_SOURCE or _SVID_SOURCE on glibc, even if xmkmf
+ asks us to. Silences a warning on Linux. Thank you Mats Lidell.
+ * configure: Regenerate.
+
2016-11-05 Michael Sperber <mike(a)xemacs.org>
* configure.ac: Disable ASLR on macOS Sierra..
diff -r b87475042f47 -r 72c0d63b2ad6 configure
--- a/configure Mon Mar 13 22:19:58 2017 +0000
+++ b/configure Wed Mar 15 22:54:10 2017 +0000
＠＠ -13530,7 +13530,10 ＠＠
-D*=* ) val=`echo '' $word | sed -e 's:^.*=::'` ;;
* ) val=1 ;;
esac
- if grep "^#define $sym " confdefs.h >/dev/null; then :; else
+ if grep "^#define $sym " confdefs.h >/dev/null || \
+ test "$have_glibc" = "yes" -a "$sym" = "_BSD_SOURCE" || \
+ test "$have_glibc" = "yes" -a "$sym" = "_SVID_SOURCE";
+ then :; else
if test "$val" = "1"
then cat >>confdefs.h <<_ACEOF
#define $sym 1
diff -r b87475042f47 -r 72c0d63b2ad6 configure.ac
--- a/configure.ac Mon Mar 13 22:19:58 2017 +0000
+++ b/configure.ac Wed Mar 15 22:54:10 2017 +0000
＠＠ -3141,7 +3141,12 ＠＠
* ) val=1 ;;
esac
dnl Avoid re-AC_DEFINE-ing xmkmf symbols we've already defined above.
- if grep "^#define $sym " confdefs.h >/dev/null; then :; else
+dnl Also, glibc doesn't like two of the traditional POSIX macros that xmkmf
+dnl likes us to define; ignore them if appropriate.
+ if grep "^#define $sym " confdefs.h >/dev/null || \
+ test "$have_glibc" = "yes" -a "$sym" = "_BSD_SOURCE" || \
+ test "$have_glibc" = "yes" -a "$sym" = "_SVID_SOURCE";
+ then :; else
if test "$val" = "1"
then AC_DEFINE_UNQUOTED($sym)
else AC_DEFINE_UNQUOTED($sym,$val)
--
‘As I sat looking up at the Guinness ad, I could never figure out /
How your man stayed up on the surfboard after forty pints of stout’
(C. Moore)
- 1 participants
- 0 comments
[COMMIT] Update URLs with http://mid.gmane.org/ to http://mid.xemacs.org/.
7 years, 7 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1489443598 0
# Mon Mar 13 22:19:58 2017 +0000
# Node ID b87475042f4709539c8000e20b87d8e50ab774f4
# Parent a246642bdcf107ece9e562b28881866a48fef266
Update URLs with http://mid.gmane.org/ to http://mid.xemacs.org/.
ChangeLog addition (other ChangeLog additions basically identical):
2017-03-13 Aidan Kehoe <kehoea(a)parhasard.net>
* ChangeLog:
* data.c:
Update mid.gmane.org to mid.xemacs.org. We miss you, Gmane.
diff -r a246642bdcf1 -r b87475042f47 ChangeLog
--- a/ChangeLog Sun Mar 12 22:02:08 2017 +0000
+++ b/ChangeLog Mon Mar 13 22:19:58 2017 +0000
＠＠ -1,3 +1,8 ＠＠
+2017-03-13 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * ChangeLog:
+ Update mid.gmane.org to mid.xemacs.org. We miss you, Gmane.
+
2017-01-23 Jeff Sparkes <jsparkes(a)gmail.com>
* configure.ac (HAVE_XFACE): giflib 5.0 removed a function we
＠＠ -742,9 +747,9 ＠＠
libgdbm_compat.so, also link to that library.
Correct a thinko with DBM version 4 checks. Both from Hans de
Graaff, in
- http://mid.gmane.org/20050812092756.6850.qmail＠graaff.xs4all.nl
+ http://mid.xemacs.org/20050812092756.6850.qmail＠graaff.xs4all.nl
and
- http://mid.gmane.org/pan.2007.06.24.10.10.57＠gentoo.org; thank you
+ http://mid.xemacs.org/pan.2007.06.24.10.10.57＠gentoo.org; thank you
Hans!
* configure:
Regenerate.
diff -r a246642bdcf1 -r b87475042f47 etc/ChangeLog
--- a/etc/ChangeLog Sun Mar 12 22:02:08 2017 +0000
+++ b/etc/ChangeLog Mon Mar 13 22:19:58 2017 +0000
＠＠ -1,3 +1,8 ＠＠
+2017-03-13 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * unicode/unicode-consortium/EASTASIA/OBSOLETE/BIG5.TXT:
+ Update mid.gmane.org to mid.xemacs.org. We miss you, Gmane.
+
2014-12-05 Jerry James <james(a)xemacs.org>
* xemacs.appdata.xml:
diff -r a246642bdcf1 -r b87475042f47 etc/unicode/unicode-consortium/EASTASIA/OBSOLETE/BIG5.TXT
--- a/etc/unicode/unicode-consortium/EASTASIA/OBSOLETE/BIG5.TXT Sun Mar 12 22:02:08 2017 +0000
+++ b/etc/unicode/unicode-consortium/EASTASIA/OBSOLETE/BIG5.TXT Mon Mar 13 22:19:58 2017 +0000
＠＠ -61,7 +61,7 ＠＠
#
# XEmacs change; we map them to private use characters above
# U+F0000. 0xA15A => U+FA15A, and so on. See
-# http://mid.gmane.org/s3tsl7j7zg9.fsf＠magellan.suse.de and related
+# http://mid.xemacs.org/s3tsl7j7zg9.fsf＠magellan.suse.de and related
# discussion.
#
# Notes:
diff -r a246642bdcf1 -r b87475042f47 lisp/ChangeLog
--- a/lisp/ChangeLog Sun Mar 12 22:02:08 2017 +0000
+++ b/lisp/ChangeLog Mon Mar 13 22:19:58 2017 +0000
＠＠ -1,3 +1,9 ＠＠
+2017-03-13 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * ChangeLog:
+ * data.c:
+ Update mid.gmane.org to mid.xemacs.org. We miss you, Gmane.
+
2017-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
Replace calls to #'string-match, where the match data isn't used,
＠＠ -2210,7 +2216,7 ＠＠
Update this, adding everything that maps to no-conversion or
no-conversion-multibyte in GNU's auto-mode-alist.
In particular, add PDFs, important given gnus' problem with them
- of http://mid.gmane.org/m3r637lpm5.fsf＠mikesoffice.com and the
+ of http://mid.xemacs.org/m3r637lpm5.fsf＠mikesoffice.com and the
associated thread, and Uwe's recent re-reporting of the same
problem.
＠＠ -2239,7 +2245,7 ＠＠
* cl-macs.el (cl-defsubst-expand):
Change set 2a6a8da4dd7c of
- http://mid.gmane.org/19966.17522.332164.615228＠parhasard.net
+ http://mid.xemacs.org/19966.17522.332164.615228＠parhasard.net
wasn't sufficiently comprehensive, symbol macros can be mutually
rather than simply recursive, and they can equally hang. Thanks
for the bug report, Michael Sperber, and for the test case,
＠＠ -2252,7 +2258,7 ＠＠
eval-when-compile form hasn't done save-excursion when
appropriate), error and exit; we can't guarantee we'll give useful
code in that context. See
- http://mid.gmane.org/20110909110831.GD2875＠acm.acm and related
+ http://mid.xemacs.org/20110909110831.GD2875＠acm.acm and related
discussion.
2011-09-07 Aidan Kehoe <kehoea(a)parhasard.net>
＠＠ -4170,7 +4176,7 ＠＠
in practice only seen with XFree86 and derived non-US layouts)
exists on the keyboard layout, make it equivalent to shift-tab,
addressing the issue FKtPp sees in
- http://mid.gmane.org/1269358206.4873.1.camel＠fktpp-laptop .
+ http://mid.xemacs.org/1269358206.4873.1.camel＠fktpp-laptop .
2010-03-21 Aidan Kehoe <kehoea(a)parhasard.net>
＠＠ -4285,7 +4291,7 ＠＠
in practice only seen with XFree86 and derived non-US layouts)
exists on the keyboard layout, make it equivalent to shift-tab,
addressing the issue FKtPp sees in
- http://mid.gmane.org/1269358206.4873.1.camel＠fktpp-laptop .
+ http://mid.xemacs.org/1269358206.4873.1.camel＠fktpp-laptop .
2010-03-21 Aidan Kehoe <kehoea(a)parhasard.net>
＠＠ -5080,7 +5086,7 ＠＠
* indent.el (indent-region):
Make COLUMN optional as in GNU, merging Andreas Roehler's change
- of http://mid.gmane.org/4B46F5FC.2070506＠online.de ; thank you
+ of http://mid.xemacs.org/4B46F5FC.2070506＠online.de ; thank you
Andreas!
2010-01-07 Aidan Kehoe <kehoea(a)parhasard.net>
＠＠ -5367,7 +5373,7 ＠＠
* indent.el (indent-region):
Make COLUMN optional as in GNU, merging Andreas Roehler's change
- of http://mid.gmane.org/4B46F5FC.2070506＠online.de ; thank you
+ of http://mid.xemacs.org/4B46F5FC.2070506＠online.de ; thank you
Andreas!
2010-01-07 Aidan Kehoe <kehoea(a)parhasard.net>
＠＠ -5571,7 +5577,7 ＠＠
* faces.el (init-other-random-faces):
If the modeline face is using its fallbacks, avoid that, specify
the corresponding problems instead. Fixes problems described in
- http://mid.gmane.org/3ggprc2diyt.wl_Ron.Isaacson＠morganstanley.com
+ http://mid.xemacs.org/3ggprc2diyt.wl_Ron.Isaacson＠morganstanley.com
2009-11-09 Didier Verna <didier(a)xemacs.org>
＠＠ -6192,7 +6198,7 ＠＠
autodetection fails. (Ignoring that for the user, autodetection
failing is something very distinct from what we use it to mean
here.) See
- http://mid.gmane.org/18986.53111.800393.660612＠parhasard.net and
+ http://mid.xemacs.org/18986.53111.800393.660612＠parhasard.net and
the related thread.
2009-06-06 Aidan Kehoe <kehoea(a)parhasard.net>
＠＠ -6305,7 +6311,7 ＠＠
* descr-text.el (describe-char-unicodedata-file):
Back out Stephen's change of 2009-01-01, 16c9098dd3d2; do a
Mercurial merge, add this ChangeLog entry.
- See also http://mid.gmane.org/8763jbsyr7.fsf＠xemacs.org .
+ See also http://mid.xemacs.org/8763jbsyr7.fsf＠xemacs.org .
2009-02-02 Aidan Kehoe <kehoea(a)parhasard.net>
＠＠ -6519,7 +6525,7 ＠＠
Fix a cosmetic bug; the relationship between
file-name-coding-system and the file-name coding system alias
established in coding.el wasn't being maintained. See Katsumi
- Yamaoka's comment in http://mid.gmane.org/b4m4p03bt43.fsf＠jpl.org .
+ Yamaoka's comment in http://mid.xemacs.org/b4m4p03bt43.fsf＠jpl.org .
2009-01-11 Aidan Kehoe <kehoea(a)parhasard.net>
＠＠ -6945,7 +6951,7 ＠＠
* subr.el (add-to-list): Implement the same logic with a more
concise syntax; thank you Stephen, in
- http://mid.gmane.org/87ablomdwx.fsf＠uwakimon.sk.tsukuba.ac.jp .
+ http://mid.xemacs.org/87ablomdwx.fsf＠uwakimon.sk.tsukuba.ac.jp .
2008-02-25 bpalmer <bpalmer(a)gmail.com>
diff -r a246642bdcf1 -r b87475042f47 src/ChangeLog
--- a/src/ChangeLog Sun Mar 12 22:02:08 2017 +0000
+++ b/src/ChangeLog Mon Mar 13 22:19:58 2017 +0000
＠＠ -1,3 +1,8 ＠＠
+2017-03-13 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * data.c (Flsh):
+ Update mid.gmane.org to mid.xemacs.org. We miss you, Gmane.
+
2017-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
* file-coding.c:
＠＠ -3270,7 +3275,7 ＠＠
is deleted, the window display code uses the buffer's actual point
instead of the position that the marker had been moved to.
Fixes Michael Heinrich's problem of
- http://mid.gmane.org/6zr42uxtf5.fsf＠elektra.science-computing.de ,
+ http://mid.xemacs.org/6zr42uxtf5.fsf＠elektra.science-computing.de ,
introduced by Ben's patch of
https://bitbucket.org/xemacs/xemacs/commits/047d37eb70d70f43803 .
＠＠ -5530,7 +5535,7 ＠＠
The EMACS_INT typedef was not changed, it does not describe
non-bignum Lisp integers.
Script that did the change available in
- http://mid.gmane.org/20067.17650.181273.12014＠parhasard.net .
+ http://mid.xemacs.org/20067.17650.181273.12014＠parhasard.net .
2011-09-06 Aidan Kehoe <kehoea(a)parhasard.net>
＠＠ -6460,7 +6465,7 ＠＠
* specifier.c (specifier_instance_from_inst_list):
Call call_with_suspended_errors() with ERROR_ME_WARN, explicitly;
avoids the problem Giacomo Boffi describes in
- http://mid.gmane.org/19617.52517.341117.388679＠aiuole.stru.polimi.it
+ http://mid.xemacs.org/19617.52517.341117.388679＠aiuole.stru.polimi.it
, but the specifier instantiation bug that makes XEmacs fail for
him is still visible.
＠＠ -17894,7 +17899,7 ＠＠
* redisplay-msw.c (mswindows_text_width_single_run):
Explicitly check for the null font instance, and return zero if
so. Avoids the crash documented in
- http://mid.gmane.org/18473.32468.712317.149457＠parhasard.net .
+ http://mid.xemacs.org/18473.32468.712317.149457＠parhasard.net .
2008-05-27 Aidan Kehoe <kehoea(a)parhasard.net>
＠＠ -18193,9 +18198,9 ＠＠
If the charset is not specified when calling the
font_spec_matches_charset device method, its value is Qnil, not
Qunbound. See
- http://mid.gmane.org/E1EfbmW-00029r-5G＠iwi191.iwi.uni-sb.de and
+ http://mid.xemacs.org/E1EfbmW-00029r-5G＠iwi191.iwi.uni-sb.de and
Ben Wing's patch of
- http://mid.gmane.org/439FA06B.3090007＠xemacs.org.
+ http://mid.xemacs.org/439FA06B.3090007＠xemacs.org.
2007-12-22 Aidan Kehoe <kehoea(a)parhasard.net>
diff -r a246642bdcf1 -r b87475042f47 src/data.c
--- a/src/data.c Sun Mar 12 22:02:08 2017 +0000
+++ b/src/data.c Mon Mar 13 22:19:58 2017 +0000
＠＠ -3093,7 +3093,7 ＠＠
/* Sigh, this won't catch all overflows in the MPZ type under GMP,
and there's no way to hook into the library so that an overflow
errors rather than aborting. See
- http://mid.gmane.org/5529.2096.e5823.ccba＠parhasard.net . */
+ http://mid.xemacs.org/5529.2096.e5823.ccba＠parhasard.net . */
if (!bignum_fits_ulong_p (scratch_bignum))
{
args_out_of_range_3 (count,
diff -r a246642bdcf1 -r b87475042f47 tests/ChangeLog
--- a/tests/ChangeLog Sun Mar 12 22:02:08 2017 +0000
+++ b/tests/ChangeLog Mon Mar 13 22:19:58 2017 +0000
＠＠ -1,3 +1,9 ＠＠
+2017-03-13 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/completion-tests.el (featurep):
+ * automated/search-tests.el:
+ Update mid.gmane.org to mid.xemacs.org. We miss you, Gmane.
+
2017-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el:
＠＠ -700,7 +706,7 ＠＠
* automated/lisp-tests.el (substring-no-properties):
Make sure this function checks its arguments' types, the absence
of which was revealed by Raymond Toy's bug report of
- http://mid.gmane.org/4D65D413.5050103＠gmail.com .
+ http://mid.xemacs.org/4D65D413.5050103＠gmail.com .
2011-02-10 Aidan Kehoe <kehoea(a)parhasard.net>
＠＠ -1343,7 +1349,7 ＠＠
* automated/regexp-tests.el:
Make sure that control-1 characters are no longer treated as
second-class citizens in regexp ranges, as in
- http://mid.gmane.org/18829.34118.709782.704574＠parhasard.net .
+ http://mid.xemacs.org/18829.34118.709782.704574＠parhasard.net .
2010-01-29 Ben Wing <ben(a)xemacs.org>
＠＠ -1693,7 +1699,7 ＠＠
* automated/mule-tests.el:
Check for Richard Zidlicky's bug of
- http://mid.gmane.org/20090602194123.GA5163＠linux-m68k.org; also
+ http://mid.xemacs.org/20090602194123.GA5163＠linux-m68k.org; also
check that supplying CODESYS to #'find-file is respected both for
nonexistent files and zero-length existing files.
＠＠ -1717,7 +1723,7 ＠＠
* automated/mule-tests.el (featurep):
Add a missing parenthesis here, thank you
- Stephen. Cf. http://mid.gmane.org/871vtzrxey.fsf＠xemacs.org .
+ Stephen. Cf. http://mid.xemacs.org/871vtzrxey.fsf＠xemacs.org .
2009-02-10 Aidan Kehoe <kehoea(a)parhasard.net>
diff -r a246642bdcf1 -r b87475042f47 tests/automated/completion-tests.el
--- a/tests/automated/completion-tests.el Sun Mar 12 22:02:08 2017 +0000
+++ b/tests/automated/completion-tests.el Mon Mar 13 22:19:58 2017 +0000
＠＠ -32,7 +32,7 ＠＠
(defmacro Assert (assertion &optional failing-case)
;; This file can actually execute on GNU, though it exposes some bugs
;; as of So 1 Jan 2012 14:41:32 GMT, described in
- ;; http://mid.gmane.org/20224.27302.821804.284656＠parhasard.net .
+ ;; http://mid.xemacs.org/20224.27302.821804.284656＠parhasard.net .
`(condition-case err
(assert ,assertion nil
,＠(if (memq (car-safe assertion)
diff -r a246642bdcf1 -r b87475042f47 tests/automated/search-tests.el
--- a/tests/automated/search-tests.el Sun Mar 12 22:02:08 2017 +0000
+++ b/tests/automated/search-tests.el Mon Mar 13 22:19:58 2017 +0000
＠＠ -156,7 +156,7 ＠＠
(goto-char (point-max))
(Assert (not (search-backward string nil t 6))))))
-;; Bug reported in http://mid.gmane.org/y9lk5lu5orq.fsf＠deinprogramm.de from
+;; Bug reported in http://mid.xemacs.org/y9lk5lu5orq.fsf＠deinprogramm.de from
;; Michael Sperber. Fixed 2008-01-29.
(with-string-as-buffer-contents "\n\nDer beruhmte deutsche Flei\xdf\n\n"
(goto-char (point-min))
--
‘As I sat looking up at the Guinness ad, I could never figure out /
How your man stayed up on the surfboard after forty pints of stout’
(C. Moore)
- 1 participants
- 0 comments
[COMMIT] Revert to the pre-merge description of the no-conversion coding system type.
7 years, 7 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1489343455 0
# Sun Mar 12 18:30:55 2017 +0000
# Node ID b39892b2cd48fdd5f2ff4e6c9f87baaa7dd39187
# Parent 7053230a0057848e0491c2be03ffa64ba38b89d0
Revert to the pre-merge description of the no-conversion coding system type.
src/ChangeLog addition:
2017-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
* file-coding.c (coding_system_type_create):
Revert to the pre-merge description of the no-conversion coding
system type, the approach I had taken on the unicode-internal side
leads to dumping problems with the C++ build.
Thank you for the buildbot reports, Matsl!
diff -r 7053230a0057 -r b39892b2cd48 src/ChangeLog
--- a/src/ChangeLog Sun Mar 12 13:16:09 2017 +0000
+++ b/src/ChangeLog Sun Mar 12 18:30:55 2017 +0000
＠＠ -1,3 +1,12 ＠＠
+2017-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * file-coding.c:
+ * file-coding.c (coding_system_type_create):
+ Revert to the pre-merge description of the no-conversion coding
+ system type, the approach I had taken on the unicode-internal side
+ leads to dumping problems with the C++ build.
+ Thank you for the buildbot reports, Matsl!
+
2017-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
Make some small changes to placate the buildbot.
diff -r 7053230a0057 -r b39892b2cd48 src/file-coding.c
--- a/src/file-coding.c Sun Mar 12 13:16:09 2017 +0000
+++ b/src/file-coding.c Sun Mar 12 18:30:55 2017 +0000
＠＠ -3863,21 +3863,7 ＠＠
Charcount characters_seen;
};
-struct no_conversion_coding_system
-{
-};
-
-static const struct memory_description
- no_conversion_coding_system_description[] = {
- { XD_END }
-};
-
-static const struct memory_description
- no_conversion_coding_stream_description[] = {
- { XD_END }
-};
-
-DEFINE_CODING_SYSTEM_TYPE_WITH_DATA (no_conversion);
+DEFINE_CODING_SYSTEM_TYPE (no_conversion);
/* This is used when reading in "binary" files -- i.e. files that may
contain all 256 possible byte values and that are not to be
＠＠ -5827,8 +5813,13 ＠＠
dump_add_opaque_int (&coding_detector_count);
dump_add_opaque_int (&coding_detector_category_count);
- INITIALIZE_CODING_SYSTEM_TYPE_WITH_DATA (no_conversion,
- "no-conversion-coding-system-p");
+ INITIALIZE_CODING_SYSTEM_TYPE (no_conversion,
+ "no-conversion-coding-system-p");
+ /* This is the only coding system type that has coding_stream info but no
+ coding_system info, which is why we're not using
+ INITIALIZE_CODING_SYSTEM_TYPE_WITH_DATA. */
+ no_conversion_coding_system_methods->stream_data_size =
+ sizeof (struct no_conversion_coding_stream);
CODING_SYSTEM_HAS_METHOD (no_conversion, convert);
CODING_SYSTEM_HAS_METHOD (no_conversion, character_tell);
--
‘As I sat looking up at the Guinness ad, I could never figure out /
How your man stayed up on the surfboard after forty pints of stout’
(C. Moore)
- 1 participants
- 0 comments
[COMMIT] Make some small changes to placate the buildbot, src/
7 years, 7 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1489324569 0
# Sun Mar 12 13:16:09 2017 +0000
# Node ID 7053230a0057848e0491c2be03ffa64ba38b89d0
# Parent 2e96482cc41086258d6b796414303d2a44932fee
Make some small changes to placate the buildbot, src/
src/ChangeLog addition:
2017-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
Make some small changes to placate the buildbot.
* charset.h (Vcharset_control_1):
Make this available on non-Mule.
* redisplay-xlike-inc.c:
Restore ALLOCATE_RUNS_TEXT() for nonmule.
* redisplay-xlike-inc.c (separate_textual_runs_xft_nomule):
* redisplay-xlike-inc.c (separate_textual_runs_xft_mule):
Declare TEXT_STORAGE as non-const, even for those functions where
it is not modified, it is not worth the book-keeping to fight
with the C++ compile for it.
* text.c (ibyte_string_displayed_columns):
Removed a compiler-placating USED() that's no longer necessary.
diff -r 2e96482cc410 -r 7053230a0057 src/ChangeLog
--- a/src/ChangeLog Sun Mar 12 11:39:25 2017 +0000
+++ b/src/ChangeLog Sun Mar 12 13:16:09 2017 +0000
＠＠ -1,3 +1,18 ＠＠
+2017-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ Make some small changes to placate the buildbot.
+ * charset.h (Vcharset_control_1):
+ Make this available on non-Mule.
+ * redisplay-xlike-inc.c:
+ Restore ALLOCATE_RUNS_TEXT() for nonmule.
+ * redisplay-xlike-inc.c (separate_textual_runs_xft_nomule):
+ * redisplay-xlike-inc.c (separate_textual_runs_xft_mule):
+ Declare TEXT_STORAGE as non-const, even for those functions where
+ it is not modified, it is not worth the book-keeping to fight
+ with the C++ compile for it.
+ * text.c (ibyte_string_displayed_columns):
+ Removed a compiler-placating USED() that's no longer necessary.
+
2017-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
* text.h (itext_ichar_eql):
diff -r 2e96482cc410 -r 7053230a0057 src/charset.h
--- a/src/charset.h Sun Mar 12 11:39:25 2017 +0000
+++ b/src/charset.h Sun Mar 12 13:16:09 2017 +0000
＠＠ -97,6 +97,8 ＠＠
be done */
#define Vcharset_ascii Qnil
+#define Vcharset_control_1 Qunbound /* A character's charset will never be
+ this. */
#define ichar_charset(ch) Vcharset_ascii
#define ichar_leading_byte(ch) LEADING_BYTE_ASCII
diff -r 2e96482cc410 -r 7053230a0057 src/redisplay-xlike-inc.c
--- a/src/redisplay-xlike-inc.c Sun Mar 12 11:39:25 2017 +0000
+++ b/src/redisplay-xlike-inc.c Sun Mar 12 13:16:09 2017 +0000
＠＠ -176,9 +176,13 ＠＠
*/
#if !defined (USE_XFT) && !defined (MULE)
+
+#define ALLOCATE_RUNS_TEXT(storage, storage_len, str, len) \
+ (storage = alloca_extbytes (len))
+
static int
separate_textual_runs_nomule (struct buffer * UNUSED (buf),
- const Extbyte *text_storage,
+ Extbyte *text_storage,
struct textual_run *run_storage,
const Ibyte *str, Bytecount len,
struct face_cachel *UNUSED(cachel))
＠＠ -222,7 +226,7 ＠＠
UCS-2. */
static int
separate_textual_runs_xft_nomule (struct buffer * UNUSED (buf),
- const Extbyte *text_storage,
+ Extbyte *text_storage,
struct textual_run *run_storage,
const Ibyte *str, Bytecount len,
struct face_cachel *UNUSED (cachel))
＠＠ -243,7 +247,7 ＠＠
#if defined (USE_XFT) && defined (MULE)
static int
separate_textual_runs_xft_mule (struct buffer *buf,
- const Extbyte *text_storage,
+ Extbyte *text_storage,
struct textual_run *run_storage,
const Ibyte *str, Bytecount len,
struct face_cachel *UNUSED (cachel))
＠＠ -262,7 +266,6 ＠＠
Ichar ch = itext_ichar (str);
Lisp_Object charset;
int byte1, byte2;
- int ucs = ichar_to_unicode (ch, CONVERR_SUBSTITUTE);
/* ＠＠#### This use of CONVERR_SUBSTITUTE is somewhat bogus.
It will substitute a '?' if we can't convert. Not clear whether
diff -r 2e96482cc410 -r 7053230a0057 src/text.c
--- a/src/text.c Sun Mar 12 11:39:25 2017 +0000
+++ b/src/text.c Sun Mar 12 13:16:09 2017 +0000
＠＠ -2587,10 +2587,6 ＠＠
INC_IBYTEPTR (str);
}
-#ifndef MULE
- USED (ch);
-#endif
-
return cols;
}
--
‘As I sat looking up at the Guinness ad, I could never figure out /
How your man stayed up on the surfboard after forty pints of stout’
(C. Moore)
- 1 participants
- 0 comments
[COMMIT] Clean up auto-save.el, extend functionality of #'auto-save-{un,}escape-name.
7 years, 7 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1489281373 0
# Sun Mar 12 01:16:13 2017 +0000
# Node ID 55b8780e42f49fe8abaeb84784316dfc4727b70b
# Parent f669d096d3d4491cfd04e5d859a4e9bf9a787d63
Clean up auto-save.el, extend functionality of #'auto-save-{un,}escape-name.
lisp/ChangeLog addition:
2017-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
Clean up auto-save.el, extend the functionality of
#'auto-save-{un,}escape-name.
* auto-save.el:
* auto-save.el (efs-auto-save-remotely):
Always provide a defvar for this, since this file is dumped efs.el
will not be loaded before auto-save.el.
* auto-save.el (auto-save-checked-directory):
Fix some indentation; remove some long-commented code, avoiding
distraction.
* auto-save.el (auto-save-name-in-fixed-directory):
We have DOC now, it's not expensive of RAM to have function
docstrings, uncomment this one.
* auto-save.el (auto-save-name-in-same-directory):
Ditto.
* auto-save.el (auto-save-reserved-chars):
Expand the docstring of this a little.
* auto-save.el (auto-save-escape-name):
Preserve those characters which wouldn't be preserved by
file-name-coding-system in this function.
* auto-save.el (auto-save-unescape-name):
Do the inverse of the newly-added functionality of
#'auto-save-escape-name.
* auto-save.el (auto-save-cyclic-hash-14):
Uncomment the docstring for this function.
tests/ChangeLog addition:
2017-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el:
[...]
Test the new escaping of ESC with the same two functions.
diff -r f669d096d3d4 -r 55b8780e42f4 lisp/ChangeLog
--- a/lisp/ChangeLog Sun Mar 12 00:06:24 2017 +0000
+++ b/lisp/ChangeLog Sun Mar 12 01:16:13 2017 +0000
＠＠ -1,3 +1,31 ＠＠
+2017-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ Clean up auto-save.el, extend the functionality of
+ #'auto-save-{un,}escape-name.
+
+ * auto-save.el:
+ * auto-save.el (efs-auto-save-remotely):
+ Always provide a defvar for this, since this file is dumped efs.el
+ will not be loaded before auto-save.el.
+ * auto-save.el (auto-save-checked-directory):
+ Fix some indentation; remove some long-commented code, avoiding
+ distraction.
+ * auto-save.el (auto-save-name-in-fixed-directory):
+ We have DOC now, it's not expensive of RAM to have function
+ docstrings, uncomment this one.
+ * auto-save.el (auto-save-name-in-same-directory):
+ Ditto.
+ * auto-save.el (auto-save-reserved-chars):
+ Expand the docstring of this a little.
+ * auto-save.el (auto-save-escape-name):
+ Preserve those characters which wouldn't be preserved by
+ file-name-coding-system in this function.
+ * auto-save.el (auto-save-unescape-name):
+ Do the inverse of the newly-added functionality of
+ #'auto-save-escape-name.
+ * auto-save.el (auto-save-cyclic-hash-14):
+ Uncomment the docstring for this function.
+
2017-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
* auto-save.el (auto-save-unescape-name):
diff -r f669d096d3d4 -r 55b8780e42f4 lisp/auto-save.el
--- a/lisp/auto-save.el Sun Mar 12 00:06:24 2017 +0000
+++ b/lisp/auto-save.el Sun Mar 12 01:16:13 2017 +0000
＠＠ -163,12 +163,9 ＠＠
:type 'boolean
:group 'auto-save)
-;;; This defvar is in efs.el now, but doesn't hurt to give it here as
-;;; well so that loading first auto-save.el does not abort.
-
-;; #### Now that `auto-save' is dumped, this is looks obnoxious.
-(or (boundp 'efs-auto-save) (defvar efs-auto-save 0))
-(or (boundp 'efs-auto-save-remotely) (defvar efs-auto-save-remotely nil))
+;; This has a defcustom in efs.el, which unfortunately won't be picked up when
+;; `efs-ftp-path' is autoloaded, because that is in efs-cu.el.
+(defvar efs-auto-save-remotely nil)
(defcustom auto-save-offer-delete nil
"*If non-nil, `recover-all-files' offers to delete autosave files
＠＠ -200,23 +197,15 ＠＠
(defun auto-save-checked-directory (dir)
"Make sure the directory DIR exists and return it expanded if non-nil."
- (when dir
- (setq dir (expand-file-name dir))
- ;; Make sure directory exists
- (unless (file-directory-p dir)
- ;; Else we create and chmod 0700 the directory
- (setq dir (directory-file-name dir)) ; some systems need this
- (make-directory dir)
- (set-file-modes dir #o700))
- dir))
-
-;; This make no sense at dump time
-;; (mapc #'auto-save-check-directory
-; '(auto-save-directory auto-save-directory-fallback))
-
-;(and auto-save-hash-p
-; (auto-save-check-directory 'auto-save-hash-directory))
-
+ (when dir
+ (setq dir (expand-file-name dir))
+ ;; Make sure directory exists
+ (unless (file-directory-p dir)
+ ;; Else we create and chmod 0700 the directory
+ (setq dir (directory-file-name dir)) ; some systems need this
+ (make-directory dir)
+ (set-file-modes dir #o700))
+ dir))
;;; Computing an autosave name for a file and vice versa
＠＠ -349,13 +338,14 ＠＠
(concat savedir (substring basename 1 -1))))))
(defun auto-save-name-in-fixed-directory (filename &optional prefix)
- ;; Escape and enclose the whole FILENAME in `#' to make an auto
- ;; save file in the auto-save-directory, or if that is nil, in
- ;; auto-save-directory-fallback (which must be the name of an
- ;; existing directory). If the results would be too long for 14
- ;; character filenames, and `auto-save-hash-p' is set, hash FILENAME
- ;; into a shorter name.
- ;; Optional PREFIX is string to use instead of "#" to prefix name.
+ "Escape FILENAME using `#' to make a file in `auto-save-directory'.
+
+If `auto-save-directory' is nil, make a file in `auto-save-directory-fallback'
+(which must be the name of an existing directory). If the results would be
+too long for 14 character filenames, and `auto-save-hash-p' is set, hash
+FILENAME into a shorter name.
+
+Optional PREFIX is string to use instead of \"#\" to prefix FILENAME."
(let ((base-name (concat (or prefix "#")
(auto-save-escape-name filename)
"#")))
＠＠ -363,20 +353,23 ＠＠
auto-save-hash-directory
(> (length base-name) 14))
(expand-file-name (auto-save-cyclic-hash-14 filename)
- (auto-save-checked-directory auto-save-hash-directory))
+ (auto-save-checked-directory
+ auto-save-hash-directory))
(expand-file-name base-name
(auto-save-checked-directory
(or auto-save-directory
auto-save-directory-fallback))))))
(defun auto-save-name-in-same-directory (filename &optional prefix)
- ;; Enclose the non-directory part of FILENAME in `#' to make an auto
- ;; save file in the same directory as FILENAME. But if this
- ;; directory is not writable, use auto-save-directory-fallback.
- ;; FILENAME is assumed to be in non-directory form (no trailing slash).
- ;; It may be a name without a directory part (presumably it really
- ;; comes from a buffer name then), the fallback is used then.
- ;; Optional PREFIX is string to use instead of "#" to prefix name.
+ "Escape FILENAME using `#', creating an auto-save name in its directory.
+
+If that directory is not writable, use `auto-save-directory-fallback'.
+
+FILENAME is assumed to be in non-directory form (no trailing slash). It may
+be a name without a directory part, in which case the current directory is
+used.
+
+Optional PREFIX is string to use instead of \"#\" to prefix FILENAME."
(let ((directory (file-name-directory filename)))
(or (null directory)
(file-writable-p directory)
＠＠ -388,75 +381,83 ＠＠
"#")))
(defconst auto-save-reserved-chars
- '(
- ?\0 ?\1 ?\2 ?\3 ?\4 ?\5 ?\6 ?\7 ?\10 ?\11 ?\12 ?\13 ?\14 ?\15 ?\16
+ '(?\0 ?\1 ?\2 ?\3 ?\4 ?\5 ?\6 ?\7 ?\10 ?\11 ?\12 ?\13 ?\14 ?\15 ?\16
?\17 ?\20 ?\21 ?\22 ?\23 ?\24 ?\25 ?\26 ?\27 ?\30 ?\31 ?\32 ?\33
?\34 ?\35 ?\36 ?\37 ?\40 ?? ?* ?: ?< ?> ?| ?/ ?\\ ?& ?^ ?% ?= ?\")
"List of characters disallowed (or potentially disallowed) in filenames.
-Includes everything that can get us into trouble under MS Windows or Unix.")
-;; This code based on code in Bill Perry's url.el.
-
-(defun auto-save-escape-name (str)
- "Escape any evil nasty characters in a potential filename.
-Uses quoted-printable-style escaping -- e.g. the dreaded =3D.
-Does not use URL escaping (with %) because filenames beginning with #% are
-a special signal for non-file buffers."
- (mapconcat
- (function
- (lambda (char)
- (if (memq char auto-save-reserved-chars)
- (if (< char 16)
- (upcase (format "=0%x" char))
- (upcase (format "=%x" char)))
- (list char))))
- str ""))
+Includes everything that can get us into trouble under MS Windows or Unix.
+Characters that `file-name-coding-system' cannot handle are dealt with
+separately from this list.")
-(defun auto-save-unescape-name (str)
- "Undo any escaping of evil nasty characters in a file name.
+;; This code based (ultimately) on code in Bill Perry's url.el.
+
+(defun auto-save-escape-name (string)
+ "Escape any reserved characters in a potential filename.
+
+Uses quoted-printable-style escaping -- e.g. =3D. Does not use URL escaping
+(with %) because filenames beginning with #% are a special signal for non-file
+buffers.
+
+If STRING contains characters that `file-name-coding-system' cannot encode,
+these are also escaped, after having been transformed to `escape-quoted'
+encoding. Both operations are reversed by `auto-save-unescape-name', which
+see."
+ (let ((start 0) stream)
+ (multiple-value-bind (ignored details)
+ (query-coding-string string 'file-name)
+ (declare (special ignored))
+ (loop for char being each element in string using (index index)
+ if (or (memq char auto-save-reserved-chars)
+ (and details (get-range-table index details)))
+ do (progn
+ (write-sequence string (or stream
+ (setq stream
+ (make-string-output-stream)))
+ :start start :end index)
+ (if (or (eql char ?\033)
+ (> char (load-time-value
+ (reduce #'max auto-save-reserved-chars))))
+ (loop for character
+ ;; We know escape-quoted can encode the file name!
+ across (encode-coding-char char 'escape-quoted)
+ do (format-into stream "=%02X" character))
+ (format-into stream "=%02X" char))
+ (setf start (1+ index))))
+ (if stream
+ (get-output-stream-string
+ (prog1 stream (write-sequence string stream :start start)))
+ string))))
+
+(defun auto-save-unescape-name (string)
+ "Undo any escaping of reserved characters in STRING.
+
See `auto-save-escape-name'."
- (setq str (or str ""))
- (let ((tmp "")
- (case-fold-search t))
- (while (string-match #r"=\([0-9a-f][0-9a-f]\)" str)
- (let* ((start (match-beginning 0))
- (code (parse-integer str :start (match-beginning 1)
- :end (match-end 1) :radix 16)))
- (setq tmp (concat tmp (substring str 0 start)
- (list code))
- str (substring str (match-end 0)))))
- (setq tmp (concat tmp str))
- tmp))
-
-;; The old versions are below.
-
-;(defun auto-save-escape-name (s)
-; ;; "Quote any slashes in string S by replacing them with the two
-; ;;characters `\\!'.
-; ;;Also, replace any backslash by double backslash, to make it one-to-one."
-; (let ((limit 0))
-; (while (string-match "[/\\]" s limit)
-; (setq s (concat (substring s 0 (match-beginning 0))
-; (if (string= (substring s
-; (match-beginning 0)
-; (match-end 0))
-; "/")
-; "\\!"
-; "\\\\")
-; (substring s (match-end 0))))
-; (setq limit (1+ (match-end 0)))))
-; s)
-
-;(defun auto-save-unescape-name (s)
-; ;;"Reverse of `auto-save-escape-name'."
-; (let (pos)
-; (while (setq pos (string-match "\\\\[\\!]" s pos))
-; (setq s (concat (substring s 0 pos)
-; (if (eq ?! (aref s (1+ pos))) "/" "\\")
-; (substring s (+ pos 2)))
-; pos (1+ pos))))
-; s)
-
+ (let ((start 0) (string (or string "")) offset stream fixnum decode)
+ (while (setq offset
+ (string-match-p #r"=[[:xdigit:]]\{2,2\}" string start))
+ (write-sequence string (or stream
+ (setq stream (make-string-output-stream)))
+ :start start :end offset)
+ (write-char (setq fixnum
+ (parse-integer string :start (+ offset (length "="))
+ :end (+ offset (length "=ab"))
+ :radix 16))
+ stream)
+ (or (and ;; ESC will have been doubled, it always needs decoding.
+ (not (eql fixnum #o033))
+ (memq (int-char fixnum) auto-save-reserved-chars))
+ (setf decode t))
+ (setf start (+ offset (length "=ab"))))
+ (if stream
+ (if decode
+ (decode-coding-string
+ (get-output-stream-string
+ (prog1 stream (write-sequence string stream :start start)))
+ 'escape-quoted t)
+ (get-output-stream-string
+ (prog1 stream (write-sequence string stream :start start))))
+ string)))
;;; Hashing for autosave names
＠＠ -464,11 +465,11 ＠＠
;;; based upon C code from pot(a)fly.cnuce.cnr.IT (Francesco Potorti`).
(defun auto-save-cyclic-hash-14 (s)
- ;; "Hash string S into a string of length 14.
- ;; A 7-bytes cyclic code for burst correction is calculated on a
- ;; byte-by-byte basis. The polynomial used is D^7 + D^6 + D^3 +1.
- ;; The resulting string consists of hexadecimal digits [0-9a-f].
- ;; In particular, it contains no slash, so it can be used as autosave name."
+ "Hash string S into a string of length 14.
+A 7-bytes cyclic code for burst correction is calculated on a
+byte-by-byte basis. The polynomial used is D^7 + D^6 + D^3 +1.
+The resulting string consists of hexadecimal digits [0-9a-f].
+In particular, it contains no slash, so it can be used as autosave name."
(let ((crc (make-vector 7 ?\0)))
(mapc
(lambda (new)
＠＠ -489,38 +490,6 ＠＠
(logand 255 (aref crc 4))
(logand 255 (aref crc 5))
(logand 255 (aref crc 6)))))
-
-;; #### It is unclear to me how the following function is useful. It
-;; should be used in `auto-save-name-in-same-directory', if anywhere.
-;; -hniksic
-
-;; This leaves two characters that could be used to wrap it in `#' or
-;; make two filenames from it: one for autosaving, and another for a
-;; file containing the name of the autosaved file, to make hashing
-;; reversible.
-;(defun auto-save-cyclic-hash-12 (s)
-; "Outputs the 12-characters ascii hex representation of a 6-bytes
-;cyclic code for burst correction calculated on STRING on a
-;byte-by-byte basis. The used polynomial is D^6 + D^5 + D^4 + D^3 +1."
-; (let ((crc (make-string 6 0)))
-; (mapc
-; (lambda (new)
-; (setq new (+ new (aref crc 5)))
-; (aset crc 5 (+ (aref crc 4) new))
-; (aset crc 4 (+ (aref crc 3) new))
-; (aset crc 3 (+ (aref crc 2) new))
-; (aset crc 2 (aref crc 1))
-; (aset crc 1 (aref crc 0))
-; (aset crc 0 new))
-; s)
-; (format "%02x%02x%02x%02x%02x%02x"
-; (aref crc 0)
-; (aref crc 1)
-; (aref crc 2)
-; (aref crc 3)
-; (aref crc 4)
-; (aref crc 5))))
-
;;; Recovering files
diff -r f669d096d3d4 -r 55b8780e42f4 tests/ChangeLog
--- a/tests/ChangeLog Sun Mar 12 00:06:24 2017 +0000
+++ b/tests/ChangeLog Sun Mar 12 01:16:13 2017 +0000
＠＠ -4,6 +4,7 ＠＠
Add a parenthesis which had gone astray while merging.
Test #'auto-save-escape-name, #'auto-save-unescape-name,
reasonably important functions which previously had no testing.
+ Test the new escaping of ESC with the same two functions.
2017-03-03 Aidan Kehoe <kehoea(a)parhasard.net>
diff -r f669d096d3d4 -r 55b8780e42f4 tests/automated/lisp-tests.el
--- a/tests/automated/lisp-tests.el Sun Mar 12 00:06:24 2017 +0000
+++ b/tests/automated/lisp-tests.el Sun Mar 12 01:16:13 2017 +0000
＠＠ -4240,12 +4240,23 ＠＠
,(format "hello=20=%02Xab" char))
,(format "hello %cab" char))))))))
(create-individual-char-tests
- ;; This is the value of auto-save-reserved-chars. Don't reference the
- ;; variable from the test code, we want the set to be stable.
+ ;; This is (almost) the value of auto-save-reserved-chars. Don't reference
+ ;; the variable from the test code, we want the set to be stable.
?\0 ?\1 ?\2 ?\3 ?\4 ?\5 ?\6 ?\7 ?\10 ?\11 ?\12 ?\13 ?\14 ?\15 ?\16
- ?\17 ?\20 ?\21 ?\22 ?\23 ?\24 ?\25 ?\26 ?\27 ?\30 ?\31 ?\32 ?\33
+ ?\17 ?\20 ?\21 ?\22 ?\23 ?\24 ?\25 ?\26 ?\27 ?\30 ?\31 ?\32 ; ?\33
?\34 ?\35 ?\36 ?\37 ?\40 ?? ?* ?: ?< ?> ?| ?/ ?\\ ?& ?^ ?% ?= ?\"))
+;; Test ?\33 separately, since it is doubled because of the escape-quoting.
+
+(Assert (equal (auto-save-escape-name "hello there")
+ "hello=20=1B=1B=20there"))
+(Assert (equal (auto-save-unescape-name "hello=20=1B=1B=20there")
+ "hello there"))
+(Assert (equal (auto-save-escape-name "hello ") "hello=20=1B=1B"))
+(Assert (equal (auto-save-unescape-name "hello=20=1B=1B") "hello "))
+(Assert (equal (auto-save-escape-name "hello ab") "hello=20=1B=1Bab"))
+(Assert (equal (auto-save-unescape-name "hello=20=1B=1Bab") "hello ab"))
+
(when (featurep 'mule)
(let ((file-name-alias (coding-system-aliasee 'file-name))
(complicated-file-name
--
‘As I sat looking up at the Guinness ad, I could never figure out /
How your man stayed up on the surfboard after forty pints of stout’
(C. Moore)
- 1 participants
- 0 comments
[COMMIT] Fix a bug in #'auto-save-unescape-name, test same.
7 years, 7 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1489277184 0
# Sun Mar 12 00:06:24 2017 +0000
# Node ID f669d096d3d4491cfd04e5d859a4e9bf9a787d63
# Parent a9aed431763dcc4a4b7a79c30c410be07fec9ffb
Fix a bug in #'auto-save-unescape-name, test same.
lisp/ChangeLog addition:
2017-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
* auto-save.el (auto-save-unescape-name):
Fix a bug in this, limit the hex parsing correctly.
tests/ChangeLog addition:
2017-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el:
Add a parenthesis which had gone astray while merging.
Test #'auto-save-escape-name, #'auto-save-unescape-name,
reasonably important functions which previously had no testing.
diff -r a9aed431763d -r f669d096d3d4 lisp/ChangeLog
--- a/lisp/ChangeLog Sat Mar 11 16:28:54 2017 +0000
+++ b/lisp/ChangeLog Sun Mar 12 00:06:24 2017 +0000
＠＠ -1,3 +1,8 ＠＠
+2017-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * auto-save.el (auto-save-unescape-name):
+ Fix a bug in this, limit the hex parsing correctly.
+
2017-03-09 Aidan Kehoe <kehoea(a)parhasard.net>
diff -r a9aed431763d -r f669d096d3d4 lisp/auto-save.el
--- a/lisp/auto-save.el Sat Mar 11 16:28:54 2017 +0000
+++ b/lisp/auto-save.el Sun Mar 12 00:06:24 2017 +0000
＠＠ -421,7 +421,7 ＠＠
(while (string-match #r"=\([0-9a-f][0-9a-f]\)" str)
(let* ((start (match-beginning 0))
(code (parse-integer str :start (match-beginning 1)
- :end (match-end 2) :radix 16)))
+ :end (match-end 1) :radix 16)))
(setq tmp (concat tmp (substring str 0 start)
(list code))
str (substring str (match-end 0)))))
diff -r a9aed431763d -r f669d096d3d4 tests/ChangeLog
--- a/tests/ChangeLog Sat Mar 11 16:28:54 2017 +0000
+++ b/tests/ChangeLog Sun Mar 12 00:06:24 2017 +0000
＠＠ -1,3 +1,10 ＠＠
+2017-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/lisp-tests.el:
+ Add a parenthesis which had gone astray while merging.
+ Test #'auto-save-escape-name, #'auto-save-unescape-name,
+ reasonably important functions which previously had no testing.
+
2017-03-03 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/regexp-tests.el:
diff -r a9aed431763d -r f669d096d3d4 tests/automated/lisp-tests.el
--- a/tests/automated/lisp-tests.el Sat Mar 11 16:28:54 2017 +0000
+++ b/tests/automated/lisp-tests.el Sun Mar 12 00:06:24 2017 +0000
＠＠ -3830,7 +3830,7 ＠＠
(Assert (>= 35 max) "checking base 36 is supported, `digit-fixnum-map'")
(Assert (<= min 2) "checking base two supported, `digit-fixnum-map'")
(Assert (eql (digit-char-p max-char (1+ max)) max))
- (Assert (eql (digit-char-p min-char (1+ min)) min))
+ (Assert (eql (digit-char-p min-char (1+ min)) min)))
(let ((binary-table
(copy-char-table #s(char-table :type generic :default -1 :data ()))))
＠＠ -4201,4 +4201,65 ＠＠
'#:g3456)))
(eval form)))
+;;-----------------------------------------------------
+;; Test `auto-save-escape-name', `auto-save-unescape-name'
+;;-----------------------------------------------------
+
+(Assert (equal (auto-save-escape-name "abcdefghijk") "abcdefghijk"))
+
+;; We don't check whether auto-save-escape-name creates a new string object
+;; when there are no characters that need escaping.
+
+(Assert (equal (auto-save-escape-name "") ""))
+
+(Assert (equal (auto-save-escape-name "���") "���"))
+
+(Assert (not (eq (auto-save-escape-name "abcdefghijk") "abcdefghijk")))
+
+(macrolet
+ ((create-individual-char-tests (&rest characters)
+ (cons
+ 'progn
+ (loop for char in characters
+ nconc `((Assert (equal (auto-save-escape-name
+ ,(format "hello %c there" char))
+ ,(format "hello=20=%02X=20there" char)))
+ (Assert (equal (auto-save-unescape-name
+ ,(format "hello=20=%02X=20there" char))
+ ,(format "hello %c there" char)))
+ (Assert (equal (auto-save-escape-name
+ ,(format "hello %c" char))
+ ,(format "hello=20=%02X" char)))
+ (Assert (equal (auto-save-unescape-name
+ ,(format "hello=20=%02X" char))
+ ,(format "hello %c" char)))
+ (Assert (equal (auto-save-escape-name
+ ,(format "hello %cab" char))
+ ,(format "hello=20=%02Xab" char)))
+ (Assert (equal (auto-save-unescape-name
+ ,(format "hello=20=%02Xab" char))
+ ,(format "hello %cab" char))))))))
+ (create-individual-char-tests
+ ;; This is the value of auto-save-reserved-chars. Don't reference the
+ ;; variable from the test code, we want the set to be stable.
+ ?\0 ?\1 ?\2 ?\3 ?\4 ?\5 ?\6 ?\7 ?\10 ?\11 ?\12 ?\13 ?\14 ?\15 ?\16
+ ?\17 ?\20 ?\21 ?\22 ?\23 ?\24 ?\25 ?\26 ?\27 ?\30 ?\31 ?\32 ?\33
+ ?\34 ?\35 ?\36 ?\37 ?\40 ?? ?* ?: ?< ?> ?| ?/ ?\\ ?& ?^ ?% ?= ?\"))
+
+(when (featurep 'mule)
+ (let ((file-name-alias (coding-system-aliasee 'file-name))
+ (complicated-file-name
+ (decode-coding-string "/hel\xc5\x82o\n" 'utf-8)))
+ (unwind-protect
+ (progn
+ ;; Check that we preserve data that may be lost by the file-name
+ ;; coding system.
+ (define-coding-system-alias 'file-name 'iso-8859-1)
+ (Assert (equal complicated-file-name
+ (auto-save-unescape-name
+ (encode-coding-string
+ (auto-save-escape-name complicated-file-name)
+ 'file-name t)))))
+ (define-coding-system-alias 'file-name file-name-alias))))
+
;;; end of lisp-tests.el
--
‘As I sat looking up at the Guinness ad, I could never figure out /
How your man stayed up on the surfboard after forty pints of stout’
(C. Moore)
- 1 participants
- 0 comments