1;;; mule.el --- basic commands for mulitilingual environment 2 3;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 4;; Free Software Foundation, Inc. 5;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 6;; 2005, 2006, 2007 7;; National Institute of Advanced Industrial Science and Technology (AIST) 8;; Registration Number H14PRO021 9 10;; Keywords: mule, multilingual, character set, coding system 11 12;; This file is part of GNU Emacs. 13 14;; GNU Emacs is free software; you can redistribute it and/or modify 15;; it under the terms of the GNU General Public License as published by 16;; the Free Software Foundation; either version 2, or (at your option) 17;; any later version. 18 19;; GNU Emacs is distributed in the hope that it will be useful, 20;; but WITHOUT ANY WARRANTY; without even the implied warranty of 21;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 22;; GNU General Public License for more details. 23 24;; You should have received a copy of the GNU General Public License 25;; along with GNU Emacs; see the file COPYING. If not, write to the 26;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 27;; Boston, MA 02110-1301, USA. 28 29;;; Commentary: 30 31;;; Code: 32 33(defconst mule-version "5.0 (SAKAKI)" "\ 34Version number and name of this version of MULE (multilingual environment).") 35 36(defconst mule-version-date "1999.12.7" "\ 37Distribution date of this version of MULE (multilingual environment).") 38 39(defun load-with-code-conversion (fullname file &optional noerror nomessage) 40 "Execute a file of Lisp code named FILE whose absolute name is FULLNAME. 41The file contents are decoded before evaluation if necessary. 42If optional third arg NOERROR is non-nil, 43 report no error if FILE doesn't exist. 44Print messages at start and end of loading unless 45 optional fourth arg NOMESSAGE is non-nil. 46Return t if file exists." 47 (if (null (file-readable-p fullname)) 48 (and (null noerror) 49 (signal 'file-error (list "Cannot open load file" file))) 50 ;; Read file with code conversion, and then eval. 51 (let* ((buffer 52 ;; To avoid any autoloading, set default-major-mode to 53 ;; fundamental-mode. 54 ;; So that we don't get completely screwed if the 55 ;; file is encoded in some complicated character set, 56 ;; read it with real decoding, as a multibyte buffer, 57 ;; even if this is a --unibyte Emacs session. 58 (let ((default-major-mode 'fundamental-mode) 59 (default-enable-multibyte-characters t)) 60 ;; We can't use `generate-new-buffer' because files.el 61 ;; is not yet loaded. 62 (get-buffer-create (generate-new-buffer-name " *load*")))) 63 (load-in-progress t) 64 (source (save-match-data (string-match "\\.el\\'" fullname)))) 65 (unless nomessage 66 (if source 67 (message "Loading %s (source)..." file) 68 (message "Loading %s..." file))) 69 (when purify-flag 70 (push file preloaded-file-list)) 71 (unwind-protect 72 (let ((load-file-name fullname) 73 (set-auto-coding-for-load t) 74 (inhibit-file-name-operation nil)) 75 (with-current-buffer buffer 76 ;; Don't let deactivate-mark remain set. 77 (let (deactivate-mark) 78 (insert-file-contents fullname)) 79 ;; If the loaded file was inserted with no-conversion or 80 ;; raw-text coding system, make the buffer unibyte. 81 ;; Otherwise, eval-buffer might try to interpret random 82 ;; binary junk as multibyte characters. 83 (if (and enable-multibyte-characters 84 (or (eq (coding-system-type last-coding-system-used) 5) 85 (eq last-coding-system-used 'no-conversion))) 86 (set-buffer-multibyte nil)) 87 ;; Make `kill-buffer' quiet. 88 (set-buffer-modified-p nil)) 89 ;; Have the original buffer current while we eval. 90 (eval-buffer buffer nil 91 ;; This is compatible with what `load' does. 92 (if purify-flag file fullname) 93 ;; If this Emacs is running with --unibyte, 94 ;; convert multibyte strings to unibyte 95 ;; after reading them. 96;; (not default-enable-multibyte-characters) 97 nil t 98 )) 99 (let (kill-buffer-hook kill-buffer-query-functions) 100 (kill-buffer buffer))) 101 (unless purify-flag 102 (do-after-load-evaluation fullname)) 103 104 (unless (or nomessage noninteractive) 105 (if source 106 (message "Loading %s (source)...done" file) 107 (message "Loading %s...done" file))) 108 t))) 109 110;; API (Application Program Interface) for charsets. 111 112(defsubst charset-quoted-standard-p (obj) 113 "Return t if OBJ is a quoted symbol, and is the name of a standard charset." 114 (and (listp obj) (eq (car obj) 'quote) 115 (symbolp (car-safe (cdr obj))) 116 (let ((vector (get (car-safe (cdr obj)) 'charset))) 117 (and (vectorp vector) 118 (< (aref vector 0) 160))))) 119 120(defsubst charsetp (object) 121 "Return t if OBJECT is a charset." 122 (and (symbolp object) (vectorp (get object 'charset)))) 123 124(defsubst charset-info (charset) 125 "Return a vector of information of CHARSET. 126The elements of the vector are: 127 CHARSET-ID, BYTES, DIMENSION, CHARS, WIDTH, DIRECTION, 128 LEADING-CODE-BASE, LEADING-CODE-EXT, 129 ISO-FINAL-CHAR, ISO-GRAPHIC-PLANE, 130 REVERSE-CHARSET, SHORT-NAME, LONG-NAME, DESCRIPTION, 131 PLIST, 132where 133CHARSET-ID (integer) is the identification number of the charset. 134BYTES (integer) is the length of multi-byte form of a character in 135 the charset: one of 1, 2, 3, and 4. 136DIMENSION (integer) is the number of bytes to represent a character of 137the charset: 1 or 2. 138CHARS (integer) is the number of characters in a dimension: 94 or 96. 139WIDTH (integer) is the number of columns a character in the charset 140 occupies on the screen: one of 0, 1, and 2. 141DIRECTION (integer) is the rendering direction of characters in the 142 charset when rendering. If 0, render from left to right, else 143 render from right to left. 144LEADING-CODE-BASE (integer) is the base leading-code for the 145 charset. 146LEADING-CODE-EXT (integer) is the extended leading-code for the 147 charset. All charsets of less than 0xA0 has the value 0. 148ISO-FINAL-CHAR (character) is the final character of the 149 corresponding ISO 2022 charset. If the charset is not assigned 150 any final character, the value is -1. 151ISO-GRAPHIC-PLANE (integer) is the graphic plane to be invoked 152 while encoding to variants of ISO 2022 coding system, one of the 153 following: 0/graphic-plane-left(GL), 1/graphic-plane-right(GR). 154 If the charset is not assigned any final character, the value is -1. 155REVERSE-CHARSET (integer) is the charset which differs only in 156 LEFT-TO-RIGHT value from the charset. If there's no such a 157 charset, the value is -1. 158SHORT-NAME (string) is the short name to refer to the charset. 159LONG-NAME (string) is the long name to refer to the charset 160DESCRIPTION (string) is the description string of the charset. 161PLIST (property list) may contain any type of information a user 162 want to put and get by functions `put-charset-property' and 163 `get-charset-property' respectively." 164 (get charset 'charset)) 165 166;; It is better not to use backquote in this file, 167;; because that makes a bootstrapping problem 168;; if you need to recompile all the Lisp files using interpreted code. 169 170(defmacro charset-id (charset) 171 "Return charset identification number of CHARSET." 172 (if (charset-quoted-standard-p charset) 173 (aref (charset-info (nth 1 charset)) 0) 174 (list 'aref (list 'charset-info charset) 0))) 175 176(defmacro charset-bytes (charset) 177 "Return bytes of CHARSET. 178See the function `charset-info' for more detail." 179 (if (charset-quoted-standard-p charset) 180 (aref (charset-info (nth 1 charset)) 1) 181 (list 'aref (list 'charset-info charset) 1))) 182 183(defmacro charset-dimension (charset) 184 "Return dimension of CHARSET. 185See the function `charset-info' for more detail." 186 (if (charset-quoted-standard-p charset) 187 (aref (charset-info (nth 1 charset)) 2) 188 (list 'aref (list 'charset-info charset) 2))) 189 190(defmacro charset-chars (charset) 191 "Return character numbers contained in a dimension of CHARSET. 192See the function `charset-info' for more detail." 193 (if (charset-quoted-standard-p charset) 194 (aref (charset-info (nth 1 charset)) 3) 195 (list 'aref (list 'charset-info charset) 3))) 196 197(defmacro charset-width (charset) 198 "Return width (how many column occupied on a screen) of CHARSET. 199See the function `charset-info' for more detail." 200 (if (charset-quoted-standard-p charset) 201 (aref (charset-info (nth 1 charset)) 4) 202 (list 'aref (list 'charset-info charset) 4))) 203 204(defmacro charset-direction (charset) 205 "Return direction of CHARSET. 206See the function `charset-info' for more detail." 207 (if (charset-quoted-standard-p charset) 208 (aref (charset-info (nth 1 charset)) 5) 209 (list 'aref (list 'charset-info charset) 5))) 210 211(defmacro charset-iso-final-char (charset) 212 "Return final char of CHARSET. 213See the function `charset-info' for more detail." 214 (if (charset-quoted-standard-p charset) 215 (aref (charset-info (nth 1 charset)) 8) 216 (list 'aref (list 'charset-info charset) 8))) 217 218(defmacro charset-iso-graphic-plane (charset) 219 "Return graphic plane of CHARSET. 220See the function `charset-info' for more detail." 221 (if (charset-quoted-standard-p charset) 222 (aref (charset-info (nth 1 charset)) 9) 223 (list 'aref (list 'charset-info charset) 9))) 224 225(defmacro charset-reverse-charset (charset) 226 "Return reverse charset of CHARSET. 227See the function `charset-info' for more detail." 228 (if (charset-quoted-standard-p charset) 229 (aref (charset-info (nth 1 charset)) 10) 230 (list 'aref (list 'charset-info charset) 10))) 231 232(defmacro charset-short-name (charset) 233 "Return short name of CHARSET. 234See the function `charset-info' for more detail." 235 (if (charset-quoted-standard-p charset) 236 (aref (charset-info (nth 1 charset)) 11) 237 (list 'aref (list 'charset-info charset) 11))) 238 239(defmacro charset-long-name (charset) 240 "Return long name of CHARSET. 241See the function `charset-info' for more detail." 242 (if (charset-quoted-standard-p charset) 243 (aref (charset-info (nth 1 charset)) 12) 244 (list 'aref (list 'charset-info charset) 12))) 245 246(defmacro charset-description (charset) 247 "Return description of CHARSET. 248See the function `charset-info' for more detail." 249 (if (charset-quoted-standard-p charset) 250 (aref (charset-info (nth 1 charset)) 13) 251 (list 'aref (list 'charset-info charset) 13))) 252 253(defmacro charset-plist (charset) 254 "Return list charset property of CHARSET. 255See the function `charset-info' for more detail." 256 (list 'aref 257 (if (charset-quoted-standard-p charset) 258 (charset-info (nth 1 charset)) 259 (list 'charset-info charset)) 260 14)) 261 262(defun set-charset-plist (charset plist) 263 "Set CHARSET's property list to PLIST, and return PLIST." 264 (aset (charset-info charset) 14 plist)) 265 266(defun make-char (charset &optional code1 code2) 267 "Return a character of CHARSET whose position codes are CODE1 and CODE2. 268CODE1 and CODE2 are optional, but if you don't supply 269sufficient position codes, return a generic character which stands for 270all characters or group of characters in the character set. 271A generic character can be used to index a char table (e.g. `syntax-table'). 272 273Such character sets as ascii, eight-bit-control, and eight-bit-graphic 274don't have corresponding generic characters. If CHARSET is one of 275them and you don't supply CODE1, return the character of the smallest 276code in CHARSET. 277 278If CODE1 or CODE2 are invalid (out of range), this function signals an 279error. However, the eighth bit of both CODE1 and CODE2 is zeroed 280before they are used to index CHARSET. Thus you may use, say, the 281actual ISO 8859 character code rather than subtracting 128, as you 282would need to index the corresponding Emacs charset." 283 (make-char-internal (charset-id charset) code1 code2)) 284 285(put 'make-char 'byte-compile 286 (lambda (form) 287 (let ((charset (nth 1 form))) 288 (byte-compile-normal-call 289 (cons 'make-char-internal 290 (cons (if (charset-quoted-standard-p charset) 291 (charset-id (nth 1 charset)) 292 (list 'charset-id charset)) 293 (nthcdr 2 form))))))) 294 295(defun charset-list () 296 "Return list of charsets ever defined. 297 298This function is provided for backward compatibility. 299Now we have the variable `charset-list'." 300 charset-list) 301 302(defsubst generic-char-p (char) 303 "Return t if and only if CHAR is a generic character. 304See also the documentation of `make-char'." 305 (and (>= char 0400) 306 (let ((l (split-char char))) 307 (and (or (= (nth 1 l) 0) (eq (nth 2 l) 0)) 308 (not (eq (car l) 'composition)))))) 309 310(defun decode-char (ccs code-point &optional restriction) 311 "Return character specified by coded character set CCS and CODE-POINT in it. 312Return nil if such a character is not supported. 313Currently the only supported coded character set is `ucs' (ISO/IEC 31410646: Universal Multi-Octet Coded Character Set), and the result is 315translated through the translation-table named 316`utf-translation-table-for-decode', or through the 317translation-hash-table named `utf-subst-table-for-decode' 318\(if `utf-translate-cjk-mode' is non-nil). 319 320Optional argument RESTRICTION specifies a way to map the pair of CCS 321and CODE-POINT to a character. Currently not supported and just ignored." 322 (cond 323 ((eq ccs 'ucs) 324 (or (and utf-translate-cjk-mode 325 (utf-lookup-subst-table-for-decode code-point)) 326 (let ((c (cond 327 ((< code-point 160) 328 code-point) 329 ((< code-point 256) 330 (make-char 'latin-iso8859-1 code-point)) 331 ((< code-point #x2500) 332 (setq code-point (- code-point #x0100)) 333 (make-char 'mule-unicode-0100-24ff 334 (+ (/ code-point 96) 32) (+ (% code-point 96) 32))) 335 ((< code-point #x3400) 336 (setq code-point (- code-point #x2500)) 337 (make-char 'mule-unicode-2500-33ff 338 (+ (/ code-point 96) 32) (+ (% code-point 96) 32))) 339 ((and (>= code-point #xe000) (< code-point #x10000)) 340 (setq code-point (- code-point #xe000)) 341 (make-char 'mule-unicode-e000-ffff 342 (+ (/ code-point 96) 32) 343 (+ (% code-point 96) 32)))))) 344 (when c 345 (or (aref (get 'utf-translation-table-for-decode 346 'translation-table) c) 347 c))))))) 348 349(defun encode-char (char ccs &optional restriction) 350 "Return code-point in coded character set CCS that corresponds to CHAR. 351Return nil if CHAR is not included in CCS. 352Currently the only supported coded character set is `ucs' (ISO/IEC 35310646: Universal Multi-Octet Coded Character Set), and CHAR is first 354translated through the translation-table named 355`utf-translation-table-for-encode', or through the 356translation-hash-table named `utf-subst-table-for-encode' \(if 357`utf-translate-cjk-mode' is non-nil). 358 359CHAR should be in one of these charsets: 360 ascii, latin-iso8859-1, mule-unicode-0100-24ff, mule-unicode-2500-33ff, 361 mule-unicode-e000-ffff, eight-bit-control 362Otherwise, return nil. 363 364Optional argument RESTRICTION specifies a way to map CHAR to a 365code-point in CCS. Currently not supported and just ignored." 366 (let* ((split (split-char char)) 367 (charset (car split)) 368 trans) 369 (cond ((eq ccs 'ucs) 370 (or (and utf-translate-cjk-mode 371 (utf-lookup-subst-table-for-encode char)) 372 (let ((table (get 'utf-translation-table-for-encode 373 'translation-table))) 374 (setq trans (aref table char)) 375 (if trans 376 (setq split (split-char trans) 377 charset (car split))) 378 (cond ((eq charset 'ascii) 379 (or trans char)) 380 ((eq charset 'latin-iso8859-1) 381 (+ (nth 1 split) 128)) 382 ((eq charset 'mule-unicode-0100-24ff) 383 (+ #x0100 (+ (* (- (nth 1 split) 32) 96) 384 (- (nth 2 split) 32)))) 385 ((eq charset 'mule-unicode-2500-33ff) 386 (+ #x2500 (+ (* (- (nth 1 split) 32) 96) 387 (- (nth 2 split) 32)))) 388 ((eq charset 'mule-unicode-e000-ffff) 389 (+ #xe000 (+ (* (- (nth 1 split) 32) 96) 390 (- (nth 2 split) 32)))) 391 ((eq charset 'eight-bit-control) 392 char)))))))) 393 394 395;; Save the ASCII case table in case we need it later. Some locales 396;; (such as Turkish) modify the case behavior of ASCII characters, 397;; which can interfere with networking code that uses ASCII strings. 398 399(defvar ascii-case-table 400 ;; Code copied from copy-case-table to avoid requiring case-table.el 401 (let ((tbl (copy-sequence (standard-case-table))) 402 (up (char-table-extra-slot (standard-case-table) 0))) 403 (if up (set-char-table-extra-slot tbl 0 (copy-sequence up))) 404 (set-char-table-extra-slot tbl 1 nil) 405 (set-char-table-extra-slot tbl 2 nil) 406 tbl) 407 "Case table for the ASCII character set.") 408 409;; Coding system stuff 410 411;; Coding system is a symbol that has the property `coding-system'. 412;; 413;; The value of the property `coding-system' is a vector of the 414;; following format: 415;; [TYPE MNEMONIC DOC-STRING PLIST FLAGS] 416;; We call this vector as coding-spec. See comments in src/coding.c 417;; for more detail. 418 419(defconst coding-spec-type-idx 0) 420(defconst coding-spec-mnemonic-idx 1) 421(defconst coding-spec-doc-string-idx 2) 422(defconst coding-spec-plist-idx 3) 423(defconst coding-spec-flags-idx 4) 424 425;; PLIST is a property list of a coding system. To share PLIST among 426;; alias coding systems, a coding system has PLIST in coding-spec 427;; instead of having it in normal property list of Lisp symbol. 428;; Here's a list of coding system properties currently being used. 429;; 430;; o coding-category 431;; 432;; The value is a coding category the coding system belongs to. The 433;; function `make-coding-system' sets this value automatically 434;; unless its argument PROPERTIES specifies this property. 435;; 436;; o alias-coding-systems 437;; 438;; The value is a list of coding systems of the same alias group. The 439;; first element is the coding system made at first, which we call as 440;; `base coding system'. The function `make-coding-system' sets this 441;; value automatically and `define-coding-system-alias' updates it. 442;; 443;; See the documentation of make-coding-system for the meanings of the 444;; following properties. 445;; 446;; o post-read-conversion 447;; o pre-write-conversion 448;; o translation-table-for-decode 449;; o translation-table-for-encode 450;; o safe-chars 451;; o safe-charsets 452;; o mime-charset 453;; o valid-codes (meaningful only for a coding system based on CCL) 454 455 456(defsubst coding-system-spec (coding-system) 457 "Return coding-spec of CODING-SYSTEM." 458 (get (check-coding-system coding-system) 'coding-system)) 459 460(defun coding-system-type (coding-system) 461 "Return the coding type of CODING-SYSTEM. 462A coding type is an integer value indicating the encoding method 463of CODING-SYSTEM. See the function `make-coding-system' for more detail." 464 (aref (coding-system-spec coding-system) coding-spec-type-idx)) 465 466(defun coding-system-mnemonic (coding-system) 467 "Return the mnemonic character of CODING-SYSTEM. 468The mnemonic character of a coding system is used in mode line 469to indicate the coding system. If the arg is nil, return ?-." 470 (let ((spec (coding-system-spec coding-system))) 471 (if spec (aref spec coding-spec-mnemonic-idx) ?-))) 472 473(defun coding-system-doc-string (coding-system) 474 "Return the documentation string for CODING-SYSTEM." 475 (aref (coding-system-spec coding-system) coding-spec-doc-string-idx)) 476 477(defun coding-system-plist (coding-system) 478 "Return the property list of CODING-SYSTEM." 479 (aref (coding-system-spec coding-system) coding-spec-plist-idx)) 480 481(defun coding-system-flags (coding-system) 482 "Return `flags' of CODING-SYSTEM. 483A `flags' of a coding system is a vector of length 32 indicating detailed 484information of a coding system. See the function `make-coding-system' 485for more detail." 486 (aref (coding-system-spec coding-system) coding-spec-flags-idx)) 487 488(defun coding-system-get (coding-system prop) 489 "Extract a value from CODING-SYSTEM's property list for property PROP." 490 (plist-get (coding-system-plist coding-system) prop)) 491 492(defun coding-system-put (coding-system prop val) 493 "Change value in CODING-SYSTEM's property list PROP to VAL." 494 (let ((plist (coding-system-plist coding-system))) 495 (if plist 496 (plist-put plist prop val) 497 (aset (coding-system-spec coding-system) coding-spec-plist-idx 498 (list prop val))))) 499 500(defun coding-system-category (coding-system) 501 "Return the coding category of CODING-SYSTEM. 502See also `coding-category-list'." 503 (coding-system-get coding-system 'coding-category)) 504 505(defun coding-system-base (coding-system) 506 "Return the base coding system of CODING-SYSTEM. 507A base coding system is what made by `make-coding-system'. 508Any alias nor subsidiary coding systems are not base coding system." 509 (car (coding-system-get coding-system 'alias-coding-systems))) 510 511;; Coding system also has a property `eol-type'. 512;; 513;; This property indicates how the coding system handles end-of-line 514;; format. The value is integer 0, 1, 2, or a vector of three coding 515;; systems. Each integer value 0, 1, and 2 indicates the format of 516;; end-of-line LF, CRLF, and CR respectively. A vector value 517;; indicates that the format of end-of-line should be detected 518;; automatically. Nth element of the vector is the subsidiary coding 519;; system whose `eol-type' property is N. 520 521(defun coding-system-eol-type (coding-system) 522 "Return eol-type of CODING-SYSTEM. 523An eol-type is integer 0, 1, 2, or a vector of coding systems. 524 525Integer values 0, 1, and 2 indicate a format of end-of-line; LF, 526CRLF, and CR respectively. 527 528A vector value indicates that a format of end-of-line should be 529detected automatically. Nth element of the vector is the subsidiary 530coding system whose eol-type is N." 531 (get coding-system 'eol-type)) 532 533(defun coding-system-eol-type-mnemonic (coding-system) 534 "Return the string indicating end-of-line format of CODING-SYSTEM." 535 (let* ((eol-type (coding-system-eol-type coding-system)) 536 (val (cond ((eq eol-type 0) eol-mnemonic-unix) 537 ((eq eol-type 1) eol-mnemonic-dos) 538 ((eq eol-type 2) eol-mnemonic-mac) 539 (t eol-mnemonic-undecided)))) 540 (if (stringp val) 541 val 542 (char-to-string val)))) 543 544(defun coding-system-lessp (x y) 545 (cond ((eq x 'no-conversion) t) 546 ((eq y 'no-conversion) nil) 547 ((eq x 'emacs-mule) t) 548 ((eq y 'emacs-mule) nil) 549 ((eq x 'undecided) t) 550 ((eq y 'undecided) nil) 551 (t (let ((c1 (coding-system-mnemonic x)) 552 (c2 (coding-system-mnemonic y))) 553 (or (< (downcase c1) (downcase c2)) 554 (and (not (> (downcase c1) (downcase c2))) 555 (< c1 c2))))))) 556 557(defun coding-system-equal (coding-system-1 coding-system-2) 558 "Return t if and only if CODING-SYSTEM-1 and CODING-SYSTEM-2 are identical. 559Two coding systems are identical if two symbols are equal 560or one is an alias of the other." 561 (or (eq coding-system-1 coding-system-2) 562 (and (equal (coding-system-spec coding-system-1) 563 (coding-system-spec coding-system-2)) 564 (let ((eol-type-1 (coding-system-eol-type coding-system-1)) 565 (eol-type-2 (coding-system-eol-type coding-system-2))) 566 (or (eq eol-type-1 eol-type-2) 567 (and (vectorp eol-type-1) (vectorp eol-type-2))))))) 568 569(defun add-to-coding-system-list (coding-system) 570 "Add CODING-SYSTEM to `coding-system-list' while keeping it sorted." 571 (if (or (null coding-system-list) 572 (coding-system-lessp coding-system (car coding-system-list))) 573 (setq coding-system-list (cons coding-system coding-system-list)) 574 (let ((len (length coding-system-list)) 575 mid (tem coding-system-list)) 576 (while (> len 1) 577 (setq mid (nthcdr (/ len 2) tem)) 578 (if (coding-system-lessp (car mid) coding-system) 579 (setq tem mid 580 len (- len (/ len 2))) 581 (setq len (/ len 2)))) 582 (setcdr tem (cons coding-system (cdr tem)))))) 583 584(defun coding-system-list (&optional base-only) 585 "Return a list of all existing non-subsidiary coding systems. 586If optional arg BASE-ONLY is non-nil, only base coding systems are listed. 587The value doesn't include subsidiary coding systems which are what 588made from bases and aliases automatically for various end-of-line 589formats (e.g. iso-latin-1-unix, koi8-r-dos)." 590 (let* ((codings (copy-sequence coding-system-list)) 591 (tail (cons nil codings))) 592 ;; Remove subsidiary coding systems (eol variants) and alias 593 ;; coding systems (if necessary). 594 (while (cdr tail) 595 (let* ((coding (car (cdr tail))) 596 (aliases (coding-system-get coding 'alias-coding-systems))) 597 (if (or 598 ;; CODING is an eol variant if not in ALIASES. 599 (not (memq coding aliases)) 600 ;; CODING is an alias if it is not car of ALIASES. 601 (and base-only (not (eq coding (car aliases))))) 602 (setcdr tail (cdr (cdr tail))) 603 (setq tail (cdr tail))))) 604 codings)) 605 606(defun map-charset-chars (func charset) 607 "Use FUNC to map over all characters in CHARSET for side effects. 608FUNC is a function of two args, the start and end (inclusive) of a 609character code range. Thus FUNC should iterate over [START, END]." 610 (let* ((dim (charset-dimension charset)) 611 (chars (charset-chars charset)) 612 (start (if (= chars 94) 613 33 614 32))) 615 (if (= dim 1) 616 (funcall func 617 (make-char charset start) 618 (make-char charset (+ start chars -1))) 619 (dotimes (i chars) 620 (funcall func 621 (make-char charset (+ i start) start) 622 (make-char charset (+ i start) (+ start chars -1))))))) 623 624(defalias 'register-char-codings 'ignore "") 625(make-obsolete 'register-char-codings 626 "it exists just for backward compatibility, and does nothing." 627 "21.3") 628 629(defconst char-coding-system-table nil 630 "This is an obsolete variable. 631It exists just for backward compatibility, and the value is always nil.") 632 633(defun make-subsidiary-coding-system (coding-system) 634 "Make subsidiary coding systems (eol-type variants) of CODING-SYSTEM." 635 (let ((coding-spec (coding-system-spec coding-system)) 636 (subsidiaries (vector (intern (format "%s-unix" coding-system)) 637 (intern (format "%s-dos" coding-system)) 638 (intern (format "%s-mac" coding-system)))) 639 elt) 640 (dotimes (i 3) 641 (setq elt (aref subsidiaries i)) 642 (put elt 'coding-system coding-spec) 643 (put elt 'eol-type i) 644 (put elt 'coding-system-define-form nil) 645 (add-to-coding-system-list elt) 646 (or (assoc (symbol-name elt) coding-system-alist) 647 (setq coding-system-alist 648 (cons (list (symbol-name elt)) coding-system-alist)))) 649 subsidiaries)) 650 651(defun transform-make-coding-system-args (name type &optional doc-string props) 652 "For internal use only. 653Transform XEmacs style args for `make-coding-system' to Emacs style. 654Value is a list of transformed arguments." 655 (let ((mnemonic (string-to-char (or (plist-get props 'mnemonic) "?"))) 656 (eol-type (plist-get props 'eol-type)) 657 properties tmp) 658 (cond 659 ((eq eol-type 'lf) (setq eol-type 'unix)) 660 ((eq eol-type 'crlf) (setq eol-type 'dos)) 661 ((eq eol-type 'cr) (setq eol-type 'mac))) 662 (if (setq tmp (plist-get props 'post-read-conversion)) 663 (setq properties (plist-put properties 'post-read-conversion tmp))) 664 (if (setq tmp (plist-get props 'pre-write-conversion)) 665 (setq properties (plist-put properties 'pre-write-conversion tmp))) 666 (cond 667 ((eq type 'shift-jis) 668 `(,name 1 ,mnemonic ,doc-string () ,properties ,eol-type)) 669 ((eq type 'iso2022) ; This is not perfect. 670 (if (plist-get props 'escape-quoted) 671 (error "escape-quoted is not supported: %S" 672 `(,name ,type ,doc-string ,props))) 673 (let ((g0 (plist-get props 'charset-g0)) 674 (g1 (plist-get props 'charset-g1)) 675 (g2 (plist-get props 'charset-g2)) 676 (g3 (plist-get props 'charset-g3)) 677 (use-roman 678 (and 679 (eq (cadr (assoc 'latin-jisx0201 680 (plist-get props 'input-charset-conversion))) 681 'ascii) 682 (eq (cadr (assoc 'ascii 683 (plist-get props 'output-charset-conversion))) 684 'latin-jisx0201))) 685 (use-oldjis 686 (and 687 (eq (cadr (assoc 'japanese-jisx0208-1978 688 (plist-get props 'input-charset-conversion))) 689 'japanese-jisx0208) 690 (eq (cadr (assoc 'japanese-jisx0208 691 (plist-get props 'output-charset-conversion))) 692 'japanese-jisx0208-1978)))) 693 (if (charsetp g0) 694 (if (plist-get props 'force-g0-on-output) 695 (setq g0 `(nil ,g0)) 696 (setq g0 `(,g0 t)))) 697 (if (charsetp g1) 698 (if (plist-get props 'force-g1-on-output) 699 (setq g1 `(nil ,g1)) 700 (setq g1 `(,g1 t)))) 701 (if (charsetp g2) 702 (if (plist-get props 'force-g2-on-output) 703 (setq g2 `(nil ,g2)) 704 (setq g2 `(,g2 t)))) 705 (if (charsetp g3) 706 (if (plist-get props 'force-g3-on-output) 707 (setq g3 `(nil ,g3)) 708 (setq g3 `(,g3 t)))) 709 `(,name 2 ,mnemonic ,doc-string 710 (,g0 ,g1 ,g2 ,g3 711 ,(plist-get props 'short) 712 ,(not (plist-get props 'no-ascii-eol)) 713 ,(not (plist-get props 'no-ascii-cntl)) 714 ,(plist-get props 'seven) 715 t 716 ,(not (plist-get props 'lock-shift)) 717 ,use-roman 718 ,use-oldjis 719 ,(plist-get props 'no-iso6429) 720 nil nil nil nil) 721 ,properties ,eol-type))) 722 ((eq type 'big5) 723 `(,name 3 ,mnemonic ,doc-string () ,properties ,eol-type)) 724 ((eq type 'ccl) 725 `(,name 4 ,mnemonic ,doc-string 726 (,(plist-get props 'decode) . ,(plist-get props 'encode)) 727 ,properties ,eol-type)) 728 (t 729 (error "unsupported XEmacs style make-coding-style arguments: %S" 730 `(,name ,type ,doc-string ,props)))))) 731 732(defun make-coding-system (coding-system type mnemonic doc-string 733 &optional 734 flags 735 properties 736 eol-type) 737 "Define a new coding system CODING-SYSTEM (symbol). 738Remaining arguments are TYPE, MNEMONIC, DOC-STRING, FLAGS (optional), 739and PROPERTIES (optional) which construct a coding-spec of CODING-SYSTEM 740in the following format: 741 [TYPE MNEMONIC DOC-STRING PLIST FLAGS] 742 743TYPE is an integer value indicating the type of the coding system as follows: 744 0: Emacs internal format, 745 1: Shift-JIS (or MS-Kanji) used mainly on Japanese PCs, 746 2: ISO-2022 including many variants, 747 3: Big5 used mainly on Chinese PCs, 748 4: private, CCL programs provide encoding/decoding algorithm, 749 5: Raw-text, which means that text contains random 8-bit codes. 750 751MNEMONIC is a character to be displayed on mode line for the coding system. 752 753DOC-STRING is a documentation string for the coding system. 754 755FLAGS specifies more detailed information of the coding system as follows: 756 757 If TYPE is 2 (ISO-2022), FLAGS is a list of these elements: 758 CHARSET0, CHARSET1, CHARSET2, CHARSET3, SHORT-FORM, 759 ASCII-EOL, ASCII-CNTL, SEVEN, LOCKING-SHIFT, SINGLE-SHIFT, 760 USE-ROMAN, USE-OLDJIS, NO-ISO6429, INIT-BOL, DESIGNATION-BOL, 761 SAFE, ACCEPT-LATIN-EXTRA-CODE. 762 CHARSETn are character sets initially designated to Gn graphic registers. 763 If CHARSETn is nil, Gn is never used. 764 If CHARSETn is t, Gn can be used but nothing designated initially. 765 If CHARSETn is a list of character sets, those character sets are 766 designated to Gn on output, but nothing designated to Gn initially. 767 But, character set `ascii' can be designated only to G0. 768 SHORT-FORM non-nil means use short designation sequence on output. 769 ASCII-EOL non-nil means designate ASCII to g0 at end of line on output. 770 ASCII-CNTL non-nil means designate ASCII to g0 before control codes and 771 SPACE on output. 772 SEVEN non-nil means use 7-bit code only on output. 773 LOCKING-SHIFT non-nil means use locking-shift. 774 SINGLE-SHIFT non-nil means use single-shift. 775 USE-ROMAN non-nil means designate JIS0201-1976-Roman instead of ASCII. 776 USE-OLDJIS non-nil means designate JIS0208-1976 instead of JIS0208-1983. 777 NO-ISO6429 non-nil means not use ISO6429's direction specification. 778 INIT-BOL non-nil means any designation state is assumed to be reset 779 to initial at each beginning of line on output. 780 DESIGNATION-BOL non-nil means designation sequences should be placed 781 at beginning of line on output. 782 SAFE non-nil means convert unsafe characters to `?' on output. 783 Characters not specified in the property `safe-charsets' nor 784 `safe-chars' are unsafe. 785 ACCEPT-LATIN-EXTRA-CODE non-nil means code-detection routine accepts 786 a code specified in `latin-extra-code-table' (which see) as a valid 787 code of the coding system. 788 789 If TYPE is 4 (private), FLAGS should be a cons of CCL programs, for 790 decoding and encoding. CCL programs should be specified by their 791 symbols. 792 793PROPERTIES is an alist of properties vs the corresponding values. The 794following properties are recognized: 795 796 o post-read-conversion 797 798 The value is a function to call after some text is inserted and 799 decoded by the coding system itself and before any functions in 800 `after-insert-functions' are called. The argument of this 801 function is the same as for a function in 802 `after-insert-file-functions', i.e. LENGTH of the text inserted, 803 with point at the head of the text to be decoded. 804 805 o pre-write-conversion 806 807 The value is a function to call after all functions in 808 `write-region-annotate-functions' and `buffer-file-format' are 809 called, and before the text is encoded by the coding system itself. 810 The arguments to this function are the same as those of a function 811 in `write-region-annotate-functions', i.e. FROM and TO, specifying 812 a region of text. 813 814 o translation-table-for-decode 815 816 The value is a translation table to be applied on decoding. See 817 the function `make-translation-table' for the format of translation 818 table. This is not applicable to type 4 (CCL-based) coding systems. 819 820 o translation-table-for-encode 821 822 The value is a translation table to be applied on encoding. This is 823 not applicable to type 4 (CCL-based) coding systems. 824 825 o safe-chars 826 827 The value is a char table. If a character has non-nil value in it, 828 the character is safely supported by the coding system. This 829 overrides the specification of safe-charsets. 830 831 o safe-charsets 832 833 The value is a list of charsets safely supported by the coding 834 system. The value t means that all charsets Emacs handles are 835 supported. Even if some charset is not in this list, it doesn't 836 mean that the charset can't be encoded in the coding system; 837 it just means that some other receiver of text encoded 838 in the coding system won't be able to handle that charset. 839 840 o mime-charset 841 842 The value is a symbol whose name is the `MIME-charset' parameter of 843 the coding system. 844 845 o mime-text-unsuitable 846 847 A non-nil value means the `mime-charset' property names a charset 848 which is unsuitable for the top-level media type \"text\". 849 850 o valid-codes (meaningful only for a coding system based on CCL) 851 852 The value is a list to indicate valid byte ranges of the encoded 853 file. Each element of the list is an integer or a cons of integer. 854 In the former case, the integer value is a valid byte code. In the 855 latter case, the integers specify the range of valid byte codes. 856 857 o composition (meaningful only when TYPE is 0 or 2) 858 859 If the value is non-nil, the coding system preserves composition 860 information. 861 862 o ascii-incompatible 863 864 If the value is non-nil, the coding system is not compatible 865 with ASCII, which means it encodes or decodes ASCII character 866 string to the different byte sequence. 867 868These properties are set in PLIST, a property list. This function 869also sets properties `coding-category' and `alias-coding-systems' 870automatically. 871 872EOL-TYPE specifies the EOL type of the coding-system in one of the 873following formats: 874 875 o symbol (unix, dos, or mac) 876 877 The symbol `unix' means Unix-like EOL (LF), `dos' means 878 DOS-like EOL (CRLF), and `mac' means MAC-like EOL (CR). 879 880 o number (0, 1, or 2) 881 882 The number 0, 1, and 2 mean UNIX, DOS, and MAC-like EOL 883 respectively. 884 885 o vector of coding-systems of length 3 886 887 The EOL type is detected automatically for the coding system. 888 And, according to the detected EOL type, one of the coding 889 systems in the vector is selected. Elements of the vector 890 corresponds to Unix-like EOL, DOS-like EOL, and Mac-like EOL 891 in this order. 892 893Kludgy features for backward compatibility: 894 8951. If TYPE is 4 and car or cdr of FLAGS is a vector, the vector is 896treated as a compiled CCL code. 897 8982. If PROPERTIES is just a list of character sets, the list is set as 899a value of `safe-charsets' in PLIST." 900 901 ;; For compatiblity with XEmacs, we check the type of TYPE. If it 902 ;; is a symbol, perhaps, this function is called with XEmacs-style 903 ;; arguments. Here, try to transform that kind of arguments to 904 ;; Emacs style. 905 (if (symbolp type) 906 (let ((args (transform-make-coding-system-args coding-system type 907 mnemonic doc-string))) 908 (setq coding-system (car args) 909 type (nth 1 args) 910 mnemonic (nth 2 args) 911 doc-string (nth 3 args) 912 flags (nth 4 args) 913 properties (nth 5 args) 914 eol-type (nth 6 args)))) 915 916 ;; Set a value of `coding-system' property. 917 (let ((coding-spec (make-vector 5 nil)) 918 (no-initial-designation t) 919 (no-alternative-designation t) 920 (accept-latin-extra-code nil) 921 coding-category) 922 (if (or (not (integerp type)) (< type 0) (> type 5)) 923 (error "TYPE argument must be 0..5")) 924 (if (or (not (integerp mnemonic)) (<= mnemonic ? ) (> mnemonic 127)) 925 (error "MNEMONIC argument must be an ASCII printable character")) 926 (aset coding-spec coding-spec-type-idx type) 927 (aset coding-spec coding-spec-mnemonic-idx mnemonic) 928 (aset coding-spec coding-spec-doc-string-idx 929 (purecopy (if (stringp doc-string) doc-string ""))) 930 (cond ((= type 0) 931 (setq coding-category 'coding-category-emacs-mule)) 932 ((= type 1) 933 (setq coding-category 'coding-category-sjis)) 934 ((= type 2) ; ISO2022 935 (let ((i 0) 936 (vec (make-vector 32 nil)) 937 (g1-designation nil) 938 (fl flags)) 939 (while (< i 4) 940 (let ((charset (car fl))) 941 (if (and no-initial-designation 942 (> i 0) 943 (or (charsetp charset) 944 (and (consp charset) 945 (charsetp (car charset))))) 946 (setq no-initial-designation nil)) 947 (if (charsetp charset) 948 (if (= i 1) (setq g1-designation charset)) 949 (if (consp charset) 950 (let ((tail charset) 951 elt) 952 (while tail 953 (setq elt (car tail)) 954 (if (eq elt t) 955 (setq no-alternative-designation nil) 956 (if (and elt (not (charsetp elt))) 957 (error "Invalid charset: %s" elt))) 958 (setq tail (cdr tail))) 959 (setq g1-designation (car charset))) 960 (if charset 961 (if (eq charset t) 962 (setq no-alternative-designation nil) 963 (error "Invalid charset: %s" charset))))) 964 (aset vec i charset)) 965 (setq fl (cdr fl) i (1+ i))) 966 (while (and (< i 32) fl) 967 (aset vec i (car fl)) 968 (if (and (= i 16) ; ACCEPT-LATIN-EXTRA-CODE 969 (car fl)) 970 (setq accept-latin-extra-code t)) 971 (setq fl (cdr fl) i (1+ i))) 972 (aset coding-spec 4 vec) 973 (setq coding-category 974 (if (aref vec 8) ; Use locking-shift. 975 (or (and (aref vec 7) 'coding-category-iso-7-else) 976 'coding-category-iso-8-else) 977 (if (aref vec 7) ; 7-bit only. 978 (if (aref vec 9) ; Use single-shift. 979 'coding-category-iso-7-else 980 (if no-alternative-designation 981 'coding-category-iso-7-tight 982 'coding-category-iso-7)) 983 (if (or no-initial-designation 984 (not no-alternative-designation)) 985 'coding-category-iso-8-else 986 (if (and (charsetp g1-designation) 987 (= (charset-dimension g1-designation) 2)) 988 'coding-category-iso-8-2 989 'coding-category-iso-8-1))))))) 990 ((= type 3) 991 (setq coding-category 'coding-category-big5)) 992 ((= type 4) ; private 993 (setq coding-category 'coding-category-ccl) 994 (if (not (consp flags)) 995 (error "Invalid FLAGS argument for TYPE 4 (CCL)") 996 (let ((decoder (check-ccl-program 997 (car flags) 998 (intern (format "%s-decoder" coding-system)))) 999 (encoder (check-ccl-program 1000 (cdr flags) 1001 (intern (format "%s-encoder" coding-system))))) 1002 (if (and decoder encoder) 1003 (aset coding-spec 4 (cons decoder encoder)) 1004 (error "Invalid FLAGS argument for TYPE 4 (CCL)"))))) 1005 (t ; i.e. (= type 5) 1006 (setq coding-category 'coding-category-raw-text))) 1007 1008 (let ((plist (list 'coding-category coding-category 1009 'alias-coding-systems (list coding-system)))) 1010 (if no-initial-designation 1011 (plist-put plist 'no-initial-designation t)) 1012 (if (and properties 1013 (or (eq properties t) 1014 (not (consp (car properties))))) 1015 ;; In the old version, the arg PROPERTIES is a list to be 1016 ;; set in PLIST as a value of property `safe-charsets'. 1017 (setq properties (list (cons 'safe-charsets properties)))) 1018 ;; In the current version PROPERTIES is a property list. 1019 ;; Reflect it into PLIST one by one while handling safe-chars 1020 ;; specially. 1021 (let ((safe-charsets (cdr (assq 'safe-charsets properties))) 1022 (safe-chars (cdr (assq 'safe-chars properties))) 1023 (l properties) 1024 prop val) 1025 ;; If only safe-charsets is specified, make a char-table from 1026 ;; it, and store that char-table as the value of `safe-chars'. 1027 (if (and (not safe-chars) safe-charsets) 1028 (let (charset) 1029 (if (eq safe-charsets t) 1030 (setq safe-chars t) 1031 (setq safe-chars (make-char-table 'safe-chars)) 1032 (while safe-charsets 1033 (setq charset (car safe-charsets) 1034 safe-charsets (cdr safe-charsets)) 1035 (cond ((eq charset 'ascii)) ; just ignore 1036 ((eq charset 'eight-bit-control) 1037 (let ((i 128)) 1038 (while (< i 160) 1039 (aset safe-chars i t) 1040 (setq i (1+ i))))) 1041 ((eq charset 'eight-bit-graphic) 1042 (let ((i 160)) 1043 (while (< i 256) 1044 (aset safe-chars i t) 1045 (setq i (1+ i))))) 1046 (t 1047 (aset safe-chars (make-char charset) t)))) 1048 (if accept-latin-extra-code 1049 (let ((i 128)) 1050 (while (< i 160) 1051 (if (aref latin-extra-code-table i) 1052 (aset safe-chars i t)) 1053 (setq i (1+ i)))))) 1054 (setq l (cons (cons 'safe-chars safe-chars) l)))) 1055 (while l 1056 (setq prop (car (car l)) val (cdr (car l)) l (cdr l)) 1057 (if (eq prop 'safe-chars) 1058 (progn 1059 (if (and (symbolp val) 1060 (get val 'translation-table)) 1061 (setq safe-chars (get val 'translation-table))) 1062 (setq val safe-chars))) 1063 (plist-put plist prop val))) 1064 ;; The property `coding-category' may have been set differently 1065 ;; through PROPERTIES. 1066 (setq coding-category (plist-get plist 'coding-category)) 1067 (aset coding-spec coding-spec-plist-idx plist)) 1068 (put coding-system 'coding-system coding-spec) 1069 (put coding-system 'coding-system-define-form nil) 1070 (put coding-category 'coding-systems 1071 (cons coding-system (get coding-category 'coding-systems)))) 1072 1073 ;; Next, set a value of `eol-type' property. 1074 (if (not eol-type) 1075 ;; If EOL-TYPE is nil, set a vector of subsidiary coding 1076 ;; systems, each corresponds to a coding system for the detected 1077 ;; EOL format. 1078 (setq eol-type (make-subsidiary-coding-system coding-system))) 1079 (setq eol-type 1080 (cond ((or (eq eol-type 'unix) (null eol-type)) 1081 0) 1082 ((eq eol-type 'dos) 1083 1) 1084 ((eq eol-type 'mac) 1085 2) 1086 ((or (and (vectorp eol-type) 1087 (= (length eol-type) 3)) 1088 (and (numberp eol-type) 1089 (and (>= eol-type 0) 1090 (<= eol-type 2)))) 1091 eol-type) 1092 (t 1093 (error "Invalid EOL-TYPE spec:%S" eol-type)))) 1094 (put coding-system 'eol-type eol-type) 1095 1096 (define-coding-system-internal coding-system) 1097 1098 ;; At last, register CODING-SYSTEM in `coding-system-list' and 1099 ;; `coding-system-alist'. 1100 (add-to-coding-system-list coding-system) 1101 (or (assoc (symbol-name coding-system) coding-system-alist) 1102 (setq coding-system-alist (cons (list (symbol-name coding-system)) 1103 coding-system-alist))) 1104 1105 ;; For a coding system of cateogory iso-8-1 and iso-8-2, create 1106 ;; XXX-with-esc variants. 1107 (let ((coding-category (coding-system-category coding-system))) 1108 (if (or (eq coding-category 'coding-category-iso-8-1) 1109 (eq coding-category 'coding-category-iso-8-2)) 1110 (let ((esc (intern (concat (symbol-name coding-system) "-with-esc"))) 1111 (doc (format "Same as %s but can handle any charsets by ISO's escape sequences." coding-system)) 1112 (safe-charsets (assq 'safe-charsets properties)) 1113 (mime-charset (assq 'mime-charset properties))) 1114 (if safe-charsets 1115 (setcdr safe-charsets t) 1116 (setq properties (cons (cons 'safe-charsets t) properties))) 1117 (if mime-charset 1118 (setcdr mime-charset nil)) 1119 (make-coding-system esc type mnemonic doc 1120 (if (listp (car flags)) 1121 (cons (append (car flags) '(t)) (cdr flags)) 1122 (cons (list (car flags) t) (cdr flags))) 1123 properties)))) 1124 1125 coding-system) 1126 1127(put 'safe-chars 'char-table-extra-slots 0) 1128 1129(defun define-coding-system-alias (alias coding-system) 1130 "Define ALIAS as an alias for coding system CODING-SYSTEM." 1131 (put alias 'coding-system (coding-system-spec coding-system)) 1132 (put alias 'coding-system-define-form nil) 1133 (add-to-coding-system-list alias) 1134 (or (assoc (symbol-name alias) coding-system-alist) 1135 (setq coding-system-alist (cons (list (symbol-name alias)) 1136 coding-system-alist))) 1137 (let ((eol-type (coding-system-eol-type coding-system))) 1138 (if (vectorp eol-type) 1139 (progn 1140 (nconc (coding-system-get alias 'alias-coding-systems) (list alias)) 1141 (put alias 'eol-type (make-subsidiary-coding-system alias))) 1142 (put alias 'eol-type eol-type)))) 1143 1144(defun merge-coding-systems (first second) 1145 "Fill in any unspecified aspects of coding system FIRST from SECOND. 1146Return the resulting coding system." 1147 (let ((base (coding-system-base second)) 1148 (eol (coding-system-eol-type second))) 1149 ;; If FIRST doesn't specify text conversion, merge with that of SECOND. 1150 (if (eq (coding-system-base first) 'undecided) 1151 (setq first (coding-system-change-text-conversion first base))) 1152 ;; If FIRST doesn't specify eol conversion, merge with that of SECOND. 1153 (if (and (vectorp (coding-system-eol-type first)) 1154 (numberp eol) (>= eol 0) (<= eol 2)) 1155 (setq first (coding-system-change-eol-conversion 1156 first eol))) 1157 first)) 1158 1159(defun autoload-coding-system (symbol form) 1160 "Define SYMBOL as a coding-system that is defined on demand. 1161 1162FROM is a form to evaluate to define the coding-system." 1163 (put symbol 'coding-system-define-form form) 1164 (setq coding-system-alist (cons (list (symbol-name symbol)) 1165 coding-system-alist)) 1166 (dolist (elt '("-unix" "-dos" "-mac")) 1167 (let ((name (concat (symbol-name symbol) elt))) 1168 (put (intern name) 'coding-system-define-form form) 1169 (setq coding-system-alist (cons (list name) coding-system-alist))))) 1170 1171(defun set-buffer-file-coding-system (coding-system &optional force nomodify) 1172 "Set the file coding-system of the current buffer to CODING-SYSTEM. 1173This means that when you save the buffer, it will be converted 1174according to CODING-SYSTEM. For a list of possible values of CODING-SYSTEM, 1175use \\[list-coding-systems]. 1176 1177If CODING-SYSTEM leaves the text conversion unspecified, or if it 1178leaves the end-of-line conversion unspecified, FORCE controls what to 1179do. If FORCE is nil, get the unspecified aspect (or aspects) from the 1180buffer's previous `buffer-file-coding-system' value (if it is 1181specified there). Otherwise, leave it unspecified. 1182 1183This marks the buffer modified so that the succeeding \\[save-buffer] 1184surely saves the buffer with CODING-SYSTEM. From a program, if you 1185don't want to mark the buffer modified, specify t for NOMODIFY. 1186If you know exactly what coding system you want to use, 1187just set the variable `buffer-file-coding-system' directly." 1188 (interactive "zCoding system for saving file (default nil): \nP") 1189 (check-coding-system coding-system) 1190 (if (and coding-system buffer-file-coding-system (null force)) 1191 (setq coding-system 1192 (merge-coding-systems coding-system buffer-file-coding-system))) 1193 (setq buffer-file-coding-system coding-system) 1194 ;; This is in case of an explicit call. Normally, `normal-mode' and 1195 ;; `set-buffer-major-mode-hook' take care of setting the table. 1196 (if (fboundp 'ucs-set-table-for-input) ; don't lose when building 1197 (ucs-set-table-for-input)) 1198 (unless nomodify 1199 (set-buffer-modified-p t)) 1200 (force-mode-line-update)) 1201 1202(defun revert-buffer-with-coding-system (coding-system &optional force) 1203 "Visit the current buffer's file again using coding system CODING-SYSTEM. 1204For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems]. 1205 1206If CODING-SYSTEM leaves the text conversion unspecified, or if it 1207leaves the end-of-line conversion unspecified, FORCE controls what to 1208do. If FORCE is nil, get the unspecified aspect (or aspects) from the 1209buffer's previous `buffer-file-coding-system' value (if it is 1210specified there). Otherwise, determine it from the file contents as 1211usual for visiting a file." 1212 (interactive "zCoding system for visited file (default nil): \nP") 1213 (check-coding-system coding-system) 1214 (if (and coding-system buffer-file-coding-system (null force)) 1215 (setq coding-system 1216 (merge-coding-systems coding-system buffer-file-coding-system))) 1217 (let ((coding-system-for-read coding-system)) 1218 (revert-buffer))) 1219 1220(defun set-file-name-coding-system (coding-system) 1221 "Set coding system for decoding and encoding file names to CODING-SYSTEM. 1222It actually just set the variable `file-name-coding-system' (which 1223see) to CODING-SYSTEM." 1224 (interactive "zCoding system for file names (default nil): ") 1225 (check-coding-system coding-system) 1226 (if (and coding-system 1227 (coding-system-get coding-system 'ascii-incompatible)) 1228 (error "%s is not ASCII-compatible" coding-system)) 1229 (setq file-name-coding-system coding-system)) 1230 1231(defvar default-terminal-coding-system nil 1232 "Default value for the terminal coding system. 1233This is normally set according to the selected language environment. 1234See also the command `set-terminal-coding-system'.") 1235 1236(defun set-terminal-coding-system (coding-system) 1237 "Set coding system of your terminal to CODING-SYSTEM. 1238All text output to the terminal will be encoded 1239with the specified coding system. 1240For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems]. 1241The default is determined by the selected language environment 1242or by the previous use of this command." 1243 (interactive 1244 (list (let ((default (if (and (not (terminal-coding-system)) 1245 default-terminal-coding-system) 1246 default-terminal-coding-system))) 1247 (read-coding-system 1248 (format "Coding system for terminal display (default %s): " 1249 default) 1250 default)))) 1251 (if (and (not coding-system) 1252 (not (terminal-coding-system))) 1253 (setq coding-system default-terminal-coding-system)) 1254 (if coding-system 1255 (setq default-terminal-coding-system coding-system)) 1256 (set-terminal-coding-system-internal coding-system) 1257 (redraw-frame (selected-frame))) 1258 1259(defvar default-keyboard-coding-system nil 1260 "Default value of the keyboard coding system. 1261This is normally set according to the selected language environment. 1262See also the command `set-keyboard-coding-system'.") 1263 1264(defun set-keyboard-coding-system (coding-system) 1265 "Set coding system for keyboard input to CODING-SYSTEM. 1266In addition, this command enables Encoded-kbd minor mode. 1267\(If CODING-SYSTEM is nil, Encoded-kbd mode is turned off -- see 1268`encoded-kbd-mode'.) 1269For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems]. 1270The default is determined by the selected language environment 1271or by the previous use of this command." 1272 (interactive 1273 (list (let ((default (if (and (not (keyboard-coding-system)) 1274 default-keyboard-coding-system) 1275 default-keyboard-coding-system))) 1276 (read-coding-system 1277 (format "Coding system for keyboard input (default %s): " 1278 default) 1279 default)))) 1280 (if (and (not coding-system) 1281 (not (keyboard-coding-system))) 1282 (setq coding-system default-keyboard-coding-system)) 1283 (if coding-system 1284 (setq default-keyboard-coding-system coding-system)) 1285 (if (and coding-system 1286 (coding-system-get coding-system 'ascii-incompatible)) 1287 (error "%s is not ASCII-compatible" coding-system)) 1288 (set-keyboard-coding-system-internal coding-system) 1289 (setq keyboard-coding-system coding-system) 1290 (encoded-kbd-mode (if coding-system 1 0))) 1291 1292(defcustom keyboard-coding-system nil 1293 "Specify coding system for keyboard input. 1294If you set this on a terminal which can't distinguish Meta keys from 12958-bit characters, you will have to use ESC to type Meta characters. 1296See Info node `Terminal Coding' and Info node `Unibyte Mode'. 1297 1298On non-windowing terminals, this is set from the locale by default. 1299 1300Setting this variable directly does not take effect; 1301use either \\[customize] or \\[set-keyboard-coding-system]." 1302 :type '(coding-system :tag "Coding system") 1303 :link '(info-link "(emacs)Terminal Coding") 1304 :link '(info-link "(emacs)Unibyte Mode") 1305 :set (lambda (symbol value) 1306 ;; Don't load encoded-kbd-mode unnecessarily. 1307 (if (or value (boundp 'encoded-kbd-mode)) 1308 (set-keyboard-coding-system value) 1309 (set-default 'keyboard-coding-system nil))) ; must initialize 1310 :version "22.1" 1311 :group 'keyboard 1312 :group 'mule) 1313 1314(defun set-buffer-process-coding-system (decoding encoding) 1315 "Set coding systems for the process associated with the current buffer. 1316DECODING is the coding system to be used to decode input from the process, 1317ENCODING is the coding system to be used to encode output to the process. 1318 1319For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems]." 1320 (interactive 1321 "zCoding-system for output from the process: \nzCoding-system for input to the process: ") 1322 (let ((proc (get-buffer-process (current-buffer)))) 1323 (if (null proc) 1324 (error "No process") 1325 (check-coding-system decoding) 1326 (check-coding-system encoding) 1327 (set-process-coding-system proc decoding encoding))) 1328 (force-mode-line-update)) 1329 1330(defalias 'set-clipboard-coding-system 'set-selection-coding-system) 1331 1332(defun set-selection-coding-system (coding-system) 1333 "Make CODING-SYSTEM used for communicating with other X clients. 1334When sending or receiving text via cut_buffer, selection, and clipboard, 1335the text is encoded or decoded by CODING-SYSTEM." 1336 (interactive "zCoding system for X selection: ") 1337 (check-coding-system coding-system) 1338 (setq selection-coding-system coding-system)) 1339 1340;; Coding system lastly specified by the command 1341;; set-next-selection-coding-system. 1342(defvar last-next-selection-coding-system nil) 1343 1344(defun set-next-selection-coding-system (coding-system) 1345 "Make CODING-SYSTEM used for the next communication with other X clients. 1346This setting is effective for the next communication only." 1347 (interactive 1348 (list (read-coding-system 1349 (if last-next-selection-coding-system 1350 (format "Coding system for the next X selection (default %S): " 1351 last-next-selection-coding-system) 1352 "Coding system for the next X selection: ") 1353 last-next-selection-coding-system))) 1354 (if coding-system 1355 (setq last-next-selection-coding-system coding-system) 1356 (setq coding-system last-next-selection-coding-system)) 1357 (check-coding-system coding-system) 1358 1359 (setq next-selection-coding-system coding-system)) 1360 1361(defun set-coding-priority (arg) 1362 "Set priority of coding categories according to ARG. 1363ARG is a list of coding categories ordered by priority." 1364 (let ((l arg) 1365 (current-list (copy-sequence coding-category-list))) 1366 ;; Check the validity of ARG while deleting coding categories in 1367 ;; ARG from CURRENT-LIST. We assume that CODING-CATEGORY-LIST 1368 ;; contains all coding categories. 1369 (while l 1370 (if (or (null (get (car l) 'coding-category-index)) 1371 (null (memq (car l) current-list))) 1372 (error "Invalid or duplicated element in argument: %s" arg)) 1373 (setq current-list (delq (car l) current-list)) 1374 (setq l (cdr l))) 1375 ;; Update `coding-category-list' and return it. 1376 (setq coding-category-list (append arg current-list)) 1377 (set-coding-priority-internal))) 1378 1379;;; X selections 1380 1381(defvar ctext-non-standard-encodings-alist 1382 '(("big5-0" big5 2 (chinese-big5-1 chinese-big5-2)) 1383 ("ISO8859-14" iso-8859-14 1 latin-iso8859-14) 1384 ("ISO8859-15" iso-8859-15 1 latin-iso8859-15)) 1385 "Alist of non-standard encoding names vs the corresponding usages in CTEXT. 1386 1387It controls how extended segments of a compound text are handled 1388by the coding system `compound-text-with-extensions'. 1389 1390Each element has the form (ENCODING-NAME CODING-SYSTEM N-OCTET CHARSET). 1391 1392ENCODING-NAME is an encoding name of an \"extended segments\". 1393 1394CODING-SYSTEM is the coding-system to encode (or decode) the 1395characters into (or from) the extended segment. 1396 1397N-OCTET is the number of octets (bytes) that encodes a character 1398in the segment. It can be 0 (meaning the number of octets per 1399character is variable), 1, 2, 3, or 4. 1400 1401CHARSET is a charater set containing characters that are encoded 1402in the segment. It can be a list of character sets. It can also 1403be a char-table, in which case characters that have non-nil value 1404in the char-table are the target. 1405 1406On decoding CTEXT, all encoding names listed here are recognized. 1407 1408On encoding CTEXT, encoding names in the variable 1409`ctext-non-standard-encodings' (which see) and in the information 1410listed for the current language environment under the key 1411`ctext-non-standard-encodings' are used.") 1412 1413(defvar ctext-non-standard-encodings 1414 '("big5-0") 1415 "List of non-standard encoding names used in extended segments of CTEXT. 1416Each element must be one of the names listed in the variable 1417`ctext-non-standard-encodings-alist' (which see).") 1418 1419(defvar ctext-non-standard-encodings-regexp 1420 (string-to-multibyte 1421 (concat 1422 ;; For non-standard encodings. 1423 "\\(\e%/[0-4][\200-\377][\200-\377]\\([^\002]+\\)\002\\)" 1424 "\\|" 1425 ;; For UTF-8 encoding. 1426 "\\(\e%G[^\e]*\e%@\\)"))) 1427 1428;; Functions to support "Non-Standard Character Set Encodings" defined 1429;; by the COMPOUND-TEXT spec. They also support "The UTF-8 encoding" 1430;; described in the section 7 of the documentation of COMPOUND-TEXT 1431;; distributed with XFree86. 1432 1433(defun ctext-post-read-conversion (len) 1434 "Decode LEN characters encoded as Compound Text with Extended Segments." 1435 (save-match-data 1436 (save-restriction 1437 (let ((case-fold-search nil) 1438 (in-workbuf (string= (buffer-name) " *code-converting-work*")) 1439 last-coding-system-used 1440 pos bytes) 1441 (or in-workbuf 1442 (narrow-to-region (point) (+ (point) len))) 1443 (if in-workbuf 1444 (set-buffer-multibyte t)) 1445 (while (re-search-forward ctext-non-standard-encodings-regexp 1446 nil 'move) 1447 (setq pos (match-beginning 0)) 1448 (if (match-beginning 1) 1449 ;; ESC % / [0-4] M L --ENCODING-NAME-- \002 --BYTES-- 1450 (let* ((M (char-after (+ pos 4))) 1451 (L (char-after (+ pos 5))) 1452 (encoding (match-string 2)) 1453 (encoding-info (assoc-string 1454 encoding 1455 ctext-non-standard-encodings-alist t)) 1456 (coding (if encoding-info 1457 (nth 1 encoding-info) 1458 (setq encoding (intern (downcase encoding))) 1459 (and (coding-system-p encoding) 1460 encoding)))) 1461 (setq bytes (- (+ (* (- M 128) 128) (- L 128)) 1462 (- (point) (+ pos 6)))) 1463 (when coding 1464 (delete-region pos (point)) 1465 (forward-char bytes) 1466 (decode-coding-region (- (point) bytes) (point) coding))) 1467 ;; ESC % G --UTF-8-BYTES-- ESC % @ 1468 (delete-char -3) 1469 (delete-region pos (+ pos 3)) 1470 (decode-coding-region pos (point) 'utf-8)))) 1471 (goto-char (point-min)) 1472 (- (point-max) (point))))) 1473 1474;; Return a char table of extended segment usage for each character. 1475;; Each value of the char table is nil, one of the elements of 1476;; `ctext-non-standard-encodings-alist', or the symbol `utf-8'. 1477 1478(defun ctext-non-standard-encodings-table () 1479 (let ((table (make-char-table 'translation-table))) 1480 (aset table (make-char 'mule-unicode-0100-24ff) 'utf-8) 1481 (aset table (make-char 'mule-unicode-2500-33ff) 'utf-8) 1482 (aset table (make-char 'mule-unicode-e000-ffff) 'utf-8) 1483 (dolist (encoding (reverse 1484 (append 1485 (get-language-info current-language-environment 1486 'ctext-non-standard-encodings) 1487 ctext-non-standard-encodings))) 1488 (let* ((slot (assoc encoding ctext-non-standard-encodings-alist)) 1489 (charset (nth 3 slot))) 1490 (if charset 1491 (cond ((charsetp charset) 1492 (aset table (make-char charset) slot)) 1493 ((listp charset) 1494 (dolist (elt charset) 1495 (aset table (make-char elt) slot))) 1496 ((char-table-p charset) 1497 (map-char-table #'(lambda (k v) 1498 (if (and v (> k 128)) (aset table k slot))) 1499 charset)))))) 1500 table)) 1501 1502(defun ctext-pre-write-conversion (from to) 1503 "Encode characters between FROM and TO as Compound Text w/Extended Segments. 1504 1505If FROM is a string, or if the current buffer is not the one set up for us 1506by encode-coding-string, generate a new temp buffer, insert the 1507text, and convert it in the temporary buffer. Otherwise, convert in-place." 1508 (save-match-data 1509 (let ((workbuf (get-buffer-create " *code-conversion-work*"))) 1510 ;; Setup a working buffer if necessary. 1511 (cond ((stringp from) 1512 (set-buffer workbuf) 1513 (erase-buffer) 1514 (set-buffer-multibyte (multibyte-string-p from)) 1515 (insert from)) 1516 ((not (eq (current-buffer) workbuf)) 1517 (let ((buf (current-buffer)) 1518 (multibyte enable-multibyte-characters)) 1519 (set-buffer workbuf) 1520 (erase-buffer) 1521 (set-buffer-multibyte multibyte) 1522 (insert-buffer-substring buf from to))))) 1523 1524 ;; Now we can encode the whole buffer. 1525 (let ((encoding-table (ctext-non-standard-encodings-table)) 1526 last-coding-system-used 1527 last-pos last-encoding-info 1528 encoding-info end-pos) 1529 (goto-char (setq last-pos (point-min))) 1530 (setq end-pos (point-marker)) 1531 (while (re-search-forward "[^\000-\177]+" nil t) 1532 ;; Found a sequence of non-ASCII characters. 1533 (setq last-pos (match-beginning 0) 1534 last-encoding-info (aref encoding-table (char-after last-pos))) 1535 (set-marker end-pos (match-end 0)) 1536 (goto-char (1+ last-pos)) 1537 (catch 'tag 1538 (while t 1539 (setq encoding-info 1540 (if (< (point) end-pos) 1541 (aref encoding-table (following-char)))) 1542 (unless (eq last-encoding-info encoding-info) 1543 (cond ((consp last-encoding-info) 1544 ;; Encode the previous range using an extended 1545 ;; segment. 1546 (let ((encoding-name (car last-encoding-info)) 1547 (coding-system (nth 1 last-encoding-info)) 1548 (noctets (nth 2 last-encoding-info)) 1549 len) 1550 (encode-coding-region last-pos (point) coding-system) 1551 (setq len (+ (length encoding-name) 1 1552 (- (point) last-pos))) 1553 (save-excursion 1554 (goto-char last-pos) 1555 (insert (string-to-multibyte 1556 (format "\e%%/%d%c%c%s" 1557 noctets 1558 (+ (/ len 128) 128) 1559 (+ (% len 128) 128) 1560 encoding-name)))))) 1561 ((eq last-encoding-info 'utf-8) 1562 ;; Encode the previous range using UTF-8 encoding 1563 ;; extention. 1564 (encode-coding-region last-pos (point) 'mule-utf-8) 1565 (save-excursion 1566 (goto-char last-pos) 1567 (insert "\e%G")) 1568 (insert "\e%@"))) 1569 (setq last-pos (point) 1570 last-encoding-info encoding-info)) 1571 (if (< (point) end-pos) 1572 (forward-char 1) 1573 (throw 'tag nil))))) 1574 (set-marker end-pos nil) 1575 (goto-char (point-min)))) 1576 ;; Must return nil, as build_annotations_2 expects that. 1577 nil) 1578 1579;;; FILE I/O 1580 1581(defcustom auto-coding-alist 1582 ;; .exe and .EXE are added to support archive-mode looking at DOS 1583 ;; self-extracting exe archives. 1584 '(("\\.\\(arc\\|zip\\|lzh\\|lha\\|zoo\\|[jew]ar\\|xpi\\|exe\\)\\'" . no-conversion) 1585 ("\\.\\(ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|EXE\\)\\'" . no-conversion) 1586 ("\\.\\(sx[dmicw]\\|odt\\|tar\\|tgz\\)\\'" . no-conversion) 1587 ("\\.\\(gz\\|Z\\|bz\\|bz2\\|gpg\\)\\'" . no-conversion) 1588 ("\\.\\(jpe?g\\|png\\|gif\\|tiff?\\|p[bpgn]m\\)\\'" . no-conversion) 1589 ("\\.pdf\\'" . no-conversion) 1590 ("/#[^/]+#\\'" . emacs-mule)) 1591 "Alist of filename patterns vs corresponding coding systems. 1592Each element looks like (REGEXP . CODING-SYSTEM). 1593A file whose name matches REGEXP is decoded by CODING-SYSTEM on reading. 1594 1595The settings in this alist take priority over `coding:' tags 1596in the file (see the function `set-auto-coding') 1597and the contents of `file-coding-system-alist'." 1598 :group 'files 1599 :group 'mule 1600 :type '(repeat (cons (regexp :tag "File name regexp") 1601 (symbol :tag "Coding system")))) 1602 1603(defcustom auto-coding-regexp-alist 1604 '(("^BABYL OPTIONS:[ \t]*-\\*-[ \t]*rmail[ \t]*-\\*-" . no-conversion) 1605 ("\\`\xFE\xFF" . utf-16be-with-signature) 1606 ("\\`\xFF\xFE" . utf-16le-with-signature) 1607 ("\\`\xEF\xBB\xBF" . utf-8)) 1608 "Alist of patterns vs corresponding coding systems. 1609Each element looks like (REGEXP . CODING-SYSTEM). 1610A file whose first bytes match REGEXP is decoded by CODING-SYSTEM on reading. 1611 1612The settings in this alist take priority over `coding:' tags 1613in the file (see the function `set-auto-coding') 1614and the contents of `file-coding-system-alist'." 1615 :group 'files 1616 :group 'mule 1617 :type '(repeat (cons (regexp :tag "Regexp") 1618 (symbol :tag "Coding system")))) 1619 1620(defun auto-coding-regexp-alist-lookup (from to) 1621 "Lookup `auto-coding-regexp-alist' for the contents of the current buffer. 1622The value is a coding system is specified for the region FROM and TO, 1623or nil." 1624 (save-excursion 1625 (goto-char from) 1626 (let ((alist auto-coding-regexp-alist) 1627 coding-system) 1628 (while (and alist (not coding-system)) 1629 (let ((regexp (car (car alist)))) 1630 (if enable-multibyte-characters 1631 (setq regexp (string-to-multibyte regexp))) 1632 (if (re-search-forward regexp to t) 1633 (setq coding-system (cdr (car alist))) 1634 (setq alist (cdr alist))))) 1635 coding-system))) 1636 1637;; See the bottom of this file for built-in auto coding functions. 1638(defcustom auto-coding-functions '(sgml-xml-auto-coding-function 1639 sgml-html-meta-auto-coding-function) 1640 "A list of functions which attempt to determine a coding system. 1641 1642Each function in this list should be written to operate on the 1643current buffer, but should not modify it in any way. The buffer 1644will contain undecoded text of parts of the file. Each function 1645should take one argument, SIZE, which says how many 1646characters (starting from point) it should look at. 1647 1648If one of these functions succeeds in determining a coding 1649system, it should return that coding system. Otherwise, it 1650should return nil. 1651 1652If a file has a `coding:' tag, that takes precedence over these 1653functions, so they won't be called at all." 1654 :group 'files 1655 :group 'mule 1656 :type '(repeat function)) 1657 1658(defvar set-auto-coding-for-load nil 1659 "Non-nil means look for `load-coding' property instead of `coding'. 1660This is used for loading and byte-compiling Emacs Lisp files.") 1661 1662(defun auto-coding-alist-lookup (filename) 1663 "Return the coding system specified by `auto-coding-alist' for FILENAME." 1664 (let ((alist auto-coding-alist) 1665 (case-fold-search (memq system-type '(vax-vms windows-nt ms-dos cygwin))) 1666 coding-system) 1667 (while (and alist (not coding-system)) 1668 (if (string-match (car (car alist)) filename) 1669 (setq coding-system (cdr (car alist))) 1670 (setq alist (cdr alist)))) 1671 coding-system)) 1672 1673(put 'enable-character-translation 'permanent-local t) 1674(put 'enable-character-translation 'safe-local-variable 'booleanp) 1675 1676(defun find-auto-coding (filename size) 1677 "Find a coding system for a file FILENAME of which SIZE bytes follow point. 1678These bytes should include at least the first 1k of the file 1679and the last 3k of the file, but the middle may be omitted. 1680 1681The function checks FILENAME against the variable `auto-coding-alist'. 1682If FILENAME doesn't match any entries in the variable, it checks the 1683contents of the current buffer following point against 1684`auto-coding-regexp-alist'. If no match is found, it checks for a 1685`coding:' tag in the first one or two lines following point. If no 1686`coding:' tag is found, it checks any local variables list in the last 16873K bytes out of the SIZE bytes. Finally, if none of these methods 1688succeed, it checks to see if any function in `auto-coding-functions' 1689gives a match. 1690 1691If a coding system is specifed, the return value is a 1692cons (CODING . SOURCE), where CODING is the specified coding 1693system and SOURCE is a symbol `auto-coding-alist', 1694`auto-coding-regexp-alist', `coding:', or `auto-coding-functions' 1695indicating by what CODING is specified. Note that the validity 1696of CODING is not checked; it's the caller's responsibility to check it. 1697 1698If nothing is specified, the return value is nil." 1699 (or (let ((coding-system (auto-coding-alist-lookup filename))) 1700 (if coding-system 1701 (cons coding-system 'auto-coding-alist))) 1702 ;; Try using `auto-coding-regexp-alist'. 1703 (let ((coding-system (auto-coding-regexp-alist-lookup (point) 1704 (+ (point) size)))) 1705 (if coding-system 1706 (cons coding-system 'auto-coding-regexp-alist))) 1707 (let* ((case-fold-search t) 1708 (head-start (point)) 1709 (head-end (+ head-start (min size 1024))) 1710 (tail-start (+ head-start (max (- size 3072) 0))) 1711 (tail-end (+ head-start size)) 1712 coding-system head-found tail-found pos char-trans) 1713 ;; Try a short cut by searching for the string "coding:" 1714 ;; and for "unibyte:" at the head and tail of SIZE bytes. 1715 (setq head-found (or (search-forward "coding:" head-end t) 1716 (search-forward "unibyte:" head-end t) 1717 (search-forward "enable-character-translation:" 1718 head-end t))) 1719 (if (and head-found (> head-found tail-start)) 1720 ;; Head and tail are overlapped. 1721 (setq tail-found head-found) 1722 (goto-char tail-start) 1723 (setq tail-found (or (search-forward "coding:" tail-end t) 1724 (search-forward "unibyte:" tail-end t) 1725 (search-forward "enable-character-translation:" 1726 tail-end t)))) 1727 1728 ;; At first check the head. 1729 (when head-found 1730 (goto-char head-start) 1731 (setq head-end (set-auto-mode-1)) 1732 (setq head-start (point)) 1733 (when (and head-end (< head-found head-end)) 1734 (goto-char head-start) 1735 (when (and set-auto-coding-for-load 1736 (re-search-forward 1737 "\\(.*;\\)?[ \t]*unibyte:[ \t]*\\([^ ;]+\\)" 1738 head-end t)) 1739 (setq coding-system 'raw-text)) 1740 (when (and (not coding-system) 1741 (re-search-forward 1742 "\\(.*;\\)?[ \t]*coding:[ \t]*\\([^ ;]+\\)" 1743 head-end t)) 1744 (setq coding-system (intern (match-string 2)))) 1745 (when (re-search-forward 1746 "\\(.*;\\)?[ \t]*enable-character-translation:[ \t]*\\([^ ;]+\\)" 1747 head-end t) 1748 (setq char-trans (match-string 2))))) 1749 1750 ;; If no coding: tag in the head, check the tail. 1751 ;; Here we must pay attention to the case that the end-of-line 1752 ;; is just "\r" and we can't use "^" nor "$" in regexp. 1753 (when (and tail-found (or (not coding-system) (not char-trans))) 1754 (goto-char tail-start) 1755 (re-search-forward "[\r\n]\^L" tail-end t) 1756 (if (re-search-forward 1757 "[\r\n]\\([^[\r\n]*\\)[ \t]*Local Variables:[ \t]*\\([^\r\n]*\\)[\r\n]" 1758 tail-end t) 1759 ;; The prefix is what comes before "local variables:" in its 1760 ;; line. The suffix is what comes after "local variables:" 1761 ;; in its line. 1762 (let* ((prefix (regexp-quote (match-string 1))) 1763 (suffix (regexp-quote (match-string 2))) 1764 (re-coding 1765 (concat 1766 "[\r\n]" prefix 1767 ;; N.B. without the \n below, the regexp can 1768 ;; eat newlines. 1769 "[ \t]*coding[ \t]*:[ \t]*\\([^ \t\r\n]+\\)[ \t]*" 1770 suffix "[\r\n]")) 1771 (re-unibyte 1772 (concat 1773 "[\r\n]" prefix 1774 "[ \t]*unibyte[ \t]*:[ \t]*\\([^ \t\r\n]+\\)[ \t]*" 1775 suffix "[\r\n]")) 1776 (re-char-trans 1777 (concat 1778 "[\r\n]" prefix 1779 "[ \t]*enable-character-translation[ \t]*:[ \t]*\\([^ \t\r\n]+\\)[ \t]*" 1780 suffix "[\r\n]")) 1781 (re-end 1782 (concat "[\r\n]" prefix "[ \t]*End *:[ \t]*" suffix 1783 "[\r\n]?")) 1784 (pos (1- (point)))) 1785 (forward-char -1) ; skip back \r or \n. 1786 (re-search-forward re-end tail-end 'move) 1787 (setq tail-end (point)) 1788 (goto-char pos) 1789 (when (and set-auto-coding-for-load 1790 (re-search-forward re-unibyte tail-end t)) 1791 (setq coding-system 'raw-text)) 1792 (when (and (not coding-system) 1793 (re-search-forward re-coding tail-end t)) 1794 (setq coding-system (intern (match-string 1)))) 1795 (when (and (not char-trans) 1796 (re-search-forward re-char-trans tail-end t)) 1797 (setq char-trans (match-string 1)))))) 1798 (if coding-system 1799 ;; If the coding-system name ends with "!", remove it and 1800 ;; set char-trans to "nil". 1801 (let ((name (symbol-name coding-system))) 1802 (if (= (aref name (1- (length name))) ?!) 1803 (setq coding-system (intern (substring name 0 -1)) 1804 char-trans "nil")))) 1805 (when (and char-trans 1806 (not (setq char-trans (intern char-trans)))) 1807 (make-local-variable 'enable-character-translation) 1808 (setq enable-character-translation nil)) 1809 (if coding-system 1810 (cons coding-system :coding))) 1811 ;; Finally, try all the `auto-coding-functions'. 1812 (let ((funcs auto-coding-functions) 1813 (coding-system nil)) 1814 (while (and funcs (not coding-system)) 1815 (setq coding-system (condition-case e 1816 (save-excursion 1817 (goto-char (point-min)) 1818 (funcall (pop funcs) size)) 1819 (error nil)))) 1820 (if coding-system 1821 (cons coding-system 'auto-coding-functions))))) 1822 1823(defun set-auto-coding (filename size) 1824 "Return coding system for a file FILENAME of which SIZE bytes follow point. 1825See `find-auto-coding' for how the coding system is found. 1826Return nil if an invalid coding system is found. 1827 1828The variable `set-auto-coding-function' (which see) is set to this 1829function by default." 1830 (let ((found (find-auto-coding filename size))) 1831 (if (and found (coding-system-p (car found))) 1832 (car found)))) 1833 1834(setq set-auto-coding-function 'set-auto-coding) 1835 1836;; This variable is set in these two cases: 1837;; (1) A file is read by a coding system specified explicitly. 1838;; after-insert-file-set-coding sets this value to 1839;; coding-system-for-read. 1840;; (2) A buffer is saved. 1841;; After writing, basic-save-buffer-1 sets this value to 1842;; last-coding-system-used. 1843;; This variable is used for decoding in revert-buffer. 1844(defvar buffer-file-coding-system-explicit nil 1845 "The file coding system explicitly specified for the current buffer. 1846Internal use only.") 1847(make-variable-buffer-local 'buffer-file-coding-system-explicit) 1848(put 'buffer-file-coding-system-explicit 'permanent-local t) 1849 1850(defun after-insert-file-set-coding (inserted &optional visit) 1851 "Set `buffer-file-coding-system' of current buffer after text is inserted. 1852INSERTED is the number of characters that were inserted, as figured 1853in the situation before this function. Return the number of characters 1854inserted, as figured in the situation after. The two numbers can be 1855different if the buffer has become unibyte. 1856The optional second arg VISIT non-nil means that we are visiting a file." 1857 (if (and visit 1858 coding-system-for-read 1859 (not (eq coding-system-for-read 'auto-save-coding))) 1860 (setq buffer-file-coding-system-explicit coding-system-for-read)) 1861 (if last-coding-system-used 1862 (let ((coding-system 1863 (find-new-buffer-file-coding-system last-coding-system-used)) 1864 (modified-p (buffer-modified-p))) 1865 (when coding-system 1866 ;; Tell set-buffer-file-coding-system not to mark the file 1867 ;; as modified; we just read it, and it's supposed to be unmodified. 1868 ;; Marking it modified would try to lock it, which would 1869 ;; check the modtime, and we don't want to do that again now. 1870 (set-buffer-file-coding-system coding-system t t) 1871 (if (and enable-multibyte-characters 1872 (or (eq coding-system 'no-conversion) 1873 (eq (coding-system-type coding-system) 5)) 1874 ;; If buffer was unmodified and the size is the 1875 ;; same as INSERTED, we must be visiting it. 1876 (not modified-p) 1877 (= (buffer-size) inserted)) 1878 ;; For coding systems no-conversion and raw-text..., 1879 ;; edit the buffer as unibyte. 1880 (let ((pos-marker (copy-marker (+ (point) inserted))) 1881 ;; Prevent locking. 1882 (buffer-file-name nil)) 1883 (if visit 1884 ;; If we're doing this for find-file, 1885 ;; don't record undo info; this counts as 1886 ;; part of producing the buffer's initial contents. 1887 (let ((buffer-undo-list t)) 1888 (set-buffer-multibyte nil)) 1889 (set-buffer-multibyte nil)) 1890 (setq inserted (- pos-marker (point))))) 1891 (restore-buffer-modified-p modified-p)))) 1892 inserted) 1893 1894;; The coding-spec and eol-type of coding-system returned is decided 1895;; independently in the following order. 1896;; 1. That of buffer-file-coding-system locally bound. 1897;; 2. That of CODING. 1898 1899(defun find-new-buffer-file-coding-system (coding) 1900 "Return a coding system for a buffer when a file of CODING is inserted. 1901The local variable `buffer-file-coding-system' of the current buffer 1902is set to the returned value. 1903Return nil if there's no need to set `buffer-file-coding-system'." 1904 (let (local-coding local-eol 1905 found-coding found-eol 1906 new-coding new-eol) 1907 (if (null coding) 1908 ;; Nothing found about coding. 1909 nil 1910 1911 ;; Get information of `buffer-file-coding-system' in LOCAL-EOL 1912 ;; and LOCAL-CODING. 1913 (setq local-eol (coding-system-eol-type buffer-file-coding-system)) 1914 (if (null (numberp local-eol)) 1915 ;; But eol-type is not yet set. 1916 (setq local-eol nil)) 1917 (if (and buffer-file-coding-system 1918 (not (eq (coding-system-type buffer-file-coding-system) t))) 1919 ;; This is not `undecided'. 1920 (setq local-coding (coding-system-base buffer-file-coding-system))) 1921 1922 (if (and (local-variable-p 'buffer-file-coding-system) 1923 local-eol local-coding) 1924 ;; The current buffer has already set full coding-system, we 1925 ;; had better not change it. 1926 nil 1927 1928 (setq found-eol (coding-system-eol-type coding)) 1929 (if (null (numberp found-eol)) 1930 ;; But eol-type is not found. 1931 ;; If EOL conversions are inhibited, force unix eol-type. 1932 (setq found-eol (if inhibit-eol-conversion 0))) 1933 (if (eq (coding-system-type coding) t) 1934 (setq found-coding 'undecided) 1935 (setq found-coding (coding-system-base coding))) 1936 1937 (if (and (not found-eol) (eq found-coding 'undecided)) 1938 ;; No valid coding information found. 1939 nil 1940 1941 ;; Some coding information (eol or text) found. 1942 1943 ;; The local setting takes precedence over the found one. 1944 (setq new-coding (if (local-variable-p 'buffer-file-coding-system) 1945 (or local-coding found-coding) 1946 (or found-coding local-coding))) 1947 (setq new-eol (if (local-variable-p 'buffer-file-coding-system) 1948 (or local-eol found-eol) 1949 (or found-eol local-eol))) 1950 1951 (let ((eol-type (coding-system-eol-type new-coding))) 1952 (if (and (numberp new-eol) (vectorp eol-type)) 1953 (aref eol-type new-eol) 1954 new-coding))))))) 1955 1956(defun modify-coding-system-alist (target-type regexp coding-system) 1957 "Modify one of look up tables for finding a coding system on I/O operation. 1958There are three of such tables, `file-coding-system-alist', 1959`process-coding-system-alist', and `network-coding-system-alist'. 1960 1961TARGET-TYPE specifies which of them to modify. 1962If it is `file', it affects `file-coding-system-alist' (which see). 1963If it is `process', it affects `process-coding-system-alist' (which see). 1964If it is `network', it affects `network-coding-system-alist' (which see). 1965 1966REGEXP is a regular expression matching a target of I/O operation. 1967The target is a file name if TARGET-TYPE is `file', a program name if 1968TARGET-TYPE is `process', or a network service name or a port number 1969to connect to if TARGET-TYPE is `network'. 1970 1971CODING-SYSTEM is a coding system to perform code conversion on the I/O 1972operation, or a cons cell (DECODING . ENCODING) specifying the coding systems 1973for decoding and encoding respectively, 1974or a function symbol which, when called, returns such a cons cell." 1975 (or (memq target-type '(file process network)) 1976 (error "Invalid target type: %s" target-type)) 1977 (or (stringp regexp) 1978 (and (eq target-type 'network) (integerp regexp)) 1979 (error "Invalid regular expression: %s" regexp)) 1980 (if (symbolp coding-system) 1981 (if (not (fboundp coding-system)) 1982 (progn 1983 (check-coding-system coding-system) 1984 (setq coding-system (cons coding-system coding-system)))) 1985 (check-coding-system (car coding-system)) 1986 (check-coding-system (cdr coding-system))) 1987 (cond ((eq target-type 'file) 1988 (let ((slot (assoc regexp file-coding-system-alist))) 1989 (if slot 1990 (setcdr slot coding-system) 1991 (setq file-coding-system-alist 1992 (cons (cons regexp coding-system) 1993 file-coding-system-alist))))) 1994 ((eq target-type 'process) 1995 (let ((slot (assoc regexp process-coding-system-alist))) 1996 (if slot 1997 (setcdr slot coding-system) 1998 (setq process-coding-system-alist 1999 (cons (cons regexp coding-system) 2000 process-coding-system-alist))))) 2001 (t 2002 (let ((slot (assoc regexp network-coding-system-alist))) 2003 (if slot 2004 (setcdr slot coding-system) 2005 (setq network-coding-system-alist 2006 (cons (cons regexp coding-system) 2007 network-coding-system-alist))))))) 2008 2009(defun decode-coding-inserted-region (from to filename 2010 &optional visit beg end replace) 2011 "Decode the region between FROM and TO as if it is read from file FILENAME. 2012The idea is that the text between FROM and TO was just inserted somehow. 2013Optional arguments VISIT, BEG, END, and REPLACE are the same as those 2014of the function `insert-file-contents'. 2015Part of the job of this function is setting `buffer-undo-list' appropriately." 2016 (save-excursion 2017 (save-restriction 2018 (let ((coding coding-system-for-read) 2019 undo-list-saved) 2020 (if visit 2021 ;; Temporarily turn off undo recording, if we're decoding the 2022 ;; text of a visited file. 2023 (setq buffer-undo-list t) 2024 ;; Otherwise, if we can recognize the undo elt for the insertion, 2025 ;; remove it and get ready to replace it later. 2026 ;; In the mean time, turn off undo recording. 2027 (let ((last (car-safe buffer-undo-list))) 2028 (if (and (consp last) (eql (car last) from) (eql (cdr last) to)) 2029 (setq undo-list-saved (cdr buffer-undo-list) 2030 buffer-undo-list t)))) 2031 (narrow-to-region from to) 2032 (goto-char (point-min)) 2033 (or coding 2034 (setq coding (funcall set-auto-coding-function 2035 filename (- (point-max) (point-min))))) 2036 (or coding 2037 (setq coding (car (find-operation-coding-system 2038 'insert-file-contents 2039 (cons filename (current-buffer)) 2040 visit beg end replace)))) 2041 (if (coding-system-p coding) 2042 (or enable-multibyte-characters 2043 (setq coding 2044 (coding-system-change-text-conversion coding 'raw-text))) 2045 (setq coding nil)) 2046 (if coding 2047 (decode-coding-region (point-min) (point-max) coding) 2048 (setq last-coding-system-used coding)) 2049 ;; If we're decoding the text of a visited file, 2050 ;; the undo list should start out empty. 2051 (if visit 2052 (setq buffer-undo-list nil) 2053 ;; If we decided to replace the undo entry for the insertion, 2054 ;; do so now. 2055 (if undo-list-saved 2056 (setq buffer-undo-list 2057 (cons (cons from (point-max)) undo-list-saved)))))))) 2058 2059(defun recode-region (start end new-coding coding) 2060 "Re-decode the region (previously decoded by CODING) by NEW-CODING." 2061 (interactive 2062 (list (region-beginning) (region-end) 2063 (read-coding-system "Text was really in: ") 2064 (let ((coding (or buffer-file-coding-system last-coding-system-used))) 2065 (read-coding-system 2066 (concat "But was interpreted as" 2067 (if coding (format " (default %S): " coding) ": ")) 2068 coding)))) 2069 (or (and new-coding coding) 2070 (error "Coding system not specified")) 2071 ;; Check it before we encode the region. 2072 (check-coding-system new-coding) 2073 (save-restriction 2074 (narrow-to-region start end) 2075 (encode-coding-region (point-min) (point-max) coding) 2076 (decode-coding-region (point-min) (point-max) new-coding))) 2077 2078(defun make-translation-table (&rest args) 2079 "Make a translation table from arguments. 2080A translation table is a char table intended for character 2081translation in CCL programs. 2082 2083Each argument is a list of elements of the form (FROM . TO), where FROM 2084is a character to be translated to TO. 2085 2086FROM can be a generic character (see `make-char'). In this case, TO is 2087a generic character containing the same number of characters, or an 2088ordinary character. If FROM and TO are both generic characters, all 2089characters belonging to FROM are translated to characters belonging to TO 2090without changing their position code(s). 2091 2092The arguments and forms in each argument are processed in the given 2093order, and if a previous form already translates TO to some other 2094character, say TO-ALT, FROM is also translated to TO-ALT." 2095 (let ((table (make-char-table 'translation-table)) 2096 revlist) 2097 (while args 2098 (let ((elts (car args))) 2099 (while elts 2100 (let* ((from (car (car elts))) 2101 (from-i 0) ; degree of freedom of FROM 2102 (from-rev (nreverse (split-char from))) 2103 (to (cdr (car elts))) 2104 (to-i 0) ; degree of freedom of TO 2105 (to-rev (nreverse (split-char to)))) 2106 ;; Check numbers of heading 0s in FROM-REV and TO-REV. 2107 (while (eq (car from-rev) 0) 2108 (setq from-i (1+ from-i) from-rev (cdr from-rev))) 2109 (while (eq (car to-rev) 0) 2110 (setq to-i (1+ to-i) to-rev (cdr to-rev))) 2111 (if (and (/= from-i to-i) (/= to-i 0)) 2112 (error "Invalid character pair (%d . %d)" from to)) 2113 ;; If we have already translated TO to TO-ALT, FROM should 2114 ;; also be translated to TO-ALT. But, this is only if TO 2115 ;; is a generic character or TO-ALT is not a generic 2116 ;; character. 2117 (let ((to-alt (aref table to))) 2118 (if (and to-alt 2119 (or (> to-i 0) (not (generic-char-p to-alt)))) 2120 (setq to to-alt))) 2121 (if (> from-i 0) 2122 (set-char-table-default table from to) 2123 (aset table from to)) 2124 ;; If we have already translated some chars to FROM, they 2125 ;; should also be translated to TO. 2126 (let ((l (assq from revlist))) 2127 (if l 2128 (let ((ch (car l))) 2129 (setcar l to) 2130 (setq l (cdr l)) 2131 (while l 2132 (aset table ch to) 2133 (setq l (cdr l)) )))) 2134 ;; Now update REVLIST. 2135 (let ((l (assq to revlist))) 2136 (if l 2137 (setcdr l (cons from (cdr l))) 2138 (setq revlist (cons (list to from) revlist))))) 2139 (setq elts (cdr elts)))) 2140 (setq args (cdr args))) 2141 ;; Return TABLE just created. 2142 table)) 2143 2144(defun make-translation-table-from-vector (vec) 2145 "Make translation table from decoding vector VEC. 2146VEC is an array of 256 elements to map unibyte codes to multibyte 2147characters. Elements may be nil for undefined code points. 2148See also the variable `nonascii-translation-table'." 2149 (let ((table (make-char-table 'translation-table)) 2150 (rev-table (make-char-table 'translation-table)) 2151 ch) 2152 (dotimes (i 256) 2153 (setq ch (aref vec i)) 2154 (when ch 2155 (aset table i ch) 2156 (if (>= ch 256) 2157 (aset rev-table ch i)))) 2158 (set-char-table-extra-slot table 0 rev-table) 2159 table)) 2160 2161(defun define-translation-table (symbol &rest args) 2162 "Define SYMBOL as the name of translation table made by ARGS. 2163This sets up information so that the table can be used for 2164translations in a CCL program. 2165 2166If the first element of ARGS is a char-table whose purpose is 2167`translation-table', just define SYMBOL to name it. (Note that this 2168function does not bind SYMBOL.) 2169 2170Any other ARGS should be suitable as arguments of the function 2171`make-translation-table' (which see). 2172 2173This function sets properties `translation-table' and 2174`translation-table-id' of SYMBOL to the created table itself and the 2175identification number of the table respectively. It also registers 2176the table in `translation-table-vector'." 2177 (let ((table (if (and (char-table-p (car args)) 2178 (eq (char-table-subtype (car args)) 2179 'translation-table)) 2180 (car args) 2181 (apply 'make-translation-table args))) 2182 (len (length translation-table-vector)) 2183 (id 0) 2184 (done nil)) 2185 (put symbol 'translation-table table) 2186 (while (not done) 2187 (if (>= id len) 2188 (setq translation-table-vector 2189 (vconcat translation-table-vector (make-vector len nil)))) 2190 (let ((slot (aref translation-table-vector id))) 2191 (if (or (not slot) 2192 (eq (car slot) symbol)) 2193 (progn 2194 (aset translation-table-vector id (cons symbol table)) 2195 (setq done t)) 2196 (setq id (1+ id))))) 2197 (put symbol 'translation-table-id id) 2198 id)) 2199 2200(defun translate-region (start end table) 2201 "From START to END, translate characters according to TABLE. 2202TABLE is a string or a char-table. 2203If TABLE is a string, the Nth character in it is the mapping 2204for the character with code N. 2205If TABLE is a char-table, the element for character N is the mapping 2206for the character with code N. 2207It returns the number of characters changed." 2208 (interactive 2209 (list (region-beginning) 2210 (region-end) 2211 (let (table l) 2212 (dotimes (i (length translation-table-vector)) 2213 (if (consp (aref translation-table-vector i)) 2214 (push (list (symbol-name 2215 (car (aref translation-table-vector i)))) l))) 2216 (if (not l) 2217 (error "No translation table defined")) 2218 (while (not table) 2219 (setq table (completing-read "Translation table: " l nil t))) 2220 (intern table)))) 2221 (if (symbolp table) 2222 (let ((val (get table 'translation-table))) 2223 (or (char-table-p val) 2224 (error "Invalid translation table name: %s" table)) 2225 (setq table val))) 2226 (translate-region-internal start end table)) 2227 2228(put 'with-category-table 'lisp-indent-function 1) 2229 2230(defmacro with-category-table (table &rest body) 2231 "Evaluate BODY with category table of current buffer set to TABLE. 2232The category table of the current buffer is saved, BODY is evaluated, 2233then the saved table is restored, even in case of an abnormal exit. 2234Value is what BODY returns." 2235 (let ((old-table (make-symbol "old-table")) 2236 (old-buffer (make-symbol "old-buffer"))) 2237 `(let ((,old-table (category-table)) 2238 (,old-buffer (current-buffer))) 2239 (unwind-protect 2240 (progn 2241 (set-category-table ,table) 2242 ,@body) 2243 (with-current-buffer ,old-buffer 2244 (set-category-table ,old-table)))))) 2245 2246(defun define-translation-hash-table (symbol table) 2247 "Define SYMBOL as the name of the hash translation TABLE for use in CCL. 2248 2249Analogous to `define-translation-table', but updates 2250`translation-hash-table-vector' and the table is for use in the CCL 2251`lookup-integer' and `lookup-character' functions." 2252 (unless (and (symbolp symbol) 2253 (hash-table-p table)) 2254 (error "Bad args to define-translation-hash-table")) 2255 (let ((len (length translation-hash-table-vector)) 2256 (id 0) 2257 done) 2258 (put symbol 'translation-hash-table table) 2259 (while (not done) 2260 (if (>= id len) 2261 (setq translation-hash-table-vector 2262 (vconcat translation-hash-table-vector [nil]))) 2263 (let ((slot (aref translation-hash-table-vector id))) 2264 (if (or (not slot) 2265 (eq (car slot) symbol)) 2266 (progn 2267 (aset translation-hash-table-vector id (cons symbol table)) 2268 (setq done t)) 2269 (setq id (1+ id))))) 2270 (put symbol 'translation-hash-table-id id) 2271 id)) 2272 2273;;; Initialize some variables. 2274 2275(put 'use-default-ascent 'char-table-extra-slots 0) 2276(setq use-default-ascent (make-char-table 'use-default-ascent)) 2277(put 'ignore-relative-composition 'char-table-extra-slots 0) 2278(setq ignore-relative-composition 2279 (make-char-table 'ignore-relative-composition)) 2280 2281 2282;;; Built-in auto-coding-functions: 2283 2284(defun sgml-xml-auto-coding-function (size) 2285 "Determine whether the buffer is XML, and if so, its encoding. 2286This function is intended to be added to `auto-coding-functions'." 2287 (setq size (+ (point) size)) 2288 (when (re-search-forward "\\`[[:space:]\n]*<\\?xml" size t) 2289 (let ((end (save-excursion 2290 ;; This is a hack. 2291 (re-search-forward "[\"']\\s-*\\?>" size t)))) 2292 (when end 2293 (if (re-search-forward "encoding=[\"']\\(.+?\\)[\"']" end t) 2294 (let* ((match (match-string 1)) 2295 (sym (intern (downcase match)))) 2296 (if (coding-system-p sym) 2297 sym 2298 (message "Warning: unknown coding system \"%s\"" match) 2299 nil)) 2300 'utf-8))))) 2301 2302(defun sgml-html-meta-auto-coding-function (size) 2303 "If the buffer has an HTML meta tag, use it to determine encoding. 2304This function is intended to be added to `auto-coding-functions'." 2305 (setq size (min (+ (point) size) 2306 (save-excursion 2307 ;; Limit the search by the end of the HTML header. 2308 (or (search-forward "</head>" size t) 2309 ;; In case of no header, search only 10 lines. 2310 (forward-line 10)) 2311 (point)))) 2312 ;; Make sure that the buffer really contains an HTML document, by 2313 ;; checking that it starts with a doctype or a <HTML> start tag 2314 ;; (allowing for whitespace at bob). Note: 'DOCTYPE NETSCAPE' is 2315 ;; useful for Mozilla bookmark files. 2316 (when (and (re-search-forward "\\`[[:space:]\n]*\\(<!doctype[[:space:]\n]+\\(html\\|netscape\\)\\|<html\\)" size t) 2317 (re-search-forward "<meta\\s-+http-equiv=[\"']?content-type[\"']?\\s-+content=[\"']text/\\sw+;\\s-*charset=\\(.+?\\)[\"']" size t)) 2318 (let* ((match (match-string 1)) 2319 (sym (intern (downcase match)))) 2320 (if (coding-system-p sym) 2321 sym 2322 (message "Warning: unknown coding system \"%s\"" match) 2323 nil)))) 2324 2325;;; 2326(provide 'mule) 2327 2328;; arch-tag: 9aebaa6e-0e8a-40a9-b857-cb5d04a39e7c 2329;;; mule.el ends here 2330