Commit 738746ba authored by Kenichi Handa's avatar Kenichi Handa
Browse files

(search-unencodable-char): New

function.
(select-safe-coding-system): Show unencodable characters.
(unencodable-char-position): Deleted, and implemented by C in
coding.c.
parent 8030369c
...@@ -548,6 +548,27 @@ For invalid characters, CHARs are actually strings." ...@@ -548,6 +548,27 @@ For invalid characters, CHARs are actually strings."
(setq chars (cons (list charset 1 char) chars)))))))) (setq chars (cons (list charset 1 char) chars))))))))
(nreverse chars))) (nreverse chars)))
(defun search-unencodable-char (coding-system)
"Search forward from point for a character that is not encodable.
It asks which coding system to check.
If such a character is found, set point after that character.
Otherwise, don't move point.
When called from a program, the value is a position of the found character,
or nil if all characters are encodable."
(interactive
(list (let ((default (or buffer-file-coding-system 'us-ascii)))
(read-coding-system
(format "Coding-system (default, %s): " default)
default))))
(let ((pos (unencodable-char-position (point) (point-max) coding-system)))
(if pos
(goto-char (1+ pos))
(message "All following characters are encodable by %s" coding-system))
pos))
(defvar last-coding-system-specified nil (defvar last-coding-system-specified nil
"Most recent coding system explicitly specified by the user when asked. "Most recent coding system explicitly specified by the user when asked.
This variable is set whenever Emacs asks the user which coding system This variable is set whenever Emacs asks the user which coding system
...@@ -655,7 +676,30 @@ and TO is ignored." ...@@ -655,7 +676,30 @@ and TO is ignored."
;; If all the defaults failed, ask a user. ;; If all the defaults failed, ask a user.
(when (or (not coding-system) (consp coding-system)) (when (or (not coding-system) (consp coding-system))
;; At first, change each coding system to the corresponding ;; At first, record at most 11 problematic characters and their
;; positions for each default.
(if (stringp from)
(mapc #'(lambda (coding)
(setcdr coding
(mapcar #'(lambda (pos)
(cons pos (aref from pos)))
(unencodable-char-position
0 (length from) (car coding) 11 from))))
default-coding-system)
(mapc #'(lambda (coding)
(setcdr coding
(mapcar #'(lambda (pos)
(cons pos (char-after pos)))
(unencodable-char-position
from to (car coding) 11))))
default-coding-system))
;; If 11 unencodable characters were found, mark the last one as nil.
(mapc #'(lambda (coding)
(if (> (length coding) 11)
(setcdr (car (last coding)) nil)))
default-coding-system)
;; Change each safe coding system to the corresponding
;; mime-charset name if it is also a coding system. Such a name ;; mime-charset name if it is also a coding system. Such a name
;; is more friendly to users. ;; is more friendly to users.
(let ((l codings) (let ((l codings)
...@@ -676,75 +720,112 @@ and TO is ignored." ...@@ -676,75 +720,112 @@ and TO is ignored."
(coding-system-category elt))) (coding-system-category elt)))
(push elt l)))) (push elt l))))
(unwind-protect (let ((window-configuration (current-window-configuration)))
(save-window-excursion (save-excursion
;; Make sure the offending buffer is displayed.
(when (and default-coding-system (not (stringp from)))
(pop-to-buffer bufname)
(goto-char (apply 'min (mapcar #'(lambda (x) (car (cadr x)))
default-coding-system))))
;; Then ask users to select one from CODINGS.
(with-output-to-temp-buffer "*Warning*"
(save-excursion (save-excursion
;; Make sure the offending buffer is displayed. (set-buffer standard-output)
(unless (stringp from) (if (not default-coding-system)
(pop-to-buffer bufname) (insert "No default coding systems to try for "
(goto-char (unencodable-char-position (if (stringp from)
from to (mapcar #'car default-coding-system)))) (format "string \"%s\"." from)
;; Then ask users to select one from CODINGS. (format "buffer `%s'." bufname)))
(with-output-to-temp-buffer "*Warning*" (insert
(save-excursion "These default coding systems were tried to encode"
(set-buffer standard-output) (if (stringp from)
(if (not default-coding-system) (concat " \"" (if (> (length from) 10)
(insert "No default coding systems to try for " (concat (substring from 0 10) "...\"")
(if (stringp from) (concat from "\"")))
(format "string \"%s\"." from) (format " text\nin the buffer `%s'" bufname))
(format "buffer `%s'." bufname))) ":\n")
(insert (let ((pos (point))
"These default coding systems were tried to encode" (fill-prefix " "))
(if (stringp from) (mapcar (function (lambda (x)
(concat " \"" (if (> (length from) 10) (princ " ") (princ (car x))))
(concat (substring from 0 10) "...\"") default-coding-system)
(concat from "\""))) (insert "\n")
(format " text\nin the buffer `%s'" bufname)) (fill-region-as-paragraph pos (point)))
":\n") (if (consp coding-system)
(let ((pos (point)) (insert (format "%s safely encodes the target text,\n"
(fill-prefix " ")) (car coding-system))
(mapcar (function (lambda (x) "\
(princ " ") (princ (car x))))
default-coding-system)
(insert "\n")
(fill-region-as-paragraph pos (point)))
(if (consp coding-system)
(insert (format "%s safely encodes the target text,\n"
(car coding-system))
"\
but it is not recommended for encoding text in this context, but it is not recommended for encoding text in this context,
e.g., for sending an email message.\n") e.g., for sending an email message.\n")
(insert "\ (insert "\
However, none of them safely encodes the target text. However, each of them encountered these problematic characters:\n")
(mapc
#'(lambda (coding)
(insert (format " %s:" (car coding)))
(dolist (elt (cdr coding))
(insert " ")
(if (stringp from)
(insert (or (cdr elt) "..."))
(if (cdr elt)
(insert-text-button
(cdr elt)
:type 'help-xref
'help-echo
"mouse-2, RET: jump to this character"
'help-function
#'(lambda (bufname pos)
(when (buffer-live-p (get-buffer bufname))
(pop-to-buffer bufname)
(goto-char pos)))
'help-args (list bufname (car elt)))
(insert-text-button
"..."
:type 'help-xref
'help-echo
"mouse-2, RET: next unencodable character"
'help-function
#'(lambda (bufname pos coding)
(when (buffer-live-p (get-buffer bufname))
(pop-to-buffer bufname)
(if (< (point) pos)
(goto-char pos)
(forward-char 1)
(search-unencodable-char coding)
(forward-char -1))))
'help-args (list bufname (car elt)
(car coding))))))
(insert "\n"))
default-coding-system)
(insert "\
The first problematic character is at point in the displayed buffer,\n" The first problematic character is at point in the displayed buffer,\n"
(substitute-command-keys "\ (substitute-command-keys "\
and \\[universal-argument] \\[what-cursor-position] will give information about it.\n")))) and \\[universal-argument] \\[what-cursor-position] will give information about it.\n"))))
(insert (if (consp coding-system) (insert (if (consp coding-system)
"\nSelect the above, or " "\nSelect the above, or "
"\nSelect ") "\nSelect ")
"\ "\
one of the following safe coding systems, or edit the buffer:\n") one of the following safe coding systems, or edit the buffer:\n")
(let ((pos (point)) (let ((pos (point))
(fill-prefix " ")) (fill-prefix " "))
(mapcar (function (lambda (x) (princ " ") (princ x))) (mapcar (function (lambda (x) (princ " ") (princ x)))
codings) codings)
(insert "\n") (insert "\n")
(fill-region-as-paragraph pos (point))))) (fill-region-as-paragraph pos (point)))))
;; Read a coding system. ;; Read a coding system.
(if (consp coding-system) (if (consp coding-system)
(setq codings (cons (car coding-system) codings))) (setq codings (cons (car coding-system) codings)))
(let* ((safe-names (mapcar (lambda (x) (list (symbol-name x))) (let* ((safe-names (mapcar (lambda (x) (list (symbol-name x)))
codings)) codings))
(name (completing-read (name (completing-read
(format "Select coding system (default %s): " (format "Select coding system (default %s): "
(car codings)) (car codings))
safe-names nil t nil nil safe-names nil t nil nil
(car (car safe-names))))) (car (car safe-names)))))
(setq last-coding-system-specified (intern name) (setq last-coding-system-specified (intern name)
coding-system last-coding-system-specified))) coding-system last-coding-system-specified)))
(kill-buffer "*Warning*")))) (kill-buffer "*Warning*")
(set-window-configuration window-configuration)))
(if (vectorp (coding-system-eol-type coding-system)) (if (vectorp (coding-system-eol-type coding-system))
(let ((eol (coding-system-eol-type buffer-file-coding-system))) (let ((eol (coding-system-eol-type buffer-file-coding-system)))
...@@ -780,46 +861,6 @@ and try again)? " coding-system auto-cs)) ...@@ -780,46 +861,6 @@ and try again)? " coding-system auto-cs))
(error "Save aborted"))))) (error "Save aborted")))))
coding-system)) coding-system))
(defun unencodable-char-position (start end coding-system)
"Return position of first un-encodable character in a region.
START and END specfiy the region and CODING-SYSTEM specifies the
encoding to check. Return nil if CODING-SYSTEM does encode the region.
CODING-SYSTEM may also be a list of coding systems, in which case return
the first position not encodable by any of them.
This function is fairly slow."
;; Use recursive calls in the binary chop below, since we're
;; O(logN), and the call overhead shouldn't be a bottleneck.
(unless enable-multibyte-characters
(error "Unibyte buffer"))
;; Recurse if list of coding systems.
(if (consp coding-system)
(let ((end end) res)
(dolist (elt coding-system (and res (>= res 0) res))
(let ((pos (unencodable-char-position start end elt)))
(if pos
(setq end pos
res pos)))))
;; Skip ASCII initially.
(save-excursion
(goto-char start)
(skip-chars-forward "\000-\177" end)
(setq start (point))
(unless (= start end)
(setq coding-system (coding-system-base coding-system)) ; canonicalize
(let ((codings (find-coding-systems-region start end)))
(unless (or (equal codings '(undecided))
(memq coding-system
(find-coding-systems-region start end)))
;; Binary chop.
(if (= start (1- end))
start
(or (unencodable-char-position start (/ (+ start end) 2)
coding-system)
(unencodable-char-position (/ (+ start end) 2) end
coding-system)))))))))
(setq select-safe-coding-system-function 'select-safe-coding-system) (setq select-safe-coding-system-function 'select-safe-coding-system)
(defun select-message-coding-system () (defun select-message-coding-system ()
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment