Re: ctl-x-map key binding conventions for new major/minor modes

[Tino Calancha]

On Sat, 13 May 2017, Eli Zaretskii wrote:

> > From: Tino Calancha <address@hidden>
> > Date: Sat, 13 May 2017 14:33:45 +0900 (JST)
> > Cc: Emacs developers <address@hidden>,
> >         Tino Calancha <address@hidden>
> >
> > Imagine one user sets that binding in her .emacs file.  Now she loads
> > a lib `foo.el' which automatically sets a global binding
> > 'C-x g' to `foo-whatever'.
>
> Perhaps instead of adding recommendations about this, we could have a
> feature where define-key invoked as part as 'load' or 'require' would
> check, once, if the key being rebound already has a binding, and ask
> the user what she would like to do about, with 3 possible answers
> being "rebind", "don't rebind", and "error out of 'load'"?

That feature might be a new minor mode; where the user can customize
what key bindings protect and/or what directories to look at/ignore.

===============================================================================
I) pkb.el:
===============================================================================

--8<-----------------------------cut here---------------start------------->8---
;;; pkb.el --- Prevent unnoticed key rebindings  -*- lexical-binding: t; -*-

;; Copyright (C) 2017  Tino Calancha

;; Author: Tino Calancha <address@hidden>
;; Version: 0.2
;; Package-Version: 20170517.1359
;; Package-Requires: ((emacs "24.4"))
;; Keywords: lisp, convenience, keyboard

;; This program 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.

;; This file is NOT part of GNU Emacs.
;;
;; This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; This file prevents from inadvertently changes on key bindings
;; during the load of an elisp library.
;;
;; The file defines a new minor mode `pkb-protect-key-bindings'.
;; When the mode is enabled and a library is loaded, ask what
;; to do if a call to `define-key' rebinds a previous key.
;; Possible actions are:
;; y: Rebind it.
;; n: Skip it.
;; Y or !: Rebind all and not prompt me more.
;; N: Skip all and not prompt me more.
;; The latter two actions are permanent.  After them, you must toggle
;; OFF/ON the mode if you want to be prompted again when loading
;; a new library.
;;
;; By default, the protected keys are those reserved for users.  You can
;; add more protected keys by customizing `pkb-protected-prefices'.
;;

;;; Code:



(require 'cl-lib)

(defgroup pkb nil
  "Prevent unnoticed key rebindings."
  :prefix "pkb-"
  :group 'keyboard)

(defcustom pkb-protect-global-bindings-only t
  "If nil, then protect local key bindings as well."
  :type 'boolean
  :group 'protect-key-bindings
  :version "26.1")

;; Protect keys reserved for users. You might also want "C-x" and "M-".
(defcustom pkb-protected-prefices
  '("\\`C-c [a-zA-Z]\\'" "\\`<f5>\\'" "\\`<f6>\\'" "\\`<f7>\\'"
    "\\`<f8>\\'" "\\`<f9>\\'")
  "List of protected key bindings when loading a library."
  :type 'list
  :group 'protect-key-bindings
  :version "26.1")

(defcustom pkb-dirs-to-ignore nil
  "List of directories to ignore for key rebindings."
  :type '(choice
          (const :tag "Unset" nil)
          (repeat :tag "Directories to ignore" string))
  :group 'protect-key-bindings
  :version "26.1")

(defcustom pkb-dirs-to-check nil
  "List of directories to check for key rebindings."
  :type '(choice
          (const :tag "Unset" nil)
          (repeat :tag "Directories to check" string))
  :group 'protect-key-bindings
  :version "26.1")

(defcustom pkb-protect-action 'ask
  "What to do when the load of a lib changes a protected key binding."
  :type '(choice
          (const :tag "Unset" nil)
          (const :tag "Ask" ask)
          (const :tag "Accept all" accept)
          (const :tag "Cancel all" cancel)
          (const :tag "Signal Error" signal-error))
  :group 'keyboard
  :version "26.1")



