nxhtml/util/rebind.el

   1 ;;; rebind.el --- Rebind keys
   2 ;;
   3 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
   4 ;; Created: 2008-01-20T12:04:37+0100 Sun
   5 ;; Version:
   6 ;; Last-Updated:
   7 ;; URL:
   8 ;; Keywords:
   9 ;; Compatibility:
  10 ;;
  11 ;; Features that might be required by this library:
  12 ;;
  13 ;;   None
  14 ;;
  15 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16 ;;
  17 ;;; Commentary:
  18 ;;
  19 ;; See `rebind-keys-mode' for information.
  20 ;;
  21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22 ;;
  23 ;;; Change log:
  24 ;;
  25 ;;
  26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27 ;;
  28 ;; This program is free software; you can redistribute it and/or
  29 ;; modify it under the terms of the GNU General Public License as
  30 ;; published by the Free Software Foundation; either version 2, or
  31 ;; (at your option) any later version.
  32 ;;
  33 ;; This program is distributed in the hope that it will be useful,
  34 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  35 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  36 ;; General Public License for more details.
  37 ;;
  38 ;; You should have received a copy of the GNU General Public License
  39 ;; along with this program; see the file COPYING.  If not, write to
  40 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
  41 ;; Floor, Boston, MA 02110-1301, USA.
  42 ;;
  43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  44 ;;
  45 ;;; Code:
  46
  47 (eval-when-compile (require 'new-key-seq-widget nil t))
  48 (eval-when-compile (require 'ourcomments-widgets nil t))
  49
  50
  51 (defun rebind-toggle-first-modifier (orig-key-seq mod)
  52   (let* ((first (elt orig-key-seq 0))
  53          (new-key-seq (copy-sequence orig-key-seq)))
  54     (setq first (if (memq mod first)
  55                     (delq mod first)
  56                   (cons mod first)))
  57     (aset new-key-seq 0 first)
  58     new-key-seq))
  59 ;; (rebind-toggle-first-modifier (key-description-to-vector "C-c a") 'shift)
  60 ;; (rebind-toggle-first-modifier (key-description-to-vector "C-S-c a") 'shift)
  61
  62 (defvar widget-commandp-prompt-value-history nil)
  63
  64 ;;;###autoload
  65 (defgroup rebind nil
  66   "Customizaton group for `rebind-keys-mode'."
  67   :group 'convenience
  68   :group 'emulations
  69   :group 'editing-basics
  70   :group 'emacsw32)
  71
  72 ;; (customize-option-other-window 'rebind-keys)
  73 ;; (Fetched key bindings from http://www.davidco.com/tips_tools/tip45.html)
  74 (defcustom rebind-keys
  75   '(
  76     ("MS Windows - often used key bindings" t
  77       (
  78        (
  79         [(control ?a)]
  80         "C-a on w32 normally means 'select all'. In Emacs it is `beginning-of-line'."
  81         t
  82         shift
  83         ourcomments-mark-whole-buffer-or-field)
  84       (
  85        [(control ?o)]
  86        "C-o on w32 normally means 'open file'. In Emacs it is `open-line'."
  87        nil
  88        shift
  89        find-file)
  90       (
  91        [(control ?f)]
  92        "C-f is commonly search on w32. In Emacs it is `forward-char'."
  93        nil
  94        shift
  95        isearch-forward)
  96       (
  97        [(control ?s)]
  98        "C-s is normally 'save file' on w32. In Emacs it is `isearch-forward'."
  99        nil
 100        nil
 101        save-buffer)
 102       (
 103        [(control ?w)]
 104        "C-w is often something like kill-buffer on w32. In Emacs it is `kill-region'."
 105        t
 106        shift
 107        kill-buffer)
 108       (
 109        [(control ?p)]
 110        "C-p is nearly always print on w32. In Emacs it is `previous-line'."
 111        t
 112        shift
 113        hfyview-buffer)
 114       (
 115        [(home)]
 116        "HOME normally stays in a field. By default it does not do that in Emacs."
 117        t
 118        nil
 119        ourcomments-move-beginning-of-line)
 120       (
 121        [(control ?+)]
 122        "C-+ often increases font size (in web browsers for example)."
 123        t
 124        shift
 125        text-scale-adjust)
 126       (
 127        [(control ?-)]
 128        "C-- often decreases font size (in web browsers for example)."
 129        t
 130        shift
 131        text-scale-adjust)
 132       (
 133        [(control ?0)]
 134        "C-0 often resets font size (in web browsers for example)."
 135        t
 136        shift
 137        text-scale-adjust)
 138        )))
 139   "Normal Emacs keys that are remapped to follow some other standard.
 140 The purpose of this variable is to make it easy to switch between
 141 Emacs key bindings and other standards.
 142
 143 The new bindings are made in the global minor mode
 144 `rebind-keys-mode' and will only have effect when this mode is
 145 on.
 146
 147 *Note:* You can only move functions bound in the global key map
 148         this way.
 149 *Note:* To get CUA keys you should turn on option `cua-mode'.
 150 *Note:* To get vi key bindings call function `viper-mode'.
 151 *Note:* `text-scale-adjust' already have default key bindings."
 152   :type '(repeat
 153           (list
 154            (string :tag "For what")
 155            (boolean :tag "Group on/off")
 156            (repeat
 157             (list
 158              (key-sequence :tag "Emacs key binding")
 159              (string :tag "Why rebind")
 160              (boolean :tag "Rebinding on/off")
 161              (choice :tag "Move original by"
 162                      (const :tag "Don't put it on any new binding" nil)
 163                      (choice :tag "Add key binding modifier"
 164                              (const meta)
 165                              (const control)
 166                              (const shift))
 167                      (key-sequence :tag "New binding for original function"))
 168              (command :tag "New command on above key"))
 169             )))
 170   :set (lambda (sym val)
 171          (set-default sym val)
 172          (when (featurep 'rebind)
 173            (rebind-update-keymap)))
 174   :group 'rebind)
 175
 176 (defvar rebind-keys-mode-map nil)
 177
 178 (defvar rebind--emul-keymap-alist nil)
 179
 180 ;;(rebind-update-keymap)
 181 (defun rebind-update-keymap ()
 182   (let ((m (make-sparse-keymap)))
 183     (dolist (group rebind-keys)
 184       (when (nth 1 group)
 185         (dolist (v (nth 2 group))
 186           (let* ((orig-key   (nth 0 v))
 187                  (comment    (nth 1 v))
 188                  (enabled    (nth 2 v))
 189                  (new-choice (nth 3 v))
 190                  (new-fun    (nth 4 v))
 191                  (orig-fun (lookup-key global-map orig-key))
 192                  new-key)
 193             (when enabled
 194               (when new-choice
 195                 (if (memq new-choice '(meta control shift))
 196                     (setq new-key (rebind-toggle-first-modifier orig-key new-choice))
 197                   (setq new-key new-choice))
 198                 (define-key m new-key orig-fun))
 199               (define-key m orig-key new-fun))))
 200         (setq rebind-keys-mode-map m))))
 201   (setq rebind--emul-keymap-alist (list (cons 'rebind-keys-mode rebind-keys-mode-map))))
 202
 203 ;;;###autoload
 204 (define-minor-mode rebind-keys-mode
 205   "Rebind keys as defined in `rebind-keys'.
 206 The key bindings will override almost all other key bindings
 207 since it is put on emulation level, like for example ``cua-mode'
 208 and `viper-mode'.
 209
 210 This is for using for example C-a to mark the whole buffer \(or a
 211 field). There are some predifined keybindings for this."
 212   :keymap rebind-keys-mode-map
 213   :global t
 214   :group 'rebind
 215   (if rebind-keys-mode
 216       (progn
 217         (rebind-update-keymap)
 218         ;;(rebind-keys-post-command)
 219         (add-hook 'post-command-hook 'rebind-keys-post-command t))
 220     (remove-hook 'post-command-hook 'rebind-keys-post-command)
 221     (setq emulation-mode-map-alists (delq 'rebind--emul-keymap-alist emulation-mode-map-alists))))
 222
 223 (defun rebind-keys-post-command ()
 224   "Make sure we are first in the list when turned on.
 225 This is reasonable since we are using this mode to really get the
 226 key bindings we want!"
 227   (unless (eq 'rebind--emul-keymap-alist (car emulation-mode-map-alists))
 228     (setq emulation-mode-map-alists (delq 'rebind--emul-keymap-alist emulation-mode-map-alists))
 229     (when rebind-keys-mode
 230       (add-to-list 'emulation-mode-map-alists 'rebind--emul-keymap-alist))))
 231
 232
 233 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 234 ;;; Interactive functions for the keymap
 235
 236
 237
 238 (provide 'rebind)
 239 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 240 ;;; rebind.el ends here