lisp/international/encoded-kb.el

   1 ;;; encoded-kb.el --- handler to input multibyte characters encoded somehow
   2
   3 ;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
   4 ;;   Free Software Foundation, Inc.
   5 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   6 ;;   2005, 2006, 2007, 2008
   7 ;;   National Institute of Advanced Industrial Science and Technology (AIST)
   8 ;;   Registration Number H14PRO021
   9 ;; Copyright (C) 2003
  10 ;;   National Institute of Advanced Industrial Science and Technology (AIST)
  11 ;;   Registration Number H13PRO009
  12
  13 ;; This file is part of GNU Emacs.
  14
  15 ;; GNU Emacs is free software; you can redistribute it and/or modify
  16 ;; it under the terms of the GNU General Public License as published by
  17 ;; the Free Software Foundation; either version 3, or (at your option)
  18 ;; any later version.
  19
  20 ;; GNU Emacs is distributed in the hope that it will be useful,
  21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 ;; GNU General Public License for more details.
  24
  25 ;; You should have received a copy of the GNU General Public License
  26 ;; along with GNU Emacs; 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 ;;; Commentary:
  31
  32 ;;; Code:
  33
  34 ;; Usually this map is empty (even if Encoded-kbd mode is on), but if
  35 ;; the keyboard coding system is iso-2022-based, it defines dummy key
  36 ;; bindings for ESC $ ..., etc. so that those bindings in
  37 ;; input-decode-map take effect.
  38 (defconst encoded-kbd-mode-map (make-sparse-keymap)
  39   "Keymap for Encoded-kbd minor mode.")
  40
  41 ;; Subsidiary keymaps for handling ISO2022 escape sequences.
  42
  43 (defvar encoded-kbd-iso2022-esc-map
  44   (let ((map (make-sparse-keymap)))
  45     (define-key map "$" 'encoded-kbd-iso2022-esc-dollar-prefix)
  46     (define-key map "(" 'encoded-kbd-iso2022-designation-prefix)
  47     (define-key map ")" 'encoded-kbd-iso2022-designation-prefix)
  48     (define-key map "," 'encoded-kbd-iso2022-designation-prefix)
  49     (define-key map "-" 'encoded-kbd-iso2022-designation-prefix)
  50     map)
  51   "Keymap for handling ESC code in Encoded-kbd mode.")
  52 (fset 'encoded-kbd-iso2022-esc-prefix encoded-kbd-iso2022-esc-map)
  53
  54 (defvar encoded-kbd-iso2022-esc-dollar-map
  55   (let ((map (make-sparse-keymap)))
  56     (define-key map "(" 'encoded-kbd-iso2022-designation-prefix)
  57     (define-key map ")" 'encoded-kbd-iso2022-designation-prefix)
  58     (define-key map "," 'encoded-kbd-iso2022-designation-prefix)
  59     (define-key map "-" 'encoded-kbd-iso2022-designation-prefix)
  60     (define-key map "@" 'encoded-kbd-iso2022-designation)
  61     (define-key map "A" 'encoded-kbd-iso2022-designation)
  62     (define-key map "B" 'encoded-kbd-iso2022-designation)
  63     map)
  64   "Keymap for handling ESC $ sequence in Encoded-kbd mode.")
  65 (fset 'encoded-kbd-iso2022-esc-dollar-prefix
  66       encoded-kbd-iso2022-esc-dollar-map)
  67
  68 (defvar encoded-kbd-iso2022-designation-map
  69   (let ((map (make-sparse-keymap))
  70         (l charset-list)
  71         final-char)
  72     (while l
  73       (setq final-char (charset-iso-final-char (car l)))
  74       (if (> final-char 0)
  75           (define-key map (char-to-string final-char)
  76             'encoded-kbd-iso2022-designation))
  77       (setq l (cdr l)))
  78     map)
  79   "Keymap for handling ISO2022 designation sequence in Encoded-kbd mode.")
  80 (fset 'encoded-kbd-iso2022-designation-prefix
  81       encoded-kbd-iso2022-designation-map)
  82
  83 ;; Keep information of designation state of ISO2022 encoding.  When
  84 ;; Encoded-kbd mode is on, this is set to a vector of length 4, the
  85 ;; elements are character sets currently designated to graphic
  86 ;; registers 0 thru 3.
  87
  88 (defvar encoded-kbd-iso2022-designations nil)
  89 (put 'encoded-kbd-iso2022-designations 'permanent-local t)
  90
  91 ;; Keep information of invocation state of ISO2022 encoding.  When
  92 ;; Encoded-kbd mode is on, this is set to a vector of length 3,
  93 ;; graphic register numbers currently invoked to graphic plane 1 and
  94 ;; 2, and a single shifted graphic register number.
  95
  96 (defvar encoded-kbd-iso2022-invocations nil)
  97 (put 'encoded-kbd-iso2022-invocations 'permanent-local t)
  98
  99 (defsubst encoded-kbd-last-key ()
 100   (let ((keys (this-single-command-keys)))
 101     (aref keys (1- (length keys)))))
 102
 103 (defun encoded-kbd-iso2022-designation (ignore)
 104   "Do ISO2022 designation according to the current key in Encoded-kbd mode.
 105 The following key sequence may cause multilingual text insertion."
 106   (let ((key-seq (this-single-command-keys))
 107         (prev-g0-charset (aref encoded-kbd-iso2022-designations
 108                                (aref encoded-kbd-iso2022-invocations 0)))
 109         intermediate-char final-char
 110         reg dimension chars charset)
 111     (if (= (length key-seq) 4)
 112         ;; ESC $ <intermediate-char> <final-char>
 113         (setq intermediate-char (aref key-seq 2)
 114               dimension 2
 115               chars (if (< intermediate-char ?,) 94 96)
 116               final-char (aref key-seq 3)
 117               reg (mod intermediate-char 4))
 118       (if (= (aref key-seq 1) ?$)
 119           ;; ESC $ <final-char>
 120           (setq dimension 2
 121                 chars 94
 122                 final-char (aref key-seq 2)
 123                 reg 0)
 124         ;; ESC <intermediate-char> <final-char>
 125         (setq intermediate-char (aref key-seq 1)
 126               dimension 1
 127               chars (if (< intermediate-char ?,) 94 96)
 128               final-char (aref key-seq 2)
 129               reg (mod intermediate-char 4))))
 130     (aset encoded-kbd-iso2022-designations reg
 131           (iso-charset dimension chars final-char)))
 132   "")
 133
 134 (defun encoded-kbd-iso2022-single-shift (ignore)
 135   (let ((char (encoded-kbd-last-key)))
 136     (aset encoded-kbd-iso2022-invocations 2 (if (= char ?\216) 2 3)))
 137   "")
 138
 139 (defun encoded-kbd-self-insert-iso2022-7bit (ignore)
 140   (let ((char (encoded-kbd-last-key))
 141         (charset (aref encoded-kbd-iso2022-designations
 142                        (or (aref encoded-kbd-iso2022-invocations 2)
 143                            (aref encoded-kbd-iso2022-invocations 0)))))
 144     (aset encoded-kbd-iso2022-invocations 2 nil)
 145     (vector (if (= (charset-dimension charset) 1)
 146                 (make-char charset char)
 147               (make-char charset char (read-char-exclusive))))))
 148
 149 (defun encoded-kbd-self-insert-iso2022-8bit (ignore)
 150   (let ((char (encoded-kbd-last-key))
 151         (charset (aref encoded-kbd-iso2022-designations
 152                        (or (aref encoded-kbd-iso2022-invocations 2)
 153                            (aref encoded-kbd-iso2022-invocations 1)))))
 154     (aset encoded-kbd-iso2022-invocations 2 nil)
 155     (vector (if (= (charset-dimension charset) 1)
 156                 (make-char charset char)
 157               (make-char charset char (read-char-exclusive))))))
 158
 159 (defun encoded-kbd-self-insert-sjis (ignore)
 160   (let ((char (encoded-kbd-last-key)))
 161     (vector
 162      (if (or (< char ?\xA0) (>= char ?\xE0))
 163          (decode-sjis-char (+ (ash char 8) (read-char-exclusive)))
 164        (make-char 'katakana-jisx0201 char)))))
 165
 166 (defun encoded-kbd-self-insert-big5 (ignore)
 167   (let ((char (encoded-kbd-last-key)))
 168     (vector
 169      (decode-big5-char (+ (ash char 8) (read-char-exclusive))))))
 170
 171 (defun encoded-kbd-self-insert-ccl (ignore)
 172   (let ((str (char-to-string (encoded-kbd-last-key)))
 173         (ccl (coding-system-get (keyboard-coding-system) :ccl-decoder))
 174         (vec [nil nil nil nil nil nil nil nil nil])
 175         result)
 176     (while (= (length (setq result (ccl-execute-on-string ccl vec str t))) 0)
 177       (dotimes (i 9) (aset vec i nil))
 178       (setq str (format "%s%c" str (read-char-exclusive))))
 179     (vector (aref result 0))))
 180
 181
 182 ;; Decode list of codes in CODE-LIST by CHARSET and return the decoded
 183 ;; characters.  If CODE-LIST is too short for the dimension of
 184 ;; CHARSET, read new codes and append them to the tail of CODE-LIST.
 185 ;; Return nil if CODE-LIST can't be decoded.
 186
 187 (defun encoded-kbd-decode-code-list (charset code-list)
 188   (let ((dimension (charset-dimension charset))
 189         code)
 190     (while (> dimension (length code-list))
 191       (nconc code-list (list (read-char-exclusive))))
 192     (setq code (car code-list))
 193     (if (= dimension 1)
 194         (decode-char charset code)
 195       (setq code-list (cdr code-list)
 196             code (logior (lsh code 8) (car code-list)))
 197       (if (= dimension 2)
 198           (decode-char charset code)
 199         (setq code-list (cdr code-list)
 200               code (logior (lsh code 8) (car code-list)))
 201         (if (= dimension 3)
 202             (decode-char charset code)
 203           ;; As Emacs can't handle full 32-bit integer, we must give a
 204           ;; cons of higher and lower 16-bit codes to decode-char.
 205           (setq code (cons (lsh code -8)
 206                            (logior (lsh (car code-list) 8) (cadr code-list))))
 207           (decode-char charset code))))))
 208
 209 (defun encoded-kbd-self-insert-charset (ignore)
 210   (let ((charset-list
 211          (coding-system-get (keyboard-coding-system) :charset-list))
 212         (code-list (list (encoded-kbd-last-key)))
 213         tail char)
 214     (while (and charset-list (not char))
 215       (setq char (encoded-kbd-decode-code-list (car charset-list) code-list)
 216             charset-list (cdr charset-list)))
 217     (if char
 218         (vector char)
 219       (setq unread-command-events (cdr code-list))
 220       (vector (car code-list)))))
 221
 222 (defun encoded-kbd-self-insert-utf-8 (arg)
 223   (interactive "p")
 224   (let ((char (encoded-kbd-last-key))
 225         len)
 226     (cond ((< char #xE0)
 227            (setq len 1 char (logand char #x1F)))
 228           ((< char #xF0)
 229            (setq len 2 char (logand char #x0F)))
 230           ((< char #xF8)
 231            (setq len 3 char (logand char #x07)))
 232           (t
 233            (setq len 4 char 0)))
 234     (while (> len 0)
 235       (setq char (logior (lsh char 6) (logand (read-char-exclusive) #x3F))
 236             len (1- len)))
 237     (vector char)))
 238
 239 (defun encoded-kbd-setup-keymap (keymap coding)
 240   ;; At first, reset the keymap.
 241   (define-key encoded-kbd-mode-map "\e" nil)
 242   ;; Then setup the keymap according to the keyboard coding system.
 243   (cond
 244    ((eq (coding-system-type coding) 'shift-jis)
 245     (let ((i 128))
 246       (while (< i 256)
 247         (define-key keymap
 248           (vector i) 'encoded-kbd-self-insert-sjis)
 249         (setq i (1+ i))))
 250     8)
 251
 252    ((eq (coding-system-type coding) 'charset)
 253     (dolist (elt (mapcar
 254                   #'(lambda (x)
 255                       (let ((dim (charset-dimension x))
 256                             (code-space (get-charset-property x :code-space)))
 257                         (cons (aref code-space (* (1- dim) 2))
 258                               (aref code-space (1+ (* (1- dim) 2))))))
 259                   (coding-system-get coding :charset-list)))
 260       (let ((from (max (car elt) 128))
 261             (to (cdr elt)))
 262         (while (<= from to)
 263           (define-key keymap
 264             (vector from) 'encoded-kbd-self-insert-charset)
 265           (setq from (1+ from)))))
 266     8)
 267
 268    ((eq (coding-system-type coding) 'iso-2022)
 269     (let ((flags (coding-system-get coding :flags))
 270           (designation (coding-system-get coding :designation)))
 271       (if (memq 'locking-shift flags)
 272           nil                           ; Don't support locking-shift.
 273         (setq encoded-kbd-iso2022-designations (make-vector 4 nil)
 274               encoded-kbd-iso2022-invocations (make-vector 3 nil))
 275         (dotimes (i 4)
 276           (if (aref designation i)
 277               (if (charsetp (aref designation i))
 278                   (aset encoded-kbd-iso2022-designations
 279                         i (aref designation i))
 280                 (if (charsetp (car-safe (aref designation i)))
 281                     (aset encoded-kbd-iso2022-designations
 282                           i (car (aref designation i)))))))
 283         (aset encoded-kbd-iso2022-invocations 0 0)
 284         (if (aref encoded-kbd-iso2022-designations 1)
 285             (aset encoded-kbd-iso2022-invocations 1 1))
 286         (when (memq 'designation flags)
 287           (define-key encoded-kbd-mode-map "\e" 'encoded-kbd-iso2022-esc-prefix)
 288           (define-key keymap "\e" 'encoded-kbd-iso2022-esc-prefix))
 289         (when (or (aref designation 2) (aref designation 3))
 290           (define-key keymap
 291             [?\216] 'encoded-kbd-iso2022-single-shift)
 292           (define-key keymap
 293             [?\217] 'encoded-kbd-iso2022-single-shift))
 294         (or (eq (aref designation 0) 'ascii)
 295             (dotimes (i 96)
 296               (define-key keymap
 297                 (vector (+ 32 i)) 'encoded-kbd-self-insert-iso2022-7bit)))
 298         (if (memq '7-bit flags)
 299             t
 300           (dotimes (i 96)
 301             (define-key keymap
 302               (vector (+ 160 i)) 'encoded-kbd-self-insert-iso2022-8bit))
 303           8))))
 304
 305    ((eq (coding-system-type coding) 4)  ; CCL-base
 306     (let ((valid-codes (or (coding-system-get coding :valid)
 307                            '((128 . 255))))
 308           elt from to valid)
 309       (while valid-codes
 310         (setq elt (car valid-codes) valid-codes (cdr valid-codes))
 311         (if (consp elt)
 312             (setq from (car elt) to (cdr elt))
 313           (setq from (setq to elt)))
 314         (while (<= from to)
 315           (if (>= from 128)
 316               (define-key keymap
 317                 (vector from) 'encoded-kbd-self-insert-ccl))
 318           (setq from (1+ from))))
 319       8))
 320
 321    ((eq (coding-system-type coding) 'utf-8)
 322     (let ((i #xC0))
 323       (while (< i 256)
 324         (define-key keymap
 325           (vector i) 'encoded-kbd-self-insert-utf-8)
 326         (setq i (1+ i))))
 327     8)
 328
 329    (t
 330     nil)))
 331
 332 ;;;###autoload
 333 (defun encoded-kbd-setup-display (display)
 334   "Set up a `input-decode-map' for `keyboard-coding-system' on DISPLAY.
 335
 336 DISPLAY may be a display id, a frame, or nil for the selected frame's display."
 337   (let ((frame (if (framep display) display (car (frames-on-display-list display)))))
 338     (when frame
 339       (with-selected-frame frame
 340         ;; Remove any previous encoded-kb keymap from input-decode-map.
 341         (let ((m input-decode-map)
 342               (child nil))
 343           (while (keymapp m)
 344             (if (not (equal (keymap-prompt m) "encoded-kb"))
 345                 (progn
 346                   (setq child m)
 347                   (setq m (keymap-parent m)))
 348               ;; We've found an encoded-kb map, but maybe the prompt we get
 349               ;; is really inherited from the encoded-kb map.
 350               (let (mp)
 351                 (while (and (keymapp (setq mp (keymap-parent m)))
 352                             (equal (keymap-prompt mp) "encoded-kb"))
 353                   (setq child m)
 354                   (setq m mp))
 355                 ;; (assert (equal (keymap-prompt m) "encoded-kb"))
 356                 ;; (assert (eq mp (keymap-parent m)))
 357                 ;; (assert (not (and (keymapp mp)
 358                 ;;                   (equal (keymap-prompt mp) "encoded-kb"))))
 359                 ;; (assert (eq m (if child
 360                 ;;                   (keymap-parent child) input-decode-map)))
 361                 ;; We can finally do the actual removal.
 362                 (if child
 363                     (set-keymap-parent child mp)
 364                   (setq input-decode-map mp))
 365                 (setq m mp))))))
 366
 367       (if (keyboard-coding-system)
 368           ;; We are turning on Encoded-kbd mode.
 369           (let ((coding (keyboard-coding-system))
 370                 (keymap (make-sparse-keymap "encoded-kb"))
 371                 (cim (current-input-mode))
 372                 result)
 373             ;; Place `keymap' as the immediate parent of input-decode-map
 374             ;; rather than on top, so that later `define-key' on
 375             ;; input-decode-map don't end up accidentally changing our
 376             ;; part of the keymap, which would lead to bugs when/if we later
 377             ;; on remove that part.
 378             (set-keymap-parent keymap (keymap-parent input-decode-map))
 379             (set-keymap-parent input-decode-map keymap)
 380             (unless (terminal-parameter nil 'encoded-kbd-saved-input-meta-mode)
 381               (set-terminal-parameter nil 'encoded-kbd-saved-input-mode
 382                                       (nth 2 cim)))
 383             (setq result (and coding (encoded-kbd-setup-keymap keymap coding)))
 384             (if result
 385                 (when (and (eq result 8)
 386                            (memq (nth 2 cim) '(t nil)))
 387                   (set-input-meta-mode 'use-8th-bit))
 388               (set-terminal-parameter
 389                nil 'encoded-kbd-saved-input-meta-mode nil)
 390               (error "Unsupported coding system in Encoded-kbd mode: %S"
 391                      coding)))
 392         ;; We are turning off Encoded-kbd mode.
 393         (let ((old (terminal-parameter nil 'encoded-kbd-saved-input-meta-mode)))
 394           (when (and old (not (equal (nth 2 (current-input-mode)) old)))
 395             (set-input-meta-mode old))
 396           (set-terminal-parameter
 397            nil 'encoded-kbd-saved-input-meta-mode nil))))))
 398
 399 (provide 'encoded-kb)
 400
 401 ;; arch-tag: 76f0f9b3-65e7-45c3-b692-59509a87ad44
 402 ;;; encoded-kb.el ends here