enhanced select-safe-coding-system

[Dave Love]

This replacement for `select-safe-coding-system' didn't get included
with the batch of Mule-related files I advertised a while ago.

It enhances the vanilla one in Emacs 21.1 per the comment.  The main
function is to warn about potential lossage when editing files with
the coding system specified by cookies or the like; for various
reasons, files can get saved in encodings which are contradicted by
the coding cookies they contain, so they're mis-decoded when they're
visited.  I don't remember whether there was a good reason this check
wasn't included when `select-safe-coding-system' was re-written, but I
find it useful to save me from finger trouble occasionally.

Use it by customizing `select-safe-coding-system-function' to
`my-select-safe-coding-system'.

;; Modified from vanilla to avoid offering -with-esc coding systems
;; and to check consistency with coding cookies &c.
(defun my-select-safe-coding-system (from to &optional default-coding-system
                                          accept-default-p)
  "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
proper one is suggested as the default.

The list of `buffer-file-coding-system' of the current buffer and the
most preferred coding system (if it corresponds to a MIME charset) is
treated as the default coding system list.  Among them, the first one
that safely encodes the text is normally selected silently and
returned without any user interaction.  See also the command
`prefer-coding-system'.

However, the user is queried if the selected coding system is
inconsistent with what would be selected by coding cookies &c. in the
buffer contents if they were read from a file.  That could lead to
data corruption in a file subsequently re-visited and edited.

Optional 3rd arg DEFAULT-CODING-SYSTEM specifies a coding system or a
list of coding systems to be prepended to the default coding system
list.

Optional 4th arg ACCEPT-DEFAULT-P, if non-nil, is a function to
determine the acceptability of the silently selected coding system.
It is called with that coding system, and should return nil if it
should not be silently selected and thus user interaction is required.

The variable `select-safe-coding-system-accept-default-p', if
non-nil, overrides ACCEPT-DEFAULT-P.

Kludgy feature: if FROM is a string, the string is the target text,
and TO is ignored."
  (if (and default-coding-system
           (not (listp default-coding-system)))
      (setq default-coding-system (list default-coding-system)))

  ;; Change elements of the list to (coding . base-coding).
  (setq default-coding-system
        (mapcar (function (lambda (x) (cons x (coding-system-base x))))
                default-coding-system))

  ;; If buffer-file-coding-system is not nil nor undecided, append it
  ;; to the defaults.
  (if buffer-file-coding-system
      (let ((base (coding-system-base buffer-file-coding-system)))
        (or (eq base 'undecided)
            (assq buffer-file-coding-system default-coding-system)
            (rassq base default-coding-system)
            (setq default-coding-system
                  (append default-coding-system
                          (list (cons buffer-file-coding-system base)))))))

  ;; If the most preferred coding system has the property mime-charset,
  ;; append it to the defaults.
  (let ((tail coding-category-list)
        preferred base)
    (while (and tail
                (not (setq preferred (symbol-value (car tail)))))
      (setq tail (cdr tail)))
    (and (coding-system-p preferred)
         (setq base (coding-system-base preferred))
         (coding-system-get preferred 'mime-charset)
         (not (assq preferred default-coding-system))
         (not (rassq base default-coding-system))
         (setq default-coding-system
               (append default-coding-system (list (cons preferred base))))))

  (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)
        (l default-coding-system))
    (if (eq (car codings) 'undecided)
        ;; Any coding system is ok.
        (setq coding-system t)
      ;; Try the defaults.
      (while (and l (not coding-system))
        (if (memq (cdr (car l)) codings)
            (setq coding-system (car (car l)))
          (setq l (cdr l))))
      (if (and coding-system accept-default-p)
          (or (funcall accept-default-p coding-system)
              (setq coding-system (list coding-system)))))

    ;; If all the defaults failed, ask a user.
    (when (or (not coding-system) (consp coding-system))
      ;; At first, change each 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))))

      ;; Then ask users to select one form CODINGS.
      (unwind-protect
          (save-window-excursion
            (with-output-to-temp-buffer "*Warning*"
              (save-excursion
                (set-buffer standard-output)
                (if (not default-coding-system)
                    (insert "No default coding systems to try.")
                  (insert "These default coding systems were tried")
                  (if (stringp from)
                      (insert " to encode \""
                              (if (> (length from) 10)
                                  (substring from 0 10)
                                from)
                              "...\""))
                  (insert ":\n")
                  (let ((pos (point))
                        (fill-prefix "  "))
                    (mapcar (function (lambda (x)
                                        (princ "  ") (princ (car x))))
                            default-coding-system)
                    (insert "\n")
                    (fill-region-as-paragraph pos (point)))
                  (insert
                   (if (consp coding-system)
                       (concat (format "%s safely encodes the target text,\n"
                                       (car coding-system))
                               "but it is not recommended for encoding text in 
this context,\n"
                               "e.g., for sending an email message.\n")
                     "However, none of them safely encodes the target 
text.\n")))
                (insert (if (consp coding-system)
                            "\nSelect the above, or "
                          "\nSelect ")
                        "one of the following safe coding systems:\n")
                (let ((pos (point))
                      (fill-prefix "  "))
                  (mapcar (function (lambda (x) (princ "  ") (princ x)))
                          codings)
                  (insert "\n")
                  (fill-region-as-paragraph pos (point)))))

            ;; Read a coding system.
            (if (consp coding-system)
                (setq codings (cons (car coding-system) codings)))
            (let* ((safe-names (mapcar (lambda (x) (list (symbol-name x)))
                                       codings))
                   (name (completing-read
                          (format "Select coding system (default %s): "
                                  (car codings))
                          safe-names nil t nil nil
                          (car (car safe-names)))))
              (setq last-coding-system-specified (intern name)
                    coding-system last-coding-system-specified)))
        (kill-buffer "*Warning*")))

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

    (if (eq coding-system t)
        (setq coding-system buffer-file-coding-system))
    ;; Check we're not inconsistent with what coding cookies &c would
    ;; give when file is re-read.
    (unless (stringp from)
      (let ((auto-cs (save-restriction
                       (widen)
                       (save-excursion
                         (goto-char (point-min))
                         (set-auto-coding (or buffer-file-name "")
                                          (buffer-size))))))
        (if (and auto-cs
                 (not (coding-system-equal (coding-system-base coding-system)
                                           (coding-system-base auto-cs))))
            (unless (yes-or-no-p
                     (format "Selected encoding %s disagrees with \
%s specified by file contents.  Really save (else edit coding cookies \
and try again)? " coding-system auto-cs))
              (error "Save aborted")))))
    coding-system))