(defun pkb--current-def (keymap key)
  (let ((special-global-maps (list ctl-x-map ctl-x-4-map ctl-x-5-map esc-map)))
    (if (memq keymap special-global-maps)
        (lookup-key keymap key)
      (or (global-key-binding key)
          (and (null pkb-protect-global-bindings-only)
               (lookup-key keymap key))))))

(defun pkb--read-input (key-descr keymap)
  (let* ((special-global-maps (list ctl-x-map ctl-x-4-map ctl-x-5-map esc-map))
         (id-prefix '((0 . "C-x ") (1 . "C-x 4 ") (2 . "C-x 5 ") (3 . "M-")))
         (lib (file-name-nondirectory load-file-name))
         (prompt
          (format
           "[%s] Key '%s%s' already bound.  Rebind? [ynY!N] "
           lib
           (if (memq keymap special-global-maps)
               (cdr (assq (cl-position keymap special-global-maps) id-prefix))
             "")
           key-descr))
         (res (string (read-char prompt)))
         (valid-answers '("y" "n" "Y" "!" "N")))
    (if (member res valid-answers)
        res
      (while (not (member res valid-answers))
        (ding)
        (let ((prompt (concat prompt "Valid answers are chars in [ynY!N] ")))
          (setq res (string (read-char prompt))))) res)))

(defvar pkb--rebind-all nil)
(defvar pkb--cancel-all-rebindings nil)
(defun pkb-define-key--check-rebindings (fn keymap key def &rest args)
  "What to do when the load of a lib changes a protected key binding."
  (let* ((key-descr (key-description key))
         (current-def (pkb--current-def keymap key))
         (auto (or pkb--rebind-all pkb--cancel-all-rebindings))
         (rebind-all (or (eq pkb-protect-action 'accept)
                         (and auto pkb--rebind-all)))
         (cancel-all (or (eq pkb-protect-action 'cancel)
                         (and auto pkb--cancel-all-rebindings)))
         (in-dirs-ignore-p
          (and pkb-dirs-to-ignore
               load-file-name
               (file-in-directory-p
                (file-name-directory load-file-name)
                pkb-dirs-to-ignore)))
         (not-in-dirs-check-p
          (and pkb-dirs-to-check
               load-file-name
               (not (file-in-directory-p
                     (file-name-directory load-file-name)
                     pkb-dirs-to-check)))))
    (cond ((and load-in-progress
                (not in-dirs-ignore-p)
                (not not-in-dirs-check-p)
                current-def
                (and (functionp current-def)
                     (not (eq current-def 'self-insert-command)))
                (not (equal current-def def)))
           (let (input)
             (if (cl-notany
                  (lambda (prefix)
                    (unless (string-suffix-p " " prefix)
                      (setq prefix (concat prefix " ")))
                    (cond ((and (equal prefix "C-x ") (eq keymap ctl-x-map)) t)
                          ((and (equal prefix "C-x 4 ")
                                (eq keymap ctl-x-4-map)) t)
                          ((and (equal prefix "C-x 5 ")
                                (eq keymap ctl-x-5-map)) t)
                          ((and (equal prefix "M- ") (eq keymap esc-map)) t)
                          (t
                           (string-match (substring prefix 0 -1) key-descr))))
                  pkb-protected-prefices)
                 (apply fn keymap key def args)
               (cond ((eq pkb-protect-action 'signal-error)
                      (error "Key '%s' already bound" key-descr))
                     (rebind-all
                      (message "Rebinding key '%s'" key-descr)
                      (apply fn keymap key def args))
                     (cancel-all
                      (message "Prevent rebinding of key '%s'" key-descr))
                     (t
                      (setq input (pkb--read-input key-descr keymap))
                      (pcase input
                        ("y" (apply fn keymap key def args))
                        ((or "Y" "!")
                         (message "Accepting all rebindings")
                         (setq pkb--rebind-all t)
                         (apply fn keymap key def args))
                        ("N"
                         (setq pkb--cancel-all-rebindings t)
                         (message "OK, cancel '%s' rebinding and others"
                                  key-descr))
                        ("n" (message "OK, cancel '%s' rebinding"
                                      key-descr))))))))
          (t (apply fn keymap key def args)))))

(define-minor-mode pkb-protect-key-bindings
  "Toggle pkb mode.
With a prefix argument ARG, enable the mode if ARG is positive,
and disable it otherwise.  If called from Lisp, enable
the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'.

Prevents from inadvertently changes on key bindings during
the load of an elisp library.
When the mode is enabled and a library is loaded, ask what
to do if a call to `define-key' rebinds a protected key.
Possible actions are:
y: Rebind it.
n: Skip it.
Y or !: Rebind all and not prompt me more.
N: Skip all and not prompt me more.
The latter two actions are permanent.  After them, you must toggle
OFF/ON the mode if you want to be prompted again when loading
a new library.
By default, the protected keys are those reserved for users.  You can
add more protected keys by customizing `pkb-protected-prefices'."
  :init-value nil
  :global t
  :lighter (:eval (if pkb-protect-key-bindings " Pkb" ""))
  :keymap nil
  (if pkb-protect-key-bindings
      (advice-add 'define-key :around 'pkb-define-key--check-rebindings)
    (advice-remove 'define-key 'pkb-define-key--check-rebindings)
    (setq pkb--rebind-all nil
          pkb--cancel-all-rebindings nil)))


(provide 'pkb)
;;; pkb.el ends here
--8<-----------------------------cut here---------------end--------------->8---

===============================================================================
II) Tests for pkb.el:
===============================================================================

--8<-----------------------------cut here---------------start------------->8---
;;; pkb-tests.el --- Test suite for pkb. -*- lexical-binding: t -*-

;; Copyright (C) 2017 Free Software Foundation, Inc.

;; 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/>.

;;; Code:
(require 'ert)
(require 'pkb)


(ert-deftest pkb-test ()
  "Test for pkb mode."
  (let* ((dir (make-temp-file "pkb" 'dir))
         (default-directory dir)
         (foo (expand-file-name "foo.el" dir))
         (bar (expand-file-name "bar.el" dir))
         (qux (expand-file-name "qux.el" dir))
         ;; Restore these bindings on exit.
         (binding-cca (global-key-binding (kbd "C-c a")))
         (binding-cxf (global-key-binding (kbd "C-x f"))))
    (pkb-protect-key-bindings 1)
    (with-temp-buffer
      (insert "(global-set-key (kbd \"C-c a\") (lambda () (interactive) 
'foo))\n")
      (insert "(global-set-key (kbd \"C-x f\") (lambda () (interactive) 'foo))")
      (write-region nil nil foo)
      (erase-buffer)
      (insert "(global-set-key (kbd \"C-c a\") (lambda () (interactive) 'bar))")
      (write-region nil nil bar)
      (erase-buffer)
      (insert "(global-set-key (kbd \"C-x f\") (lambda () (interactive) 'qux))")
      (write-region nil nil qux))
    (unwind-protect
        (progn
          (let ((pkb-protect-action 'signal-error))
            (global-unset-key (kbd "C-c a"))
            (should (load foo))
            (should (load foo)) ; Again.
            (should-error (load bar)) ; 'C-c a' bound to a different lambda.
            (should (load qux)) ; Ignore "C-x".
            (let ((pkb-protected-prefices (append pkb-protected-prefices (list 
"C-x"))))
              (should-error (load foo))))
          (let ((pkb--cancel-all-rebindings t))
            (should (eq 'foo (funcall (global-key-binding (kbd "C-c a")))))
            (should (load bar))
            (should (eq 'foo (funcall (global-key-binding (kbd "C-c a"))))))
          (let ((pkb--rebind-all t))
            (should (eq 'foo (funcall (global-key-binding (kbd "C-c a")))))
            (should (load bar))
            (should (eq 'bar (funcall (global-key-binding (kbd "C-c a")))))))
      (delete-directory dir 'recursive)
      (when binding-cca
        (global-set-key (kbd "C-c a") binding-cca))
      (when binding-cxf
        (global-set-key (kbd "C-c a") binding-cxf)))))

(provide 'pkb-tests)
;; pkb-tests.el ends here
--8<-----------------------------cut here---------------end--------------->8---