emacs_el/tiny-tools/tiny/tinylibck.el

   1 ;;; tinylibck.el --- Library to (c)onvert (k)eybindings for XEmacs or Emacs
   2
   3 ;; This file is not part of Emacs
   4
   5 ;;{{{ Id
   6
   7 ;; Copyright (C) 1996-2007 Jari Aalto
   8 ;; Keywords:     tools
   9 ;; Author:       Jari Aalto
  10 ;; Maintainer:   Jari Aalto
  11 ;;
  12 ;; To get information on this program, call M-x ti::ck-version.
  13 ;; Look at the code with folding.el
  14
  15 ;; This program is free software; you can redistribute it and/or modify it
  16 ;; under the terms of the GNU General Public License as published by the Free
  17 ;; Software Foundation; either version 2 of the License, or (at your option)
  18 ;; any later version.
  19 ;;
  20 ;; This program is distributed in the hope that it will be useful, but
  21 ;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  22 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  23 ;; for more details.
  24 ;;
  25 ;; You should have received a copy of the GNU General Public License
  26 ;; along with program; see the file COPYING. If not, write to the
  27 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  28 ;; Boston, MA 02110-1301, USA.
  29 ;;
  30 ;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
  31
  32 ;;}}}
  33 ;;{{{ Install
  34
  35 ;; ....................................................... &t-install ...
  36 ;;  Put this file on your Emacs-Lisp load path, add following into your
  37 ;;  ~/.emacs startup file. This must be the very first entry before
  38 ;;  any keybindings take in effect.
  39 ;;
  40 ;;      (require 'tinylibck)
  41 ;;
  42 ;;  You can also use the preferred way: autoload
  43 ;;
  44 ;;      (autoload 'ti::ck-advice-control "tinylibck")
  45 ;;
  46 ;;  And when you need conversion you wrap the code with calls:
  47 ;;
  48 ;;      (ti::ck-advice-control)           ;; ON
  49 ;;      <key definitions>
  50 ;;      (ti::ck-advice-control 'disable)  ;; OFF
  51 ;;
  52 ;;  Remember that you DON'T LEAVE THIS PACKAGE ON. Make sure the 'disable
  53 ;;  is the last thing you do. It disables the package and makes sure your
  54 ;;  other emacs packages work properly
  55 ;;
  56 ;;  If you have any questions, use this function
  57 ;;
  58 ;;       M-x ti::ck-submit-feedback
  59
  60 ;;}}}
  61 ;;{{{ Documentation
  62
  63 ;; ..................................................... &t-commentary ...
  64
  65 ;;; Commentary:
  66
  67 ;;
  68 ;;  Preface
  69 ;;
  70 ;;      This file tries to overcome differencies between Emacs and XEmacs
  71 ;;      keybinding. Package was developed at the time when there was big
  72 ;;      differences between Emacs and XEmacs key bindings. This file is in
  73 ;;      fact "library" and propably interests only lisp programmers that
  74 ;;      want to make some old package, that has Emacs specific bindings, to
  75 ;;      work in XEmacs (or vice versa).
  76 ;;
  77 ;;  Emacs 19.30+ note
  78 ;;
  79 ;;      Newer Emacs release now supports XEmacs styled bindings.
  80 ;;      You can write
  81 ;;
  82 ;;          (local-set-key [(control meta up)] 'ignore)
  83 ;;
  84 ;;      and it should work both in XEmacs and Emacs. If all your keybindins
  85 ;;      are like that and you don't use Emacs lower than 19.30, then you
  86 ;;      don't need this package.
  87 ;;
  88 ;;  Putting your key definitions to separate file
  89 ;;
  90 ;;      You should separate all you keybindings to one file,
  91 ;;      do not stuff all your emacs definitions in one huge ~/.emacs,
  92 ;;      but instead use some basic structure like this:
  93 ;;
  94 ;;          ~/.emacs            -- the main; points to ~/rc/emacs-rc.el
  95 ;;          ~/rc/emacs-kbd.el   -- All the keybindinds
  96 ;;          ~/rc/emacs-vc.el    -- vc settings and modifications
  97 ;;          ~/rc/emacs-gnus.el  -- gnus customization
  98 ;;          ..
  99 ;;
 100 ;;      You can load your other initialize files from .emacs with `load'
 101 ;;      command. Suppose you have Emacs keybinding startup file; which you
 102 ;;      want to make compatible with XEmacs too. The reason why you should
 103 ;;      use `ti::ck-maybe-activate' is that, it can determine your emacs
 104 ;;      version and decide when the converter is needed and when not.
 105 ;;
 106 ;;          ;; at the beginning of keybindings, you add these
 107 ;;
 108 ;;          (require 'tinylibm)
 109 ;;          (autoload 'ti::ck-advice-control "tinylibck")
 110 ;;
 111 ;;          (ti::ck-maybe-activate 'xemacs-mouse)
 112 ;;          (load "~/rc/emacs-rc-keys")     ;; All XEmacs styled bindings
 113 ;;          (ti::ck-maybe-activate 'xemacs-mouse 'disable)
 114 ;;
 115 ;;          ;; End of example
 116 ;;
 117 ;;  Some lowlevel explanation
 118 ;;
 119 ;;      If you're in Emacs, you use X-event bindings like this
 120 ;;
 121 ;;          (global-set-key [C-up] 'ignore)
 122 ;;
 123 ;;      Unfortunately, this does not work in XEmacs, but using the
 124 ;;      conversion function before the definition, it does.
 125 ;;
 126 ;;          (global-set-key (ti::ck-do [C-up]) 'ignore)
 127 ;;
 128 ;;      Now the current Emacs version gets the right keybinding,
 129 ;;
 130 ;;          for Emacs  it returns       --> [C-up]
 131 ;;          for XEmacs it returns       --> '(control up)
 132 ;;
 133 ;;      You can also use the XEmacs keybinding, since the conversion goes
 134 ;;      both ways. Having the following setting:
 135 ;;
 136 ;;          (global-set-key (ti::ck-do '(control up)) 'ignore)
 137 ;;
 138 ;;      it converts this to suitable form depending on the current Emacs
 139 ;;      in use.
 140 ;;
 141 ;;  About advices
 142 ;;
 143 ;;      So that you don't have to go and add that 'ti::ck-do' call for
 144 ;;      every keybinding, the key binding functions have been adviced.
 145 ;;      The conversion is done transparently and no chnages are
 146 ;;      needed in files were keys are bound.
 147 ;;
 148 ;;  About debugging
 149 ;;
 150 ;;      If you suspect any weird behavior in your emacs while
 151 ;;      this package is loaded, you should check that the `ti::ck-:debug'
 152 ;;      is turned on. (`M-x' `ti::ck-debug-toggle')
 153 ;;
 154 ;;      The buffer `ti::ck-:debug-buffer' constantly records any conversion
 155 ;;      actions and you can find the problems quickly. Please send the
 156 ;;      supicious/false conversion lines to the maintainer of this package
 157 ;;      and if possible, tell how the conversion should go in your opinion.
 158 ;;
 159 ;;      I'd recommend that you keep the debugging permanently on, because
 160 ;;      if problems arise afterwards and if the debug were off, there is
 161 ;;      no way to tell what went wrong in what command.
 162 ;;
 163 ;;      Important; when you have problems, increase
 164 ;;
 165 ;;          ti::ck-:debug-buffer-size
 166 ;;
 167 ;;      immediately to some arbitrary big value so that you get all the
 168 ;;      conversions recorded.
 169 ;;
 170 ;;  Known limitations
 171 ;;
 172 ;;      This package tries to do its best to make the conversion, but
 173 ;;      sometimes it is just impossible. For example the following
 174 ;;      case is beyond of this package. In Emacs you can define
 175 ;;
 176 ;;          (define-key xxx-mode-map [?\C-`] 'some-function)
 177 ;;                                   ^^^^^^^
 178 ;;
 179 ;;      But when your're in XEmacs and you try to do the same, it gives
 180 ;;      error although tinylibck is currently active. The reason is that lisp
 181 ;;      intepreter never actually passes key  "?\C-`" to `define-key'
 182 ;;      but it actually evaluates the vector in place to an integer value
 183 ;;      and sends that to `define-key' function . The call actually is
 184 ;;      seen in Emacs like this:
 185 ;;
 186 ;;          (define-key xxx-mode-map [4194400] 'some-function)
 187 ;;                                   ^^^^^^^^^in HP-UX 9.05
 188 ;;
 189 ;;      And in XEmacs it is evaluates to this:
 190 ;;
 191 ;;          (define-key xxx-mode-map [0] 'xxx-tab-backward)
 192 ;;
 193 ;;      The code "0" appears, because XEmacs doesn't know Emacs "?\C-`".
 194 ;;      You should write [(control ?\`)] for XEmacs and it would work ok.
 195 ;;      Be aware of this limitation if you plan to use Emacs styled
 196 ;;      bindings. Alternatively, you can tell that you that some
 197 ;;      particular piece of code has been written by using XEmacs style.
 198 ;;      (Wouldn't you want to you use it all the time in Emacs...)
 199 ;;
 200 ;;          ;;   This is Emacs file.
 201 ;;          (require 'tinylibck)                ;Convert keys
 202 ;;          (ti::ck-advice-control)             ;turn it on
 203 ;;          ;;
 204 ;;          (define-key tinytab-mode-map [(control ?\`)]  'tinytab-tab-backward)
 205 ;;          ;; And other similar keybindings ...
 206 ;;          ;; ..
 207 ;;          (ti::ck-advice-control 'disable)    ;don't leave it on
 208 ;;
 209 ;;  Thank you
 210 ;;
 211 ;;      Vladimir Alexiev <vladimir@cs.ualberta.ca>
 212 ;;      Presented initial idea of the conversion process.
 213 ;;      Commented how the conversion should go in XEmacs.
 214 ;;
 215 ;;      Stephen Eglen  <stephene@cogs.susx.ac.uk>
 216 ;;      Stephen had the patience to send bug reports from XEmacs 19.12 and
 217 ;;      test new versions of tinylibck.el
 218
 219 ;;}}}
 220
 221 ;;; Change Log:
 222
 223 ;;; Code:
 224
 225 ;;{{{ setup: require
 226
 227 ;;; ......................................................... &require ...
 228
 229 (eval-when-compile
 230   (require 'cl)
 231   (require 'advice))
 232
 233 (eval-and-compile
 234   ;;  Don't require lib package unnecessarily
 235   (autoload 'ti::package-version-info    "tinylib")
 236   (autoload 'ti::package-submit-feedback "tinylib"))
 237
 238 ;;}}}
 239
 240 ;;{{{ setup: -- private variables
 241
 242 (defvar ti::ck-:load-hook '(ti::ck-advice-control)
 243   "*Hook run when file has been loaded.")
 244
 245 (defconst ti::ck-:xemacs-flag (string-match "XEmacs" (emacs-version))
 246   "Non-nil means XEmacs is detected.")
 247
 248 (defconst ti::ck-:emacs-minor
 249   (if (boundp 'emacs-minor-version)
 250       emacs-minor-version 0)
 251   "Emacs minor version or 0 if cannot detect one.")
 252
 253 (defconst ti::ck-:advice-re "^ti::ck-keybind"
 254   "Advice REGEXP.")
 255
 256 (defvar ti::ck-:this-command nil
 257   "Private. Current advice command.")
 258
 259 ;;  To prevent buffer growing too much
 260 ;;
 261 (defvar ti::ck-:debug-buffer-size 500
 262   "Clear the `ti::ck-:debug-buffer' if line count exceed this value.")
 263
 264 (defvar ti::ck-:debug-buffer "*ti::ck-debug*"
 265   "Debug buffer for key binding commands.")
 266
 267 ;;}}}
 268 ;;{{{ setup: -- user
 269
 270 ;;; ........................................................ &v-public ...
 271 ;;; User configurable, but in general you don't need to touch this
 272 ;;; section.
 273
 274 (defvar ti::ck-:debug nil
 275   "*Turn on/off key conversion debugging.")
 276
 277 (defvar ti::ck-:keep-next-symbol-together
 278   '("kp")
 279   "*Keep SYMBOL and next key bind definition together.
 280 When this string is found from key binding definition, it is
 281 not a stand alone event name, but only part of it. After reading the next
 282 token, the X-event has been qualified.
 283
 284 Eg. `kp' is a prefix for keypad X-event symbols, so we actually mean
 285 one key when we say 'kp-tab' and not two separate events like `kp' and `tab'.
 286
 287 Format:
 288  '(STRING-SYMBOL
 289    STRING-SYMBOL
 290    ..)")
 291
 292 (defconst ti::ck-:key-table
 293   '((A          . alt)
 294     (C          . control)
 295     (H          . hyper)
 296     (S          . shift)
 297     (s          . super)
 298     (M          . meta)
 299     (mouse-1    . button1)
 300     (mouse-2    . button2)
 301     (mouse-3    . button3)
 302     (down-mouse-1    . button1up)
 303     (down-mouse-2    . button2up)
 304     (down-mouse-3    . button3up))
 305   "*Key bind modifier mappings from Emacs to XEmacs.
 306 This is a primitive table from where the complex keybindings are
 307 derived, eg you don't put following entry to this table:
 308
 309    (C-M-mouse-1       . (control meta button1))
 310
 311 Because it can be already contructed from the primitives.
 312 If you have a need to change this table, please contact maintainer.
 313
 314 Format:
 315 '((EMACS-MODIFIER . XEMACS-MODIFIER)
 316   (EMACS-MODIFIER . XEMACS-MODIFIER)
 317   ..)")
 318
 319 ;;}}}
 320 ;;{{{ setup: -- version
 321
 322 ;;; ......................................................... &version ...
 323
 324 (defvar ti::ck-:version-id
 325   "$Id: tinylibck.el,v 2.39 2007/05/07 10:50:07 jaalto Exp $"
 326   "Full program version ID string.")
 327
 328 ;;; ----------------------------------------------------------------------
 329 ;;;
 330 (defun ti::ck-version (&optional arg)
 331   "Version information. With ARG, print briefly."
 332   (interactive "P")
 333   (ti::package-version-info "tinylibck.el" arg))
 334
 335 ;;; ----------------------------------------------------------------------
 336 ;;;
 337 (defun ti::ck-submit-feedback ()
 338   "Submit suggestions, error corrections, impressions, anything..."
 339   (interactive)
 340   (ti::package-submit-feedback "tinylibck.el"))
 341
 342 ;;}}}
 343 ;;{{{ misc, debug
 344
 345 ;;; ----------------------------------------------------------------------
 346 ;;;
 347 (defmacro ti::ck-do-p (arg)
 348   "Check if conversion is needed. ARG is the key definition."
 349   (` (not (stringp (, arg)))))          ;pass "" string bindings as is
 350
 351 ;;; ----------------------------------------------------------------------
 352 ;;; - Just for load hook
 353 ;;;
 354 (defun turn-on-ti::ck-debug ()
 355   "Turn on debug."
 356   (interactive)
 357   (ti::ck-debug-toggle 1))
 358
 359 ;;; ----------------------------------------------------------------------
 360 ;;;
 361 ;;;###autoload
 362 (defun ti::ck-debug-toggle (&optional arg)
 363   "Turn debug on or off with ARG. See buffer `ti::ck-:debug-buffer'."
 364   (interactive)
 365   (cond
 366    ((eq 1 arg)
 367     (setq ti::ck-:debug t))
 368    ((memq arg '(0 -1))
 369     (setq ti::ck-:debug nil))
 370    (t
 371     (setq ti::ck-:debug (not ti::ck-:debug))))
 372   (if (interactive-p)
 373       (message (concat "Debug " (if ti::ck-:debug "on" "off")))))
 374
 375 ;;; ----------------------------------------------------------------------
 376 ;;;
 377 (defun ti::ck-debug-write (str)
 378   "Record STR to debug buffer."
 379   (let* ((buffer (get-buffer-create ti::ck-:debug-buffer)))
 380     (with-current-buffer buffer
 381       (if (> (count-lines (point-min) (point-max))
 382              ti::ck-:debug-buffer-size)
 383           (erase-buffer))
 384       (goto-char (point-max))
 385       (insert str))))
 386
 387 ;;}}}
 388 ;;{{{ advice
 389
 390 ;;; ----------------------------------------------------------------------
 391 ;;;
 392 (defun ti::ck-advice-control (&optional disable verb)
 393   "Install advices or optionally DISABLE them. VERB."
 394   (interactive "P")
 395   (let* ((funcs '(global-set-key
 396                   local-set-key
 397                   define-key))
 398          (re   ti::ck-:advice-re)
 399          (verb (or verb (interactive-p)))
 400          func)
 401     (while funcs
 402       (setq func (car funcs))
 403       (ignore-errors
 404         (if disable
 405             (ad-disable-advice  func 'any re) ;;clear flag
 406           (ad-enable-advice     func 'any re))
 407         (ad-activate func)) ;;change state
 408       (setq funcs (cdr funcs)))
 409
 410     (if verb
 411         (if disable
 412             (message "tinylibck Advices disabled.")
 413           (message "tinylibck Advices activated.")))))
 414
 415 ;;; ----------------------------------------------------------------------
 416 ;;;
 417 (defadvice global-set-key (before ti::ck-keybind-converter  dis)
 418   "XEmacs and Emacs emulation. See function `ti::ck-do' for full story."
 419   (setq ti::ck-:this-command 'global-set-key)
 420   (if (ti::ck-do-p (ad-get-arg 0))
 421       (ad-set-arg 0 (ti::ck-do (ad-get-arg 0)))))
 422
 423 ;;; ----------------------------------------------------------------------
 424 ;;;
 425 (defadvice local-set-key (before ti::ck-keybind-converter  dis)
 426   "XEmacs and Emacs emulation. See function `ti::ck-do' for full story."
 427   (setq ti::ck-:this-command 'local-set-key)
 428   (if (ti::ck-do-p (ad-get-arg 0))
 429       (ad-set-arg 0 (ti::ck-do (ad-get-arg 0)))))
 430
 431 ;;; ----------------------------------------------------------------------
 432 ;;;
 433 (defadvice define-key (before ti::ck-keybind-converter  dis)
 434   "XEmacs and Emacs emulation. See function`ti::ck-do' for full story."
 435   (setq ti::ck-:this-command 'define-key)
 436   (let* ((arg (ad-get-arg 1)))
 437     (when (ti::ck-do-p arg)
 438       (if (and (vectorp arg)
 439                (length arg)             ; "[0]"
 440                (eq 0 (elt arg 0)))
 441           (error                         ; otw user doesn't know what
 442            (concat                       ; going on.. barf immediately
 443             "define-key/tinylibck.el: "
 444             "Vector contains zero. Did you use Emacs styled \"[?\\C-`]\" "
 445             "Wich can't be converted? Use equivalent [(control ?\\`)] "
 446             "instead which works for both XEmacs and Emacs. "
 447             "See comments in tinylibck.el for more.")))
 448       (ad-set-arg 1 (ti::ck-do (ad-get-arg 1))))))
 449
 450 ;;; ----------------------------------------------------------------------
 451 ;;; (ad-unadvise 'ti::ck-do)
 452 ;;;
 453 (defadvice ti::ck-do (around ti::ck-debug act)
 454   "Debug filter. Record command, input/output values."
 455   (cond
 456    ((eq nil ti::ck-:debug)
 457     ad-do-it)
 458    (t
 459     (ti::ck-debug-write
 460      (format
 461       "\n%-15s %-25s >> "
 462       (or (prin1-to-string ti::ck-:this-command) "")
 463       (or (prin1-to-string (ad-get-args 0))     "")))
 464
 465     ad-do-it
 466     (ti::ck-debug-write (concat (prin1-to-string ad-return-value))))))
 467
 468 ;;}}}
 469 ;;{{{ conversions
 470
 471 ;;; ----------------------------------------------------------------------
 472 ;;;
 473 (defun ti::ck-get-key-code-string (str)
 474   "Convert STR A -C -k --> ?\\A -\\C -k."
 475   (let* ((ret   "?\\")
 476          (len   (length str))
 477          (i     0)
 478          case-fold-search
 479          ch
 480          next)
 481     (while (< i len)
 482       (setq ch   (aref str i)
 483             next (if (< (1+ i)
 484                         len)
 485                      (aref str (1+ i))))
 486       (setq ret
 487             (concat
 488              ret
 489              (if (and (eq ch ?-)
 490                       ;;  A-S-a  --> \A-\S-a, but
 491                       ;;  A-s    --> \A-s
 492                       (and next
 493                            (string-match "[A-Z]"
 494                                          (char-to-string next))))
 495                  "-\\"
 496                (char-to-string ch))))
 497       (setq i (1+ i)))
 498     ret))
 499
 500 ;;; ----------------------------------------------------------------------
 501 ;;; - This is kinda faking Emacs, but since there is _no_ other way to
 502 ;;;   find the integer code for vector [?\A-a], we have to make Emacs
 503 ;;;   tell it to us.
 504 ;;;
 505 (defun ti::ck-get-key-code (simple-key-sequence)
 506   "Find out the integer value for SIMPLE-KEY-SEQUENCE, like S-a."
 507   (let* (lisp-mode-hook                ;don't run any hooks while here
 508          (buffer (get-buffer-create "*tmp*"))
 509          (modes  '(lisp-mode
 510                    emacs-lisp-mode
 511                    lisp-interaction-mode))
 512          ret)
 513     ;; XEmacs doesn't have this variable, Quiet ByteCompiler warning.
 514     ;; This is no-op
 515     (if lisp-mode-hook
 516         (setq lisp-mode-hook nil))
 517     (setq simple-key-sequence
 518           (ti::ck-get-key-code-string simple-key-sequence))
 519     (save-excursion
 520       (set-buffer buffer)
 521       (erase-buffer)
 522       ;;  Don't just always execute (lisp-mode), since
 523       ;;  setting up major mode may be time consuming.
 524       (if (not (memq major-mode modes))
 525           (lisp-mode))
 526       (insert "[" simple-key-sequence "]")
 527       ;;  This spits out the integer number
 528       (eval-last-sexp 1)
 529       (beginning-of-line)
 530       (when (looking-at ".*\\[\\([0-9]+\\)")
 531         (setq ret
 532               (string-to-int
 533                (buffer-substring (match-beginning 1) (match-end 1)))))
 534
 535       ret)))
 536
 537 ;;; ----------------------------------------------------------------------
 538 ;;;
 539 ;;; (ti::ck-gnu2xe-vector [C-kp-tab])
 540 ;;;
 541 ;;; [C-kp-tab]   --> [(control kp-tab)]
 542 ;;; [M-f1 C-f2]  --> [(meta f1) (control f2)]
 543 ;;; [?\e delete] --> [(meta delete)]  , we suppose meta is same as ESC.
 544 ;;;
 545 (defun ti::ck-gnu2xe-vector (vec)
 546   "Convert Emacs VEC bindings to XEmacs style."
 547   (let* ((table     ti::ck-:key-table)
 548          (keep-list ti::ck-:keep-next-symbol-together)
 549          (i     0)
 550          len
 551          x
 552          elt
 553          str
 554          pos
 555          aset-pos
 556          list
 557          new-vec
 558          gather-flag
 559          gather-str)
 560     (setq len (length vec)  elt (elt vec 0))
 561     (setq i        0
 562           aset-pos 0)
 563     (setq new-vec (make-vector len nil)) ;put results here
 564     ;;  This is for due to ESC key in commands like:
 565     ;;  Emacs [?\e ?k] --> XEmacs [(meta k)]
 566     (cond
 567      ((and (eq 27 elt)                  ;first element is ?\e
 568            (symbolp (elt vec 1)))
 569       ;;  Put elements 0 and 1 together "?\e delete" --> "M-delete"
 570       (setq str (concat "M-" (symbol-name (elt vec 1))))
 571       (aset vec 1 (intern str))
 572       (setq i 1)                        ;start here, skip item 0
 573       (setq new-vec (make-vector (1- len) nil)))
 574      ((and (eq 27 elt)                  ;first element is ?\e
 575            (eq 2 len))
 576       (setq str (concat "M-" (char-to-string (elt vec 1))))
 577       (aset vec 1 (intern str))
 578       (setq i 1)                        ;start here, skip item 0
 579       (setq new-vec (make-vector (1- len) nil))))
 580     (while (< i len)
 581       (setq x (elt vec i))
 582       (cond
 583        ;;  [?\C-x mouse-1] ==> [(control x) (button1)]
 584        ((and (integerp x)
 585              (< x 27))
 586         (setq x
 587               (list
 588                'control
 589                ;; ?\C-a -- "a"
 590                (intern (char-to-string (+ 96 x))))))
 591        ((integerp x)                    ; other [?\C-z ...]
 592         nil)
 593        ((symbolp x)
 594         (setq str (symbol-name x)) ;; [C-up] => "C-up"
 595         (setq list nil)
 596         (while str
 597           (if (or (string-match "^\\(down-\\)?mouse-[1-3]" str)
 598                   (string-match "^[^-]+" str))
 599               (progn
 600                 (setq pos (match-end 0))
 601                 (setq elt (substring str 0 pos))
 602
 603                 (if (< pos (length str))
 604                     (setq str (substring str (1+ pos)))
 605                   (setq str nil)))
 606             ;;  No more "-" characters in string
 607             (setq elt str   str nil))
 608           ;;  There are certain X symbols that should be kept together
 609           ;;  [C-kp-tab]  --> (control kp_tab) and not (control kp tab)
 610           (cond
 611            ((member elt keep-list)
 612             (setq gather-str elt  gather-flag 0   elt nil))
 613
 614            ((stringp gather-str)
 615             (setq gather-flag (1+ gather-flag))
 616             (if (eq 1 gather-flag)
 617                 (setq elt (concat gather-str "_" elt)
 618                       gather-str  nil
 619                       gather-flag nil)
 620               (setq elt          gather-str
 621                     gather-flag  nil
 622                     gather-str   nil))))
 623           (cond
 624            (elt
 625             (setq elt (intern elt))
 626             (if (setq x (assq elt table))
 627                 (setq elt (cdr x)))
 628             (setq list (append list (list elt))))))
 629         (setq x list)))
 630
 631       (aset new-vec aset-pos x)
 632       (setq i         (1+ i)
 633             aset-pos  (1+ aset-pos)))
 634     new-vec))
 635
 636 ;;; ----------------------------------------------------------------------
 637 ;;; [(meta f1) (control f2)] --> [M-f1 C-f2]
 638 ;;;
 639 (defun ti::ck-xe2gnu-vector (vec)
 640   "Convert XEmacs VEC to Emacs."
 641   (let* ((i     0)
 642          len
 643          sym
 644          x
 645          new-vec)
 646     (setq len (length vec))
 647     (setq new-vec (make-vector len nil))
 648     (while (< i len)
 649       (setq x (elt vec i))
 650       (cond
 651        ((integerp x)                    ;[?\C-z ...]
 652         nil)                            ;as is
 653        ((and (symbolp x)
 654              (setq sym (symbol-name x))
 655              (eq 1 (length sym)))       ;one character
 656         ;; In XEmacs, it's valid to have [f1 a], where 'a' means character
 657         ;; a. In Emacs you'd need ?a for that.
 658         ;; => as char
 659         (setq x (string-to-char sym)))
 660        ((listp x)
 661         (setq x (ti::ck-xe2gnu-list x))))
 662       (aset new-vec i x)
 663       (setq i (1+ i)))
 664     new-vec))
 665
 666 ;;; ----------------------------------------------------------------------
 667 ;;; (meta f1) --> M-f1 symbol, or '(alt a) --> 120345 some keycode integer.
 668 ;;;
 669 (defun ti::ck-xe2gnu-list (list)
 670   "Convert XEmacs bind LIST to emacs."
 671   (let* ((table ti::ck-:key-table)
 672          item
 673          elt
 674          str
 675          padd
 676          ret)
 677     (setq str "")
 678     (while list
 679       (setq elt (car list))
 680       (setq padd (if (cdr list)
 681                      "-"
 682                    ""))
 683       (cond
 684        ((setq item (rassq elt table))
 685         (setq elt (symbol-name (car item))))
 686        ((integerp elt)
 687         (setq elt (char-to-string elt)))
 688        ((and (stringp str)
 689              (symbolp elt))             ;keep it as string, see concat
 690         (setq elt (symbol-name elt))))
 691
 692       (setq str (concat str elt padd))
 693       (setq list (cdr list)))
 694     (cond
 695      ((string= "" str)
 696       nil)
 697      ((and (not (string-match "mouse" str))
 698            ;; "A-a"  "A-C-k" "?\C-`"
 699            (string-match "-.$\\|^[?][\\]?" str))
 700       (setq ret (ti::ck-get-key-code str)))
 701      (t
 702       (setq ret (intern str))))
 703     ret))
 704
 705 ;;}}}
 706 ;;{{{ main
 707
 708 ;;; ----------------------------------------------------------------------
 709 ;;; - 20 Apr 1996, Idea by Vladimir Alexiev <vladimir@cs.ualberta.ca>
 710 ;;; - 22 Apr 1996, Reprogrammed by Jari Aalto [jari]
 711 ;;;
 712 ;;;###autoload
 713 (defun ti::ck-do (key &optional xe)
 714   "Transform key binding to XEmacs or Emacs in current environment.
 715 on current emacs. This enables you to have same key binding file
 716 for both emacs versions. You can write key bindings either in XEmacs
 717 or Emacs style.
 718
 719     In Emacs :  (ti::ck-do '(meta up)) --> [M-up]
 720     In XEmacs:  (ti::ck-do [M-up])     --> '(meta up)
 721
 722 This function does the conversion only if it needs to, and returns
 723 immediately if no conversion is needed. This should minimise performance
 724 penalty.
 725
 726 Input:
 727   KEY    key sequence
 728   XE     flag. If this is nil, then Emacs env. is assumed. However
 729          `ti::ck-:xemacs-flag' is obeyed if it is non-nil.
 730          If non-nil, then XEmacs env. is assumed and conversion to
 731          XEmacs like bindings are done."
 732   (let (
 733         ;;      For greater speed this is read from variable
 734         ;;      and not dynamically for every call.
 735         (xe     (or xe ti::ck-:xemacs-flag))
 736         ret
 737         vec
 738         D)                              ;debug
 739     (cond
 740      ((and (not xe)                     ; in Emacs
 741            (vectorp key))               ; [C-up]
 742       (cond
 743        ((and (listp (elt key 0))
 744              (< ti::ck-:emacs-minor 30)) ;19.30 supports [(control up)]
 745         (setq D "1 xe2gnu-vector")
 746         (setq ret (ti::ck-xe2gnu-vector key)))
 747        (t
 748         (setq D "1 as is")
 749         (setq ret key))))               ; return "as is"
 750      ((and (not xe)                     ; '(control f1) --> C-fi
 751            (listp key))
 752       (setq D "2 ti::ck-xe2gnu-list")
 753       (setq vec (make-vector 1 nil))
 754       (setq ret (ti::ck-xe2gnu-list key))
 755       (aset vec 0 ret)
 756       (setq ret vec))
 757      ((and xe
 758            (or (listp key)              ; '(control up) in XEmacs
 759                (symbolp key)            ; 'button2
 760                (and (vectorp key)       ; [(button2]) case...
 761                     (listp (elt key 0)))))
 762       (setq D "3")
 763       (setq ret key))                   ; return "as is"
 764      ((and xe
 765            (vectorp key))               ; [C-up] to XEmacs
 766       (setq D "4  gnu2xe-vector")
 767       (setq ret (ti::ck-gnu2xe-vector  key))))
 768
 769     ;; Quiet XEmacs 19.14 ByteCompiler, This is no-op.
 770     (if D
 771         (setq D D))
 772     ret))
 773
 774 ;;}}}
 775
 776 (provide   'tinylibck)
 777 (run-hooks 'ti::ck-:load-hook)
 778
 779 ;;; tinylibck.el ends here