256 lines
9.4 KiB
EmacsLisp
256 lines
9.4 KiB
EmacsLisp
;;; puny.el --- translate non-ASCII domain names to ASCII -*- lexical-binding:t -*-
|
|
|
|
;; Copyright (C) 2015-2024 Free Software Foundation, Inc.
|
|
|
|
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
|
|
;; Keywords: mail, net
|
|
|
|
;; 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 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; 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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;; Written by looking at
|
|
;; https://stackoverflow.com/questions/183485/can-anyone-recommend-a-good-free-javascript-for-punycode-to-unicode-conversion
|
|
|
|
;;; Code:
|
|
|
|
(eval-when-compile (require 'cl-lib))
|
|
(require 'seq)
|
|
|
|
(defun puny-encode-domain (domain)
|
|
"Encode DOMAIN according to the IDNA/punycode algorithm.
|
|
For instance, \"fśf.org\" => \"xn--ff-2sa.org\"."
|
|
;; The vast majority of domain names are not IDNA domain names, so
|
|
;; add a check first to avoid doing unnecessary work.
|
|
(if (string-match "\\`[[:ascii:]]+\\'" domain)
|
|
domain
|
|
(mapconcat #'puny-encode-string (split-string domain "[.]") ".")))
|
|
|
|
(defun puny-encode-string (string)
|
|
"Encode STRING according to the IDNA/punycode algorithm.
|
|
This is used to encode non-ASCII domain names.
|
|
For instance, \"bücher\" => \"xn--bcher-kva\"."
|
|
(setq string (downcase (string-glyph-compose string)))
|
|
(let ((ascii (seq-filter (lambda (char)
|
|
(< char 128))
|
|
string)))
|
|
(if (= (length ascii) (length string))
|
|
string
|
|
(concat "xn--"
|
|
(if (null ascii)
|
|
""
|
|
(concat ascii "-"))
|
|
(puny-encode-complex (length ascii) string)))))
|
|
|
|
(defun puny-decode-domain (domain)
|
|
"Decode DOMAIN according to the IDNA/punycode algorithm.
|
|
For instance, \"xn--ff-2sa.org\" => \"fśf.org\"."
|
|
(mapconcat #'puny-decode-string (split-string domain "[.]") "."))
|
|
|
|
(defun puny-decode-string (string)
|
|
"Decode an IDNA/punycode-encoded string.
|
|
For instance \"xn--bcher-kva\" => \"bücher\"."
|
|
(if (string-match "\\`xn--" string)
|
|
(condition-case nil
|
|
(puny-decode-string-internal (substring string 4))
|
|
;; If the string is invalid Punycode, just return the string.
|
|
(args-out-of-range string))
|
|
string))
|
|
|
|
(defconst puny-initial-n 128)
|
|
(defconst puny-initial-bias 72)
|
|
(defconst puny-base 36)
|
|
(defconst puny-damp 700)
|
|
(defconst puny-tmin 1)
|
|
(defconst puny-tmax 26)
|
|
(defconst puny-skew 38)
|
|
|
|
;; 0-25 a-z
|
|
;; 26-36 0-9
|
|
(defun puny-encode-digit (d)
|
|
(if (< d 26)
|
|
(+ ?a d)
|
|
(+ ?0 (- d 26))))
|
|
|
|
(defun puny-adapt (delta num-points first-time)
|
|
(let ((delta (if first-time
|
|
(/ delta puny-damp)
|
|
(/ delta 2)))
|
|
(k 0))
|
|
(setq delta (+ delta (/ delta num-points)))
|
|
(while (> delta (/ (* (- puny-base puny-tmin)
|
|
puny-tmax)
|
|
2))
|
|
(setq delta (/ delta (- puny-base puny-tmin))
|
|
k (+ k puny-base)))
|
|
(+ k (/ (* (1+ (- puny-base puny-tmin)) delta)
|
|
(+ delta puny-skew)))))
|
|
|
|
(defun puny-encode-complex (insertion-points string)
|
|
(let ((n puny-initial-n)
|
|
(delta 0)
|
|
(bias puny-initial-bias)
|
|
(h insertion-points)
|
|
result m ijv q)
|
|
(while (< h (length string))
|
|
(setq ijv (cl-loop for char across string
|
|
when (>= char n)
|
|
minimize char))
|
|
(setq m ijv)
|
|
(setq delta (+ delta (* (- m n) (+ h 1)))
|
|
n m)
|
|
(cl-loop for char across string
|
|
when (< char n)
|
|
do (cl-incf delta)
|
|
when (= char ijv)
|
|
do (progn
|
|
(setq q delta)
|
|
(cl-loop with k = puny-base
|
|
for t1 = (cond
|
|
((<= k bias)
|
|
puny-tmin)
|
|
((>= k (+ bias puny-tmax))
|
|
puny-tmax)
|
|
(t
|
|
(- k bias)))
|
|
while (>= q t1)
|
|
do (push (puny-encode-digit
|
|
(+ t1 (mod (- q t1)
|
|
(- puny-base t1))))
|
|
result)
|
|
do (setq q (/ (- q t1) (- puny-base t1))
|
|
k (+ k puny-base)))
|
|
(push (puny-encode-digit q) result)
|
|
(setq bias (puny-adapt delta (+ h 1) (= h insertion-points))
|
|
delta 0
|
|
h (1+ h))))
|
|
(cl-incf delta)
|
|
(cl-incf n))
|
|
(nreverse result)))
|
|
|
|
(defun puny-decode-digit (cp)
|
|
(cond
|
|
((<= cp ?9)
|
|
(+ (- cp ?0) 26))
|
|
((<= cp ?Z)
|
|
(- cp ?A))
|
|
((<= cp ?z)
|
|
(- cp ?a))
|
|
(t
|
|
puny-base)))
|
|
|
|
(defun puny-decode-string-internal (string)
|
|
(with-temp-buffer
|
|
(insert string)
|
|
;; The encoded chars are after any final dash, else the whole string.
|
|
(let ((encoded (buffer-substring
|
|
(if (search-backward "-" nil 'move)
|
|
(1+ (point))
|
|
(point))
|
|
(point-max)))
|
|
(ic 0)
|
|
(i 0)
|
|
(bias puny-initial-bias)
|
|
(n puny-initial-n)
|
|
out)
|
|
(delete-region (point) (point-max))
|
|
(while (< ic (length encoded))
|
|
(let ((old-i i)
|
|
(w 1)
|
|
(k puny-base)
|
|
digit t1)
|
|
(cl-loop do (progn
|
|
(setq digit (puny-decode-digit (aref encoded ic)))
|
|
(cl-incf ic)
|
|
(cl-incf i (* digit w))
|
|
(setq t1 (cond
|
|
((<= k bias)
|
|
puny-tmin)
|
|
((>= k (+ bias puny-tmax))
|
|
puny-tmax)
|
|
(t
|
|
(- k bias)))))
|
|
while (>= digit t1)
|
|
do (setq w (* w (- puny-base t1))
|
|
k (+ k puny-base)))
|
|
(setq out (1+ (buffer-size)))
|
|
(setq bias (puny-adapt (- i old-i) out (= old-i 0))))
|
|
|
|
(setq n (+ n (/ i out))
|
|
i (mod i out))
|
|
(goto-char (point-min))
|
|
(forward-char i)
|
|
(insert (format "%c" n))
|
|
(cl-incf i)))
|
|
(buffer-string)))
|
|
|
|
;; https://www.unicode.org/reports/tr39/#Restriction_Level_Detection
|
|
;; https://www.unicode.org/reports/tr31/#Table_Candidate_Characters_for_Inclusion_in_Identifiers
|
|
|
|
(defun puny-highly-restrictive-string-p (string)
|
|
"Say whether STRING is \"highly restrictive\" in the Unicode IDNA sense.
|
|
See https://www.unicode.org/reports/tr39/#Restriction_Level_Detection
|
|
for details. The main idea is that if you're mixing
|
|
scripts (like latin and cyrillic), you may confuse the user by
|
|
using homographs."
|
|
(let ((scripts
|
|
(delq
|
|
t
|
|
(seq-uniq
|
|
(seq-map (lambda (char)
|
|
(if (memq char
|
|
;; These characters are always allowed
|
|
;; in any string.
|
|
'(#x0027 ; APOSTROPHE
|
|
#x002D ; HYPHEN-MINUS
|
|
#x002E ; FULL STOP
|
|
#x003A ; COLON
|
|
#x00B7 ; MIDDLE DOT
|
|
#x058A ; ARMENIAN HYPHEN
|
|
#x05F3 ; HEBREW PUNCTUATION GERESH
|
|
#x05F4 ; HEBREW PUNCTUATION GERSHAYIM
|
|
#x0F0B ; TIBETAN MARK INTERSYLLABIC TSHEG
|
|
#x200C ; ZERO WIDTH NON-JOINER*
|
|
#x200D ; ZERO WIDTH JOINER*
|
|
#x2010 ; HYPHEN
|
|
#x2019 ; RIGHT SINGLE QUOTATION MARK
|
|
#x2027 ; HYPHENATION POINT
|
|
#x30A0 ; KATAKANA-HIRAGANA DOUBLE HYPHEN
|
|
#x30FB)) ; KATAKANA MIDDLE DOT
|
|
t
|
|
(aref char-script-table char)))
|
|
string)))))
|
|
(or
|
|
;; Every character uses the same script.
|
|
(= (length scripts) 1)
|
|
(seq-some 'identity
|
|
(mapcar (lambda (list)
|
|
(seq-every-p (lambda (script)
|
|
(memq script list))
|
|
scripts))
|
|
'((latin han hiragana kana)
|
|
(latin han bopomofo)
|
|
(latin han hangul)))))))
|
|
|
|
(defun puny-highly-restrictive-domain-p (domain)
|
|
"Say whether DOMAIN is \"highly restrictive\" in the Unicode IDNA sense.
|
|
See `puny-highly-restrictive-string-p' for further details."
|
|
(seq-every-p 'puny-highly-restrictive-string-p (split-string domain "[.]")))
|
|
|
|
(provide 'puny)
|
|
|
|
;;; puny.el ends here
|