diff options
Diffstat (limited to 'lisp/net')
| -rw-r--r-- | lisp/net/eww.el | 14 | ||||
| -rw-r--r-- | lisp/net/network-stream.el | 12 | ||||
| -rw-r--r-- | lisp/net/puny.el | 238 | ||||
| -rw-r--r-- | lisp/net/shr.el | 37 |
4 files changed, 287 insertions, 14 deletions
diff --git a/lisp/net/eww.el b/lisp/net/eww.el index e8fdc972fb3..107df24e865 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -409,9 +409,11 @@ Currently this means either text/html or application/xhtml+xml." (shr-target-id (url-target (url-generic-parse-url url))) (shr-external-rendering-functions (append + shr-external-rendering-functions '((title . eww-tag-title) (form . eww-tag-form) (input . eww-tag-input) + (button . eww-form-submit) (textarea . eww-tag-textarea) (select . eww-tag-select) (link . eww-tag-link) @@ -680,6 +682,7 @@ the like." (define-key map "E" 'eww-set-character-encoding) (define-key map "S" 'eww-list-buffers) (define-key map "F" 'eww-toggle-fonts) + (define-key map [(meta C)] 'eww-toggle-colors) (define-key map "b" 'eww-add-bookmark) (define-key map "B" 'eww-list-bookmarks) @@ -704,6 +707,8 @@ the like." ["Add bookmark" eww-add-bookmark t] ["List bookmarks" eww-list-bookmarks t] ["List cookies" url-cookie-list t] + ["Toggle fonts" eww-toggle-fonts t] + ["Toggle colors" eww-toggle-colors t] ["Character Encoding" eww-set-character-encoding])) map)) @@ -1493,6 +1498,15 @@ If CHARSET is nil then use UTF-8." "off")) (eww-reload)) +(defun eww-toggle-colors () + "Toggle whether to use HTML-specified colors or not." + (interactive) + (message "Colors are now %s" + (if (setq shr-use-colors (not shr-use-colors)) + "on" + "off")) + (eww-reload)) + ;;; Bookmarks code (defvar eww-bookmarks nil) diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index 1eb5342009c..8e1ad637b29 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -46,6 +46,7 @@ (require 'starttls) (require 'auth-source) (require 'nsm) +(require 'puny) (autoload 'gnutls-negotiate "gnutls") (autoload 'open-gnutls-stream "gnutls") @@ -148,7 +149,7 @@ asynchronously, if possible." (plist-get parameters :capability-command)))))) ;; The simplest case: wrapper around `make-network-process'. (make-network-process :name name :buffer buffer - :host host :service service + :host (puny-encode-domain host) :service service :nowait (plist-get parameters :nowait)) (let ((work-buffer (or buffer (generate-new-buffer " *stream buffer*"))) @@ -198,7 +199,8 @@ asynchronously, if possible." (defun network-stream-open-plain (name buffer host service parameters) (let ((start (with-current-buffer buffer (point))) (stream (make-network-process :name name :buffer buffer - :host host :service service + :host (puny-encode-domain host) + :service service :nowait (plist-get parameters :nowait)))) (when (plist-get parameters :warn-unless-encrypted) (setq stream (nsm-verify-connection stream host service nil t))) @@ -219,7 +221,8 @@ asynchronously, if possible." eoc)) ;; Return (STREAM GREETING CAPABILITIES RESULTING-TYPE) (stream (make-network-process :name name :buffer buffer - :host host :service service)) + :host (puny-encode-domain host) + :service service)) (greeting (and (not (plist-get parameters :nogreeting)) (network-stream-get-response stream start eoc))) (capabilities (network-stream-command stream capability-command @@ -296,7 +299,8 @@ asynchronously, if possible." (unless require-tls (setq stream (make-network-process :name name :buffer buffer - :host host :service service)) + :host (puny-encode-domain host) + :service service)) (network-stream-get-response stream start eoc))) ;; Re-get the capabilities, which may have now changed. (setq capabilities diff --git a/lisp/net/puny.el b/lisp/net/puny.el new file mode 100644 index 00000000000..ac47e13c97d --- /dev/null +++ b/lisp/net/puny.el @@ -0,0 +1,238 @@ +;;; puny.el --- translate non-ASCII domain names to ASCII + +;; Copyright (C) 2015 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 <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Written by looking at +;; http://stackoverflow.com/questions/183485/can-anyone-recommend-a-good-free-javascript-for-punycode-to-unicode-conversion + +;;; Code: + +(require 'seq) + +(defun puny-encode-domain (domain) + "Encode DOMAIN according to the IDNA/punycode algorith. +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\"." + (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 algorith. +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) + (puny-decode-string-internal (substring string 4)) + 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 28) + +;; 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) + (goto-char (point-max)) + (search-backward "-" nil (point-min)) + ;; The encoded chars are after the final dash. + (let ((encoded (buffer-substring (1+ (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))) + +;; http://www.unicode.org/reports/tr39/#Restriction_Level_Detection +;; http://www.unicode.org/reports/tr31/#Table_Candidate_Characters_for_Inclusion_in_Identifiers + +(defun puny-highly-restrictive-p (string) + (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 ; IBETAN MARK INTERSYLLABIC TSHEG + #x200C ; ERO WIDTH NON-JOINER* + #x200D ; ERO WIDTH JOINER* + #x2010 ; YPHEN + #x2019 ; IGHT SINGLE QUOTATION MARK + #x2027 ; YPHENATION 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))))))) + +(provide 'puny) + +;;; puny.el ends here diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 330f7b5d84b..0effa93b197 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -63,6 +63,12 @@ fit these criteria." :group 'shr :type 'boolean) +(defcustom shr-use-colors t + "If non-nil, respect color specifications in the HTML." + :version "25.2" + :group 'shr + :type 'boolean) + (defcustom shr-table-horizontal-line nil "Character used to draw horizontal table lines. If nil, don't draw horizontal table lines." @@ -135,6 +141,14 @@ cid: URL as the argument.") (defvar shr-inhibit-images nil "If non-nil, inhibit loading images.") +(defvar shr-external-rendering-functions nil + "Alist of tag/function pairs used to alter how shr renders certain tags. +For instance, eww uses this to alter rendering of title, forms +and other things: +((title . eww-tag-title) + (form . eww-tag-form) + ...)") + ;;; Internal variables. (defvar shr-folding-mode nil) @@ -150,7 +164,6 @@ cid: URL as the argument.") (defvar shr-depth 0) (defvar shr-warning nil) (defvar shr-ignore-cache nil) -(defvar shr-external-rendering-functions nil) (defvar shr-target-id nil) (defvar shr-table-separator-length 1) (defvar shr-table-separator-pixel-width 0) @@ -429,11 +442,10 @@ size, and full-buffer size." (defun shr-descend (dom) (let ((function - (or - ;; Allow other packages to override (or provide) rendering - ;; of elements. - (cdr (assq (dom-tag dom) shr-external-rendering-functions)) - (intern (concat "shr-tag-" (symbol-name (dom-tag dom))) obarray))) + (intern (concat "shr-tag-" (symbol-name (dom-tag dom))) obarray)) + ;; Allow other packages to override (or provide) rendering + ;; of elements. + (external (cdr (assq (dom-tag dom) shr-external-rendering-functions))) (style (dom-attr dom 'style)) (shr-stylesheet shr-stylesheet) (shr-depth (1+ shr-depth)) @@ -448,9 +460,12 @@ size, and full-buffer size." (setq style nil))) ;; If we have a display:none, then just ignore this part of the DOM. (unless (equal (cdr (assq 'display shr-stylesheet)) "none") - (if (fboundp function) - (funcall function dom) - (shr-generic dom)) + (cond (external + (funcall external dom)) + ((fboundp function) + (funcall function dom)) + (t + (shr-generic dom))) (when (and shr-target-id (equal (dom-attr dom 'id) shr-target-id)) ;; If the element was empty, we don't have anything to put the @@ -1088,7 +1103,9 @@ ones, in case fg and bg are nil." (shr-color-visible bg fg))))))) (defun shr-colorize-region (start end fg &optional bg) - (when (and (or fg bg) (>= (display-color-cells) 88)) + (when (and shr-use-colors + (or fg bg) + (>= (display-color-cells) 88)) (let ((new-colors (shr-color-check fg bg))) (when new-colors (when fg |