comparison lisp/international/mule-cmds.el @ 58055:005c3ebdd545

(select-safe-coding-system-interactively): New function extracted from select-safe-coding-system. (select-safe-coding-system): Use it.

58054:b40b27d0c034

;;; mule-cmds.el --- commands for mulitilingual environment -*-coding: iso-2022-7bit -*-
;; Copyright (C) 1995, 2003 Electrotechnical Laboratory, JAPAN.
;; Licensed to the Free Software Foundation.
;; Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc.

;; Keywords: mule, multilingual

;; This file is part of GNU Emacs.

  "If non-nil, a function to control the behaviour of coding system selection.
The meaning is the same as the argument ACCEPT-DEFAULT-P of the
function `select-safe-coding-system' (which see).  This variable
overrides that argument.")

(defun select-safe-coding-system (from to &optional default-coding-system
				       accept-default-p file)
  "Ask a user to select a safe coding system from candidates.
The candidates of coding systems which can safely encode a text
between FROM and TO are shown in a popup window.  Among them, the most

  (if select-safe-coding-system-accept-default-p
      (setq accept-default-p select-safe-coding-system-accept-default-p))

  (let ((codings (find-coding-systems-region from to))
	(coding-system nil)
	(bufname (buffer-name))
	safe rejected unsafe)
    (if (eq (car codings) 'undecided)
	;; Any coding system is ok.
	(setq coding-system t)
      ;; Classify the defaults into safe, rejected, and unsafe.

      (if safe
	  (setq coding-system (car safe))))

    ;; If all the defaults failed, ask a user.
    (when (not coding-system)
      ;; At first, if some defaults are unsafe, record at most 11
      ;; problematic characters and their positions for them by turning
      ;;	(CODING ...)
      ;; into
      ;;	((CODING (POS . CHAR) (POS . CHAR) ...) ...)
      (if unsafe
	  (if (stringp from)
	      (setq unsafe
		    (mapcar #'(lambda (coding)
				(cons coding
				      (mapcar #'(lambda (pos)
						  (cons pos (aref from pos)))
					      (unencodable-char-position
					       0 (length from) coding
					       11 from))))
			    unsafe))
	    (setq unsafe
		  (mapcar #'(lambda (coding)
			      (cons coding
				    (mapcar #'(lambda (pos)
						(cons pos (char-after pos)))
					    (unencodable-char-position
					     from to coding 11))))
			  unsafe))))

      ;; Change each safe coding system to the corresponding
      ;; mime-charset name if it is also a coding system.  Such a name
      ;; is more friendly to users.
      (let ((l codings)
	    mime-charset)
	(while l
	  (setq mime-charset (coding-system-get (car l) 'mime-charset))
	  (if (and mime-charset (coding-system-p mime-charset))
	      (setcar l mime-charset))
	  (setq l (cdr l))))

      ;; Don't offer variations with locking shift, which you
      ;; basically never want.
      (let (l)
	(dolist (elt codings (setq codings (nreverse l)))
	  (unless (or (eq 'coding-category-iso-7-else
			  (coding-system-category elt))
		      (eq 'coding-category-iso-8-else
			  (coding-system-category elt)))
	    (push elt l))))

      ;; Remove raw-text, emacs-mule and no-conversion unless nothing
      ;; else is available.
      (setq codings
	    (or (delq 'raw-text
		      (delq 'emacs-mule
			    (delq 'no-conversion codings)))
		'(raw-text emacs-mule no-conversion)))

      (let ((window-configuration (current-window-configuration)))
	(save-excursion
	  ;; If some defaults are unsafe, make sure the offending
	  ;; buffer is displayed.
	  (when (and unsafe (not (stringp from)))
	    (pop-to-buffer bufname)
	    (goto-char (apply 'min (mapcar #'(lambda (x) (car (cadr x)))
					   unsafe))))
	  ;; Then ask users to select one from CODINGS while showing
	  ;; the reason why none of the defaults are not used.
	  (with-output-to-temp-buffer "*Warning*"
	    (save-excursion
	      (set-buffer standard-output)
	      (if (not default-coding-system)
		  (insert "No default coding systems to try for "
			  (if (stringp from)
			      (format "string \"%s\"." from)
			    (format "buffer `%s'." bufname)))
		(insert
		 "These default coding systems were tried to encode"
		 (if (stringp from)
		     (concat " \"" (if (> (length from) 10)
				       (concat (substring from 0 10) "...\"")
				     (concat from "\"")))
		   (format " text\nin the buffer `%s'" bufname))
		 ":\n")
		(let ((pos (point))
		      (fill-prefix "  "))
		  (mapc #'(lambda (x) (princ "  ") (princ (car x)))
			default-coding-system)
		  (insert "\n")
		  (fill-region-as-paragraph pos (point)))
		(when rejected
		  (insert "These safely encodes the target text,
but it is not recommended for encoding text in this context,
e.g., for sending an email message.\n ")
		  (mapc #'(lambda (x) (princ " ") (princ x)) rejected)
		  (insert "\n"))
		(when unsafe
		  (insert (if rejected "And the others"
			    "However, each of them")
			  " encountered these problematic characters:\n")
		  (mapc
		   #'(lambda (coding)
		       (insert (format "  %s:" (car coding)))
		       (let ((i 0)
			     (func1
			      #'(lambda (bufname pos)
				  (when (buffer-live-p (get-buffer bufname))
				    (pop-to-buffer bufname)
				    (goto-char pos))))
			     (func2
			      #'(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))))))
			 (dolist (elt (cdr coding))
			   (insert " ")
			   (if (stringp from)
			       (insert (if (< i 10) (cdr elt) "..."))
			     (if (< i 10)
				 (insert-text-button
				  (cdr elt)
				  :type 'help-xref
				  'help-echo
				  "mouse-2, RET: jump to this character"
				  'help-function func1
				  'help-args (list bufname (car elt)))
			       (insert-text-button
				"..."
				:type 'help-xref
				'help-echo
				"mouse-2, RET: next unencodable character"
				'help-function func2
				'help-args (list bufname (car elt)
						 (car coding)))))
			   (setq i (1+ i))))
		       (insert "\n"))
		   unsafe)
		  (insert "\
The first problematic character is at point in the displayed buffer,\n"
			  (substitute-command-keys "\
and \\[universal-argument] \\[what-cursor-position] will give information about it.\n"))))
	      (insert (if safe
			  "\nSelect the above, or "
			"\nSelect ")
		      "\
one of the following safe coding systems, or edit the buffer:\n")
	      (let ((pos (point))
		    (fill-prefix "  "))
		(mapcar (function (lambda (x) (princ "  ") (princ x)))
			codings)
		(insert "\n")
		(fill-region-as-paragraph pos (point)))
	      (insert "Or specify any other coding system
at the risk of losing the problematic characters.\n")))

	  ;; Read a coding system.
	  (setq default-coding-system (or (car safe) (car codings)))
	  (setq coding-system
		(read-coding-system
		 (format "Select coding system (default %s): "
			 default-coding-system)
		 default-coding-system))
	  (setq last-coding-system-specified coding-system))

	(kill-buffer "*Warning*")
	(set-window-configuration window-configuration)))

    (if (vectorp (coding-system-eol-type coding-system))
	(let ((eol (coding-system-eol-type buffer-file-coding-system)))
	  (if (numberp eol)
	      (setq coding-system

		   (string= "The XFree86 Project, Inc" (x-server-vendor))
		   (> (aref (number-to-string (nth 2 (x-server-version))) 0)
		      ?3))
	  ;; We suppress these setting for the moment because the
	  ;; above assumption is wrong.
	  ;; (aset standard-display-table ?' [?$,1ry(B])
	  ;; (aset standard-display-table ?` [?$,1rx(B])
	  ;; The fonts don't have the relevant bug.
	  (aset standard-display-table 160 nil)
	  (aset standard-display-table (make-char 'latin-iso8859-1 160)
		nil)))))

      ;; and they are the extra control sequences at the tail to
      ;; exclude.
      (substring enc2 0 i2))))


;;; arch-tag: b382c432-4b36-460e-bf4c-05efd0bb18dc
;;; mule-cmds.el ends here

58055:005c3ebdd545

;;; mule-cmds.el --- commands for mulitilingual environment -*-coding: utf-8 -*-

;; Copyright (C) 2000, 2001, 2002, 2003, 2004  Free Software Foundation, Inc.
;; Copyright (C) 1995, 2003 Electrotechnical Laboratory, JAPAN.
;; Licensed to the Free Software Foundation.

;; Keywords: mule, multilingual

;; This file is part of GNU Emacs.

  "If non-nil, a function to control the behaviour of coding system selection.
The meaning is the same as the argument ACCEPT-DEFAULT-P of the
function `select-safe-coding-system' (which see).  This variable
overrides that argument.")

(defun select-safe-coding-system-interactively (from to codings unsafe
						&optional rejected default)
  "Select interactively a coding system for the region FROM ... TO.
FROM can be a string, as in `write-region'.
CODINGS is the list of base coding systems known to be safe for this region,
  typically obtained with `find-coding-systems-region'.
UNSAFE is a list of coding systems known to be unsafe for this region.
REJECTED is a list of coding systems which were safe but for some reason
  were not recommended in the particular context.
DEFAULT is the coding system to use by default in the query."
  ;; At first, if some defaults are unsafe, record at most 11
  ;; problematic characters and their positions for them by turning
  ;;	(CODING ...)
  ;; into
  ;;	((CODING (POS . CHAR) (POS . CHAR) ...) ...)
  (if unsafe
      (setq unsafe
	    (mapcar #'(lambda (coding)
			(cons coding
			      (if (stringp from)
				  (mapcar #'(lambda (pos)
					      (cons pos (aref from pos)))
					  (unencodable-char-position
					   0 (length from) coding
					   11 from))
				(mapcar #'(lambda (pos)
					    (cons pos (char-after pos)))
					(unencodable-char-position
					 from to coding 11)))))
		    unsafe)))

  ;; Change each safe coding system to the corresponding
  ;; mime-charset name if it is also a coding system.  Such a name
  ;; is more friendly to users.
  (let ((l codings)
	mime-charset)
    (while l
      (setq mime-charset (coding-system-get (car l) 'mime-charset))
      (if (and mime-charset (coding-system-p mime-charset))
	  (setcar l mime-charset))
      (setq l (cdr l))))

  ;; Don't offer variations with locking shift, which you
  ;; basically never want.
  (let (l)
    (dolist (elt codings (setq codings (nreverse l)))
      (unless (or (eq 'coding-category-iso-7-else
		      (coding-system-category elt))
		  (eq 'coding-category-iso-8-else
		      (coding-system-category elt)))
	(push elt l))))

  ;; Remove raw-text, emacs-mule and no-conversion unless nothing
  ;; else is available.
  (setq codings
	(or (delq 'raw-text
		  (delq 'emacs-mule
			(delq 'no-conversion codings)))
	    '(raw-text emacs-mule no-conversion)))

  (let ((window-configuration (current-window-configuration))
	(bufname (buffer-name))
	coding-system)
    (save-excursion
      ;; If some defaults are unsafe, make sure the offending
      ;; buffer is displayed.
      (when (and unsafe (not (stringp from)))
	(pop-to-buffer bufname)
	(goto-char (apply 'min (mapcar #'(lambda (x) (car (cadr x)))
				       unsafe))))
      ;; Then ask users to select one from CODINGS while showing
      ;; the reason why none of the defaults are not used.
      (with-output-to-temp-buffer "*Warning*"
	(with-current-buffer standard-output
	  (if (and (null rejected) (null unsafe))
	      (insert "No default coding systems to try for "
		      (if (stringp from)
			  (format "string \"%s\"." from)
			(format "buffer `%s'." bufname)))
	    (insert
	     "These default coding systems were tried to encode"
	     (if (stringp from)
		 (concat " \"" (if (> (length from) 10)
				   (concat (substring from 0 10) "...\"")
				 (concat from "\"")))
	       (format " text\nin the buffer `%s'" bufname))
	     ":\n")
	    (let ((pos (point))
		  (fill-prefix "  "))
	      (dolist (x (append rejected unsafe))
		(princ "  ") (princ (car x)))
	      (insert "\n")
	      (fill-region-as-paragraph pos (point)))
	    (when rejected
	      (insert "These safely encodes the target text,
but it is not recommended for encoding text in this context,
e.g., for sending an email message.\n ")
	      (dolist (x rejected)
		(princ " ") (princ x))
	      (insert "\n"))
	    (when unsafe
	      (insert (if rejected "And the others"
			"However, each of them")
		      " encountered these problematic characters:\n")
	      (dolist (coding unsafe)
		(insert (format "  %s:" (car coding)))
		(let ((i 0)
		      (func1
		       #'(lambda (bufname pos)
			   (when (buffer-live-p (get-buffer bufname))
			     (pop-to-buffer bufname)
			     (goto-char pos))))
		      (func2
		       #'(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))))))
		  (dolist (elt (cdr coding))
		    (insert " ")
		    (if (stringp from)
			(insert (if (< i 10) (cdr elt) "..."))
		      (if (< i 10)
			  (insert-text-button
			   (cdr elt)
			   :type 'help-xref
			   'help-echo
			   "mouse-2, RET: jump to this character"
			   'help-function func1
			   'help-args (list bufname (car elt)))
			(insert-text-button
			 "..."
			 :type 'help-xref
			 'help-echo
			 "mouse-2, RET: next unencodable character"
			 'help-function func2
			 'help-args (list bufname (car elt)
					  (car coding)))))
		    (setq i (1+ i))))
		(insert "\n"))
	      (insert "\
The first problematic character is at point in the displayed buffer,\n"
		      (substitute-command-keys "\
and \\[universal-argument] \\[what-cursor-position] will give information about it.\n"))))
	  (insert "\nSelect \
one of the following safe coding systems, or edit the buffer:\n")
	  (let ((pos (point))
		(fill-prefix "  "))
	    (dolist (x codings)
	      (princ "  ") (princ x))
	    (insert "\n")
	    (fill-region-as-paragraph pos (point)))
	  (insert "Or specify any other coding system
at the risk of losing the problematic characters.\n")))

      ;; Read a coding system.
      (setq coding-system
	    (read-coding-system
	     (format "Select coding system (default %s): " default)
	     default))
      (setq last-coding-system-specified coding-system))

    (kill-buffer "*Warning*")
    (set-window-configuration window-configuration)
    coding-system))

(defun select-safe-coding-system (from to &optional default-coding-system
				       accept-default-p file)
  "Ask a user to select a safe coding system from candidates.
The candidates of coding systems which can safely encode a text
between FROM and TO are shown in a popup window.  Among them, the most

  (if select-safe-coding-system-accept-default-p
      (setq accept-default-p select-safe-coding-system-accept-default-p))

  (let ((codings (find-coding-systems-region from to))
	(coding-system nil)
	safe rejected unsafe)
    (if (eq (car codings) 'undecided)
	;; Any coding system is ok.
	(setq coding-system t)
      ;; Classify the defaults into safe, rejected, and unsafe.

      (if safe
	  (setq coding-system (car safe))))

    ;; If all the defaults failed, ask a user.
    (when (not coding-system)
      (setq coding-system (select-safe-coding-system-interactively
			   from to codings unsafe rejected (car codings))))

    (if (vectorp (coding-system-eol-type coding-system))
	(let ((eol (coding-system-eol-type buffer-file-coding-system)))
	  (if (numberp eol)
	      (setq coding-system

		   (string= "The XFree86 Project, Inc" (x-server-vendor))
		   (> (aref (number-to-string (nth 2 (x-server-version))) 0)
		      ?3))
	  ;; We suppress these setting for the moment because the
	  ;; above assumption is wrong.
	  ;; (aset standard-display-table ?' [?’])
	  ;; (aset standard-display-table ?` [?‘])
	  ;; The fonts don't have the relevant bug.
	  (aset standard-display-table 160 nil)
	  (aset standard-display-table (make-char 'latin-iso8859-1 160)
		nil)))))

      ;; and they are the extra control sequences at the tail to
      ;; exclude.
      (substring enc2 0 i2))))


;; arch-tag: b382c432-4b36-460e-bf4c-05efd0bb18dc
;;; mule-cmds.el ends here