1 ;;; mule.el --- basic commands for multilingual environment
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,
7 ;; National Institute of Advanced Industrial Science and Technology (AIST)
8 ;; Registration Number H14PRO021
10 ;; National Institute of Advanced Industrial Science and Technology (AIST)
11 ;; Registration Number H13PRO009
13 ;; Keywords: mule, multilingual, character set, coding system
15 ;; This file is part of GNU Emacs.
17 ;; GNU Emacs is free software; you can redistribute it and/or modify
18 ;; it under the terms of the GNU General Public License as published by
19 ;; the Free Software Foundation; either version 3, or (at your option)
22 ;; GNU Emacs is distributed in the hope that it will be useful,
23 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
24 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
25 ;; GNU General Public License for more details.
27 ;; You should have received a copy of the GNU General Public License
28 ;; along with GNU Emacs; see the file COPYING. If not, write to the
29 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
30 ;; Boston, MA 02110-1301, USA.
36 (defconst mule-version "6.0 (HANACHIRUSATO)" "\
37 Version number and name of this version of MULE (multilingual environment).")
39 (defconst mule-version-date "2003.9.1" "\
40 Distribution date of this version of MULE (multilingual environment).")
45 ;; Backward compatibility code for handling emacs-mule charsets.
46 (defvar private-char-area-1-min #xF0000)
47 (defvar private-char-area-1-max #xFFFFE)
48 (defvar private-char-area-2-min #x100000)
49 (defvar private-char-area-2-max #x10FFFE)
51 ;; Table of emacs-mule charsets indexed by their emacs-mule ID.
52 (defvar emacs-mule-charset-table (make-vector 256 nil))
53 (aset emacs-mule-charset-table 0 'ascii)
55 ;; Convert the argument of old-style calll of define-charset to a
56 ;; property list used by the new-style.
57 ;; INFO-VECTOR is a vector of the format:
58 ;; [DIMENSION CHARS WIDTH DIRECTION ISO-FINAL-CHAR ISO-GRAPHIC-PLANE
59 ;; SHORT-NAME LONG-NAME DESCRIPTION]
61 (defun convert-define-charset-argument (emacs-mule-id info-vector)
62 (let* ((dim (aref info-vector 0))
63 (chars (aref info-vector 1))
64 (total (if (= dim 1) chars (* chars chars)))
65 (code-space (if (= dim 1) (if (= chars 96) [32 127] [33 126])
66 (if (= chars 96) [32 127 32 127] [33 126 33 126])))
68 (if (integerp emacs-mule-id)
69 (or (= emacs-mule-id 0)
70 (and (>= emacs-mule-id 129) (< emacs-mule-id 256))
71 (error "Invalid CHARSET-ID: %d" emacs-mule-id))
73 (if (= dim 1) (setq from-id 160 to-id 224)
74 (setq from-id 224 to-id 255))
75 (while (and (< from-id to-id)
76 (not (aref emacs-mule-charset-table from-id)))
77 (setq from-id (1+ from-id)))
79 (error "No more room for the new Emacs-mule charset"))
80 (setq emacs-mule-id from-id)))
81 (if (> (- private-char-area-1-max private-char-area-1-min) total)
82 (setq code-offset private-char-area-1-min
83 private-char-area-1-min (+ private-char-area-1-min total))
84 (if (> (- private-char-area-2-max private-char-area-2-min) total)
85 (setq code-offset private-char-area-2-min
86 private-char-area-2-min (+ private-char-area-2-min total))
87 (error "No more space for a new charset.")))
89 :code-space code-space
90 :iso-final-char (aref info-vector 4)
91 :code-offset code-offset
92 :emacs-mule-id emacs-mule-id)))
94 (defun define-charset (name docstring &rest props)
95 "Define NAME (symbol) as a charset with DOCSTRING.
96 The remaining arguments must come in pairs ATTRIBUTE VALUE. ATTRIBUTE
97 may be any symbol. The following have special meanings, and one of
98 `:code-offset', `:map', `:subset', `:superset' must be specified.
102 VALUE must be a short string to identify the charset. If omitted,
107 VALUE must be a string longer than `:short-name' to identify the
108 charset. If omitted, the value of the `:short-name' attribute is used.
112 VALUE must be an integer 0, 1, 2, or 3, specifying the dimension of
113 code-points of the charsets. If omitted, it is calculated from the
114 value of the `:code-space' attribute.
118 VALUE must be a vector of length at most 8 specifying the byte code
119 range of each dimension in this format:
120 [ MIN-1 MAX-1 MIN-2 MAX-2 ... ]
121 where MIN-N is the minimum byte value of Nth dimension of code-point,
122 MAX-N is the maximum byte value of that.
126 VALUE must be an integer specifying the mininum code point of the
127 charset. If omitted, it is calculated from `:code-space'. VALUE may
128 be a cons (HIGH . LOW), where HIGH is the most significant 16 bits of
129 the code point and LOW is the least significant 16 bits.
133 VALUE must be an integer specifying the maxinum code point of the
134 charset. If omitted, it is calculated from `:code-space'. VALUE may
135 be a cons (HIGH . LOW), where HIGH is the most significant 16 bits of
136 the code point and LOW is the least significant 16 bits.
140 VALUE must be a character in the range 32 to 127 (inclusive)
141 specifying the final char of the charset for ISO-2022 encoding. If
142 omitted, the charset can't be encoded by ISO-2022 based
145 `:iso-revision-number'
147 VALUE must be an integer in the range 0..63, specifying the revision
148 number of the charset for ISO-2022 encoding.
152 VALUE must be an integer of 0, 129..255. If omitted, the charset
153 can't be encoded by coding-systems of type `emacs-mule'.
155 `:ascii-compatible-p'
157 VALUE must be nil or t (default nil). If VALUE is t, the charset is
158 compatible with ASCII, i.e. the first 128 code points map to ASCII.
162 VALUE must be nil or t. If the VALUE is t, the charset is
163 supplementary, which means it is used only as a parent of some other
168 VALUE must be a nonnegative integer that can be used as an invalid
169 code point of the charset. If the minimum code is 0 and the maximum
170 code is greater than Emacs' maximum integer value, `:invalid-code'
171 should not be omitted.
175 VALUE must be an integer added to the index number of a character to
176 get the corresponding character code.
180 VALUE must be vector or string.
182 If it is a vector, the format is [ CODE-1 CHAR-1 CODE-2 CHAR-2 ... ],
183 where CODE-n is a code-point of the charset, and CHAR-n is the
184 corresponding character code.
186 If it is a string, it is a name of file that contains the above
187 information. Each line of the file must be this format:
189 where XXX is a hexadecimal representation of CODE-n and YYY is a
190 hexadecimal representation of CHAR-n. A line starting with `#' is a
195 VALUE must be a list:
196 ( PARENT MIN-CODE MAX-CODE OFFSET )
197 PARENT is a parent charset. MIN-CODE and MAX-CODE specify the range
198 of characters inherited from the parent. OFFSET is an integer value
199 to add to a code point of the parent charset to get the corresponding
200 code point of this charset.
204 VALUE must be a list of parent charsets. The charset inherits
205 characters from them. Each element of the list may be a cons (PARENT
206 . OFFSET), where PARENT is a parent charset, and OFFSET is an offset
207 value to add to a code point of PARENT to get the corresponding code
208 point of this charset.
212 VALUE must be vector or string.
214 If it is a vector, the format is [ CODE-1 CHAR-1 CODE-2 CHAR-2 ... ],
215 where CODE-n is a code-point of the charset, and CHAR-n is the
216 corresponding Unicode character code.
218 If it is a string, it is a name of file that contains the above
219 information. The file format is the same as what described for `:map'
221 (when (vectorp (car props))
223 ;; (define-charset CHARSET-ID CHARSET-SYMBOL INFO-VECTOR)
224 ;; Convert the argument to make it fit with the current style.
225 (let ((vec (car props)))
226 (setq props (convert-define-charset-argument name vec)
228 docstring (aref vec 8))))
229 (let ((attrs (mapcar 'list '(:dimension
246 ;; If :dimension is omitted, get the dimension from :code-space.
247 (let ((dimension (plist-get props :dimension)))
249 (let ((code-space (plist-get props :code-space)))
250 (setq dimension (if code-space (/ (length code-space) 2) 4))
251 (setq props (plist-put props :dimension dimension)))))
253 (let ((code-space (plist-get props :code-space)))
255 (let ((dimension (plist-get props :dimension)))
256 (setq code-space (make-vector 8 0))
257 (dotimes (i dimension)
258 (aset code-space (1+ (* i 2)) #xFF))
259 (setq props (plist-put props :code-space code-space)))))
261 ;; If :emacs-mule-id is specified, update emacs-mule-charset-table.
262 (let ((emacs-mule-id (plist-get props :emacs-mule-id)))
263 (if (integerp emacs-mule-id)
264 (aset emacs-mule-charset-table emacs-mule-id name)))
267 (setcdr slot (plist-get props (car slot))))
269 ;; Make sure that the value of :code-space is a vector of 8
271 (let* ((slot (assq :code-space attrs))
276 (vconcat val (make-vector (- 8 len) 0)))))
278 ;; Add :name and :docstring properties to PROPS.
280 (cons :name (cons name (cons :docstring (cons docstring props)))))
281 (or (plist-get props :short-name)
282 (plist-put props :short-name (symbol-name name)))
283 (or (plist-get props :long-name)
284 (plist-put props :long-name (plist-get props :short-name)))
285 ;; We can probably get a worthwhile amount in purespace.
287 (mapcar (lambda (elt)
292 (setcdr (assq :plist attrs) props)
294 (apply 'define-charset-internal name (mapcar 'cdr attrs))))
297 (defun load-with-code-conversion (fullname file &optional noerror nomessage)
298 "Execute a file of Lisp code named FILE whose absolute name is FULLNAME.
299 The file contents are decoded before evaluation if necessary.
300 If optional third arg NOERROR is non-nil,
301 report no error if FILE doesn't exist.
302 Print messages at start and end of loading unless
303 optional fourth arg NOMESSAGE is non-nil.
304 Return t if file exists."
305 (if (null (file-readable-p fullname))
307 (signal 'file-error (list "Cannot open load file" file)))
308 ;; Read file with code conversion, and then eval.
310 ;; To avoid any autoloading, set default-major-mode to
312 ;; So that we don't get completely screwed if the
313 ;; file is encoded in some complicated character set,
314 ;; read it with real decoding, as a multibyte buffer,
315 ;; even if this is a --unibyte Emacs session.
316 (let ((default-major-mode 'fundamental-mode)
317 (default-enable-multibyte-characters t))
318 ;; We can't use `generate-new-buffer' because files.el
319 ;; is not yet loaded.
320 (get-buffer-create (generate-new-buffer-name " *load*"))))
322 (source (save-match-data (string-match "\\.el\\'" fullname))))
325 (message "Loading %s (source)..." file)
326 (message "Loading %s..." file)))
328 (push file preloaded-file-list))
330 (let ((load-file-name fullname)
331 (set-auto-coding-for-load t)
332 (inhibit-file-name-operation nil))
333 (with-current-buffer buffer
334 ;; Don't let deactivate-mark remain set.
335 (let (deactivate-mark)
336 (insert-file-contents fullname))
337 ;; If the loaded file was inserted with no-conversion or
338 ;; raw-text coding system, make the buffer unibyte.
339 ;; Otherwise, eval-buffer might try to interpret random
340 ;; binary junk as multibyte characters.
341 (if (and enable-multibyte-characters
342 (or (eq (coding-system-type last-coding-system-used)
344 (set-buffer-multibyte nil))
345 ;; Make `kill-buffer' quiet.
346 (set-buffer-modified-p nil))
347 ;; Have the original buffer current while we eval.
348 (eval-buffer buffer nil
349 ;; This is compatible with what `load' does.
350 (if purify-flag file fullname)
351 ;; If this Emacs is running with --unibyte,
352 ;; convert multibyte strings to unibyte
353 ;; after reading them.
354 ;; (not default-enable-multibyte-characters)
357 (let (kill-buffer-hook kill-buffer-query-functions)
358 (kill-buffer buffer)))
360 (do-after-load-evaluation fullname))
362 (unless (or nomessage noninteractive)
364 (message "Loading %s (source)...done" file)
365 (message "Loading %s...done" file)))
368 (defun charset-info (charset)
369 "Return a vector of information of CHARSET.
370 This function is provided for backward compatibility.
372 The elements of the vector are:
373 CHARSET-ID, BYTES, DIMENSION, CHARS, WIDTH, DIRECTION,
374 LEADING-CODE-BASE, LEADING-CODE-EXT,
375 ISO-FINAL-CHAR, ISO-GRAPHIC-PLANE,
376 REVERSE-CHARSET, SHORT-NAME, LONG-NAME, DESCRIPTION,
379 CHARSET-ID is always 0.
381 DIMENSION is the number of bytes of a code-point of the charset:
383 CHARS is the number of characters in a dimension:
386 DIRECTION is always 0.
387 LEADING-CODE-BASE is always 0.
388 LEADING-CODE-EXT is always 0.
389 ISO-FINAL-CHAR (character) is the final character of the
390 corresponding ISO 2022 charset. If the charset is not assigned
391 any final character, the value is -1.
392 ISO-GRAPHIC-PLANE is always 0.
393 REVERSE-CHARSET is always -1.
394 SHORT-NAME (string) is the short name to refer to the charset.
395 LONG-NAME (string) is the long name to refer to the charset
396 DESCRIPTION (string) is the description string of the charset.
397 PLIST (property list) may contain any type of information a user
398 want to put and get by functions `put-charset-property' and
399 `get-charset-property' respectively."
402 (charset-dimension charset)
403 (charset-chars charset)
408 (charset-iso-final-char charset)
411 (get-charset-property charset :short-name)
412 (get-charset-property charset :short-name)
413 (charset-description charset)
414 (charset-plist charset)))
416 ;; It is better not to use backquote in this file,
417 ;; because that makes a bootstrapping problem
418 ;; if you need to recompile all the Lisp files using interpreted code.
420 (defun charset-id (charset)
421 "Always return 0. This is provided for backward compatibility."
424 (defmacro charset-bytes (charset)
425 "Always return 0. This is provided for backward compatibility."
428 (defun get-charset-property (charset propname)
429 "Return the value of CHARSET's PROPNAME property.
430 This is the last value stored with
431 (put-charset-property CHARSET PROPNAME VALUE)."
432 (plist-get (charset-plist charset) propname))
434 (defun put-charset-property (charset propname value)
435 "Set CHARSETS's PROPNAME property to value VALUE.
436 It can be retrieved with `(get-charset-property CHARSET PROPNAME)'."
437 (set-charset-plist charset
438 (plist-put (charset-plist charset) propname value)))
440 (defun charset-description (charset)
441 "Return description string of CHARSET."
442 (plist-get (charset-plist charset) :docstring))
444 (defun charset-dimension (charset)
445 "Return dimension of CHARSET."
446 (plist-get (charset-plist charset) :dimension))
448 (defun charset-chars (charset &optional dimension)
449 "Return number of characters contained in DIMENSION of CHARSET.
450 DIMENSION defaults to the first dimension."
451 (unless dimension (setq dimension 1))
452 (let ((code-space (plist-get (charset-plist charset) :code-space)))
453 (1+ (- (aref code-space (1- (* 2 dimension)))
454 (aref code-space (- (* 2 dimension) 2))))))
456 (defun charset-iso-final-char (charset)
457 "Return ISO-2022 final character of CHARSET.
458 Return -1 if charset isn't an ISO 2022 one."
459 (or (plist-get (charset-plist charset) :iso-final-char)
462 (defmacro charset-short-name (charset)
463 "Return short name of CHARSET."
464 (plist-get (charset-plist charset) :short-name))
466 (defmacro charset-long-name (charset)
467 "Return long name of CHARSET."
468 (plist-get (charset-plist charset) :long-name))
470 (defun charset-list ()
471 "Return list of all charsets ever defined.
473 This function is provided for backward compatibility.
474 Now we have the variable `charset-list'."
476 (make-obsolete 'charset-list "Use variable `charset-list'" "23.1")
480 (defalias 'char-valid-p 'characterp)
481 (make-obsolete 'char-valid-p 'characterp "23.1")
483 (defun generic-char-p (char)
484 "Always return nil. This is provided for backward compatibility."
486 (make-obsolete 'generic-char-p "Generic characters no longer exist" "23.1")
488 (defun make-char-internal (charset-id &optional code1 code2)
489 (let ((charset (aref emacs-mule-charset-table charset-id)))
491 (error "Invalid Emacs-mule charset ID: %d" charset-id))
492 (make-char charset code1 code2)))
494 ;; Save the ASCII case table in case we need it later. Some locales
495 ;; (such as Turkish) modify the case behavior of ASCII characters,
496 ;; which can interfere with networking code that uses ASCII strings.
498 (defvar ascii-case-table
499 ;; Code copied from copy-case-table to avoid requiring case-table.el
500 (let ((tbl (copy-sequence (standard-case-table)))
501 (up (char-table-extra-slot (standard-case-table) 0)))
502 (if up (set-char-table-extra-slot tbl 0 (copy-sequence up)))
503 (set-char-table-extra-slot tbl 1 nil)
504 (set-char-table-extra-slot tbl 2 nil)
506 "Case table for the ASCII character set.")
508 ;; Coding system stuff
510 ;; Coding system is a symbol that has been defined by the function
511 ;; `define-coding-system'.
513 (defconst coding-system-iso-2022-flags
531 "List of symbols that control ISO-2022 encoder/decoder.
533 The value of the `:flags' attribute in the argument of the function
534 `define-coding-system' must be one of them.
536 If `long-form' is specified, use a long designation sequence on
537 encoding for the charsets `japanese-jisx0208-1978', `chinese-gb2312',
538 and `japanese-jisx0208'. The long designation sequence doesn't
539 conform to ISO 2022, but is used by such coding systems as
542 If `ascii-at-eol' is specified, designate ASCII to g0 at end of line
545 If `ascii-at-cntl' is specified, designate ASCII to g0 before control
546 codes and SPC on encoding.
548 If `7-bit' is specified, use 7-bit code only on encoding.
550 If `locking-shift' is specified, decode locking-shift code correctly
551 on decoding, and use locking-shift to invoke a graphic element on
554 If `single-shift' is specified, decode single-shift code correctly on
555 decoding, and use single-shift to invoke a graphic element on encoding.
557 If `designation' is specified, decode designation code correctly on
558 decoding, and use designation to designate a charset to a graphic
561 If `revision' is specified, produce an escape sequence to specify
562 revision number of a charset on encoding. Such an escape sequence is
563 always correctly decoded on decoding.
565 If `direction' is specified, decode ISO6429's code for specifying
566 direction correctly, and produce the code on encoding.
568 If `init-at-bol' is specified, on encoding, it is assumed that
569 invocation and designation statuses are reset at each beginning of
570 line even if `ascii-at-eol' is not specified; thus no codes for
571 resetting them are produced.
573 If `safe' is specified, on encoding, characters not supported by a
574 coding are replaced with `?'.
576 If `latin-extra' is specified, the code-detection routine assumes that a
577 code specified in `latin-extra-code-table' (which see) is valid.
579 If `composition' is specified, an escape sequence to specify
580 composition sequence is correctly decoded on decoding, and is produced
583 If `euc-tw-shift' is specified, the EUC-TW specific shifting code is
584 correctly decoded on decoding, and is produced on encoding.
586 If `use-roman' is specified, JIS0201-1976-Roman is designated instead
589 If `use-oldjis' is specified, JIS0208-1976 is designated instead of
592 (defun define-coding-system (name docstring &rest props)
593 "Define NAME (a symbol) as a coding system with DOCSTRING and attributes.
594 The remaining arguments must come in pairs ATTRIBUTE VALUE. ATTRIBUTE
597 The following attributes have special meanings. Those labeled as
598 \"(required)\", should not be omitted.
600 `:mnemonic' (required)
602 VALUE is a character to display on mode line for the coding system.
604 `:coding-type' (required)
606 VALUE must be one of `charset', `utf-8', `utf-16', `iso-2022',
607 `emacs-mule', `shift-jis', `ccl', `raw-text', `undecided'.
611 VALUE is the EOL (end-of-line) format of the coding system. It must be
612 one of `unix', `dos', `mac'. The symbol `unix' means Unix-like EOL
613 \(i.e. single LF), `dos' means DOS-like EOL \(i.e. sequence of CR LF),
614 and `mac' means MAC-like EOL \(i.e. single CR). If omitted, on
615 decoding by the coding system, Emacs automatically detects the EOL
616 format of the source text.
620 VALUE must be a list of charsets supported by the coding system. On
621 encoding by the coding system, if a character belongs to multiple
622 charsets in the list, a charset that comes earlier in the list is
623 selected. If `:coding-type' is `iso-2022', VALUE may be `iso-2022',
624 which indicates that the coding system supports all ISO-2022 based
625 charsets. If `:coding-type' is `emacs-mule', VALUE may be
626 `emacs-mule', which indicates that the coding system supports all
627 charsets that have the `:emacs-mule-id' property.
629 `:ascii-compatible-p'
631 If VALUE is non-nil, the coding system decodes all 7-bit bytes into
632 the corresponding ASCII characters, and encodes all ASCII characters
633 back to the corresponding 7-bit bytes. VALUE defaults to nil.
635 `:decode-translation-table'
637 VALUE must be a translation table to use on decoding.
639 `:encode-translation-table'
641 VALUE must be a translation table to use on encoding.
643 `:post-read-conversion'
645 VALUE must be a function to call after some text is inserted and
646 decoded by the coding system itself and before any functions in
647 `after-insert-functions' are called. The arguments to this function
648 are the same as those of a function in `after-insert-file-functions',
649 i.e. LENGTH of the text to be decoded with point at the head of it,
650 and the function should leave point unchanged.
652 `:pre-write-conversion'
654 VALUE must be a function to call after all functions in
655 `write-region-annotate-functions' and `buffer-file-format' are called,
656 and before the text is encoded by the coding system itself. The
657 arguments to this function are the same as those of a function in
658 `write-region-annotate-functions'.
662 VALUE must be a character. On encoding, a character not supported by
663 the coding system is replaced with VALUE.
667 VALUE non-nil means that visiting a file with the coding system
668 results in a unibyte buffer.
672 VALUE must be `unix', `dos', `mac'. The symbol `unix' means Unix-like
673 EOL (LF), `dos' means DOS-like EOL (CRLF), and `mac' means MAC-like
674 EOL (CR). If omitted, on decoding, the coding system detects EOL
675 format automatically, and on encoding, uses Unix-like EOL.
679 VALUE must be a symbol whose name is that of a MIME charset converted
682 `:mime-text-unsuitable'
684 VALUE non-nil means the `:mime-charset' property names a charset which
685 is unsuitable for the top-level media type \"text\".
689 VALUE must be a list of symbols that control the ISO-2022 converter.
690 Each must be a member of the list `coding-system-iso-2022-flags'
691 \(which see). This attribute has a meaning only when `:coding-type'
696 VALUE must be a vector [G0-USAGE G1-USAGE G2-USAGE G3-USAGE].
697 GN-USAGE specifies the usage of graphic register GN as follows.
699 If it is nil, no charset can be designated to GN.
701 If it is a charset, the charset is initially designated to GN, and
702 never used by the other charsets.
704 If it is a list, the elements must be charsets, nil, 94, or 96. GN
705 can be used by all the listed charsets. If the list contains 94, any
706 iso-2022 charset whose code-space ranges are 94 long can be designated
707 to GN. If the list contains 96, any charsets whose whose ranges are
708 96 long can be designated to GN. If the first element is a charset,
709 that charset is initially designated to GN.
711 This attribute has a meaning only when `:coding-type' is `iso-2022'.
715 This attributes specifies whether the coding system uses a `byte order
716 mark'. VALUE must nil, t, or cons of coding systems whose
717 `:coding-type' is `utf-16'.
719 If the value is nil, on decoding, don't treat the first two-byte as
720 BOM, and on encoding, don't produce BOM bytes.
722 If the value is t, on decoding, skip the first two-byte as BOM, and on
723 encoding, produce BOM bytes accoding to the value of `:endian'.
725 If the value is cons, on decoding, check the first two-byte. If theyq
726 are 0xFE 0xFF, use the car part coding system of the value. If they
727 are 0xFF 0xFE, use the car part coding system of the value.
728 Otherwise, treat them as bytes for a normal character. On encoding,
729 produce BOM bytes accoding to the value of `:endian'.
731 This attribute has a meaning only when `:coding-type' is `utf-16'.
735 VALUE must be `big' or `little' specifying big-endian and
736 little-endian respectively. The default value is `big'.
738 This attribute has a meaning only when `:coding-type' is `utf-16'.
742 VALUE is a symbol representing the registered CCL program used for
743 decoding. This attribute has a meaning only when `:coding-type' is
748 VALUE is a symbol representing the registered CCL program used for
749 encoding. This attribute has a meaning only when `:coding-type' is
751 (let* ((common-attrs (mapcar 'list
756 :decode-translation-table
757 :encode-translation-table
758 :post-read-conversion
759 :pre-write-conversion
764 (coding-type (plist-get props :coding-type))
765 (spec-attrs (mapcar 'list
766 (cond ((eq coding-type 'iso-2022)
771 ((eq coding-type 'utf-16)
774 ((eq coding-type 'ccl)
779 (dolist (slot common-attrs)
780 (setcdr slot (plist-get props (car slot))))
782 (dolist (slot spec-attrs)
783 (setcdr slot (plist-get props (car slot))))
785 (if (eq coding-type 'iso-2022)
786 (let ((designation (plist-get props :designation))
787 (flags (plist-get props :flags))
788 (initial (make-vector 4 nil))
789 (reg-usage (cons 4 4))
792 (setq elt (aref designation i))
793 (cond ((charsetp elt)
795 (setq request (cons (cons elt i) request)))
797 (aset initial i (car elt))
798 (if (charsetp (car elt))
799 (setq request (cons (cons (car elt) i) request)))
800 (dolist (e (cdr elt))
802 (setq request (cons (cons e i) request)))
804 (setcar reg-usage i))
806 (setcdr reg-usage i))
809 (setcdr reg-usage i)))))))
810 (setcdr (assq :initial spec-attrs) initial)
811 (setcdr (assq :reg-usage spec-attrs) reg-usage)
812 (setcdr (assq :request spec-attrs) request)
814 ;; Change :flags value from a list to a bit-mask.
817 (dolist (elt coding-system-iso-2022-flags)
819 (setq bits (logior bits (lsh 1 i))))
821 (setcdr (assq :flags spec-attrs) bits))))
823 ;; Add :name and :docstring properties to PROPS.
825 (cons :name (cons name (cons :docstring (cons (purecopy docstring)
827 (setcdr (assq :plist common-attrs) props)
828 (apply 'define-coding-system-internal
829 name (mapcar 'cdr (append common-attrs spec-attrs)))))
831 (defun coding-system-doc-string (coding-system)
832 "Return the documentation string for CODING-SYSTEM."
833 (plist-get (coding-system-plist coding-system) :docstring))
835 (defun coding-system-mnemonic (coding-system)
836 "Return the mnemonic character of CODING-SYSTEM.
837 The mnemonic character of a coding system is used in mode line to
838 indicate the coding system. If CODING-SYSTEM. is nil, return ?=."
839 (plist-get (coding-system-plist coding-system) :mnemonic))
841 (defun coding-system-type (coding-system)
842 "Return the coding type of CODING-SYSTEM.
843 A coding type is a symbol indicating the encoding method of CODING-SYSTEM.
844 See the function `define-coding-system' for more detail."
845 (plist-get (coding-system-plist coding-system) :coding-type))
847 (defun coding-system-charset-list (coding-system)
848 "Return list of charsets supported by CODING-SYSTEM.
849 If CODING-SYSTEM supports all ISO-2022 charsets, return `iso-2022'.
850 If CODING-SYSTEM supports all emacs-mule charsets, return `emacs-mule'."
851 (plist-get (coding-system-plist coding-system) :charset-list))
853 (defun coding-system-category (coding-system)
854 "Return a category symbol of CODING-SYSTEM."
855 (plist-get (coding-system-plist coding-system) :category))
857 (defun coding-system-get (coding-system prop)
858 "Extract a value from CODING-SYSTEM's property list for property PROP.
859 For compatibility with Emacs 20/21, this accepts old-style symbols
860 like `mime-charset' as well as the current style like `:mime-charset'."
861 (or (plist-get (coding-system-plist coding-system) prop)
862 (if (not (keywordp prop))
863 ;; For backward compatiblity.
864 (if (eq prop 'ascii-incompatible)
865 (not (plist-get (coding-system-plist coding-system)
866 :ascii-compatible-p))
867 (plist-get (coding-system-plist coding-system)
868 (intern (concat ":" (symbol-name prop))))))))
870 (defun coding-system-eol-type-mnemonic (coding-system)
871 "Return the string indicating end-of-line format of CODING-SYSTEM."
872 (let* ((eol-type (coding-system-eol-type coding-system))
873 (val (cond ((eq eol-type 0) eol-mnemonic-unix)
874 ((eq eol-type 1) eol-mnemonic-dos)
875 ((eq eol-type 2) eol-mnemonic-mac)
876 (t eol-mnemonic-undecided))))
879 (char-to-string val))))
881 (defun coding-system-lessp (x y)
882 (cond ((eq x 'no-conversion) t)
883 ((eq y 'no-conversion) nil)
884 ((eq x 'emacs-mule) t)
885 ((eq y 'emacs-mule) nil)
886 ((eq x 'undecided) t)
887 ((eq y 'undecided) nil)
888 (t (let ((c1 (coding-system-mnemonic x))
889 (c2 (coding-system-mnemonic y)))
890 (or (< (downcase c1) (downcase c2))
891 (and (not (> (downcase c1) (downcase c2)))
894 (defun coding-system-equal (coding-system-1 coding-system-2)
895 "Return t if and only if CODING-SYSTEM-1 and CODING-SYSTEM-2 are identical.
896 Two coding systems are identical if two symbols are equal
897 or one is an alias of the other."
898 (or (eq coding-system-1 coding-system-2)
899 (and (equal (coding-system-plist coding-system-1)
900 (coding-system-plist coding-system-2))
901 (let ((eol-type-1 (coding-system-eol-type coding-system-1))
902 (eol-type-2 (coding-system-eol-type coding-system-2)))
903 (or (eq eol-type-1 eol-type-2)
904 (and (vectorp eol-type-1) (vectorp eol-type-2)))))))
906 (defun add-to-coding-system-list (coding-system)
907 "Add CODING-SYSTEM to `coding-system-list' while keeping it sorted."
908 (if (or (null coding-system-list)
909 (coding-system-lessp coding-system (car coding-system-list)))
910 (setq coding-system-list (cons coding-system coding-system-list))
911 (let ((len (length coding-system-list))
912 mid (tem coding-system-list))
914 (setq mid (nthcdr (/ len 2) tem))
915 (if (coding-system-lessp (car mid) coding-system)
917 len (- len (/ len 2)))
918 (setq len (/ len 2))))
919 (setcdr tem (cons coding-system (cdr tem))))))
921 (defun coding-system-list (&optional base-only)
922 "Return a list of all existing non-subsidiary coding systems.
923 If optional arg BASE-ONLY is non-nil, only base coding systems are
924 listed. The value doesn't include subsidiary coding systems which are
925 made from bases and aliases automatically for various end-of-line
926 formats (e.g. iso-latin-1-unix, koi8-r-dos)."
928 (dolist (coding coding-system-list)
929 (if (eq (coding-system-base coding) coding)
931 (setq codings (cons coding codings))
932 (dolist (alias (coding-system-aliases coding))
933 (setq codings (cons alias codings))))))
936 (defconst char-coding-system-table nil
937 "This is an obsolete variable.
938 It exists just for backward compatibility, and the value is always nil.")
940 (defun transform-make-coding-system-args (name type &optional doc-string props)
941 "For internal use only.
942 Transform XEmacs style args for `make-coding-system' to Emacs style.
943 Value is a list of transformed arguments."
944 (let ((mnemonic (string-to-char (or (plist-get props 'mnemonic) "?")))
945 (eol-type (plist-get props 'eol-type))
948 ((eq eol-type 'lf) (setq eol-type 'unix))
949 ((eq eol-type 'crlf) (setq eol-type 'dos))
950 ((eq eol-type 'cr) (setq eol-type 'mac)))
951 (if (setq tmp (plist-get props 'post-read-conversion))
952 (setq properties (plist-put properties 'post-read-conversion tmp)))
953 (if (setq tmp (plist-get props 'pre-write-conversion))
954 (setq properties (plist-put properties 'pre-write-conversion tmp)))
956 ((eq type 'shift-jis)
957 `(,name 1 ,mnemonic ,doc-string () ,properties ,eol-type))
958 ((eq type 'iso2022) ; This is not perfect.
959 (if (plist-get props 'escape-quoted)
960 (error "escape-quoted is not supported: %S"
961 `(,name ,type ,doc-string ,props)))
962 (let ((g0 (plist-get props 'charset-g0))
963 (g1 (plist-get props 'charset-g1))
964 (g2 (plist-get props 'charset-g2))
965 (g3 (plist-get props 'charset-g3))
968 (eq (cadr (assoc 'latin-jisx0201
969 (plist-get props 'input-charset-conversion)))
971 (eq (cadr (assoc 'ascii
972 (plist-get props 'output-charset-conversion)))
976 (eq (cadr (assoc 'japanese-jisx0208-1978
977 (plist-get props 'input-charset-conversion)))
979 (eq (cadr (assoc 'japanese-jisx0208
980 (plist-get props 'output-charset-conversion)))
981 'japanese-jisx0208-1978))))
983 (if (plist-get props 'force-g0-on-output)
987 (if (plist-get props 'force-g1-on-output)
991 (if (plist-get props 'force-g2-on-output)
995 (if (plist-get props 'force-g3-on-output)
998 `(,name 2 ,mnemonic ,doc-string
1000 ,(plist-get props 'short)
1001 ,(not (plist-get props 'no-ascii-eol))
1002 ,(not (plist-get props 'no-ascii-cntl))
1003 ,(plist-get props 'seven)
1005 ,(not (plist-get props 'lock-shift))
1008 ,(plist-get props 'no-iso6429)
1010 ,properties ,eol-type)))
1012 `(,name 3 ,mnemonic ,doc-string () ,properties ,eol-type))
1014 `(,name 4 ,mnemonic ,doc-string
1015 (,(plist-get props 'decode) . ,(plist-get props 'encode))
1016 ,properties ,eol-type))
1018 (error "unsupported XEmacs style make-coding-style arguments: %S"
1019 `(,name ,type ,doc-string ,props))))))
1021 (defun make-coding-system (coding-system type mnemonic doc-string
1026 "Define a new coding system CODING-SYSTEM (symbol).
1027 This function is provided for backward compatibility.
1028 Use `define-coding-system' instead."
1029 ;; For compatiblity with XEmacs, we check the type of TYPE. If it
1030 ;; is a symbol, perhaps, this function is called with XEmacs-style
1031 ;; arguments. Here, try to transform that kind of arguments to
1034 (let ((args (transform-make-coding-system-args coding-system type
1035 mnemonic doc-string)))
1036 (setq coding-system (car args)
1038 mnemonic (nth 2 args)
1039 doc-string (nth 3 args)
1041 properties (nth 5 args)
1042 eol-type (nth 6 args))))
1045 (cond ((eq type 0) 'emacs-mule)
1046 ((eq type 1) 'shift-jis)
1047 ((eq type 2) 'iso2022)
1050 ((eq type 5) 'raw-text)
1052 (error "Invalid coding system type: %s" type))))
1055 (let ((plist nil) key)
1056 (dolist (elt properties)
1057 (setq key (car elt))
1058 (cond ((eq key 'post-read-conversion)
1059 (setq key :post-read-conversion))
1060 ((eq key 'pre-write-conversion)
1061 (setq key :pre-write-conversion))
1062 ((eq key 'translation-table-for-decode)
1063 (setq key :decode-translation-table))
1064 ((eq key 'translation-table-for-encode)
1065 (setq key :encode-translation-table))
1066 ((eq key 'safe-charsets)
1067 (setq key :charset-list))
1068 ((eq key 'mime-charset)
1069 (setq key :mime-charset))
1070 ((eq key 'valid-codes)
1071 (setq key :valids)))
1072 (setq plist (plist-put plist key (cdr elt))))
1074 (setq properties (plist-put properties :mnemonic mnemonic))
1075 (plist-put properties :coding-type type)
1076 (cond ((eq eol-type 0) (setq eol-type 'unix))
1077 ((eq eol-type 1) (setq eol-type 'dos))
1078 ((eq eol-type 2) (setq eol-type 'mac))
1079 ((vectorp eol-type) (setq eol-type nil)))
1080 (plist-put properties :eol-type eol-type)
1084 (plist-put properties :flags
1085 (list (and (or (consp (nth 0 flags))
1086 (consp (nth 1 flags))
1087 (consp (nth 2 flags))
1088 (consp (nth 3 flags))) 'designation)
1089 (or (nth 4 flags) 'long-form)
1090 (and (nth 5 flags) 'ascii-at-eol)
1091 (and (nth 6 flags) 'ascii-at-cntl)
1092 (and (nth 7 flags) '7-bit)
1093 (and (nth 8 flags) 'locking-shift)
1094 (and (nth 9 flags) 'single-shift)
1095 (and (nth 10 flags) 'use-roman)
1096 (and (nth 11 flags) 'use-oldjis)
1097 (or (nth 12 flags) 'direction)
1098 (and (nth 13 flags) 'init-at-bol)
1099 (and (nth 14 flags) 'designate-at-bol)
1100 (and (nth 15 flags) 'safe)
1101 (and (nth 16 flags) 'latin-extra)))
1102 (plist-put properties :designation
1103 (let ((vec (make-vector 4 nil)))
1105 (let ((spec (nth i flags)))
1107 (aset vec i '(94 96))
1111 (setq spec (append (delq t spec) '(94 96))))
1112 (aset vec i spec))))))
1116 (plist-put properties :ccl-decoder (car flags))
1117 (plist-put properties :ccl-encoder (cdr flags))))
1119 (apply 'define-coding-system coding-system doc-string properties))
1121 (defun merge-coding-systems (first second)
1122 "Fill in any unspecified aspects of coding system FIRST from SECOND.
1123 Return the resulting coding system."
1124 (let ((base (coding-system-base second))
1125 (eol (coding-system-eol-type second)))
1126 ;; If FIRST doesn't specify text conversion, merge with that of SECOND.
1127 (if (eq (coding-system-base first) 'undecided)
1128 (setq first (coding-system-change-text-conversion first base)))
1129 ;; If FIRST doesn't specify eol conversion, merge with that of SECOND.
1130 (if (and (vectorp (coding-system-eol-type first))
1131 (numberp eol) (>= eol 0) (<= eol 2))
1132 (setq first (coding-system-change-eol-conversion
1136 (defun autoload-coding-system (symbol form)
1137 "Define SYMBOL as a coding-system that is defined on demand.
1139 FROM is a form to evaluate to define the coding-system."
1140 (put symbol 'coding-system-define-form form)
1141 (setq coding-system-alist (cons (list (symbol-name symbol))
1142 coding-system-alist))
1143 (dolist (elt '("-unix" "-dos" "-mac"))
1144 (let ((name (concat (symbol-name symbol) elt)))
1145 (put (intern name) 'coding-system-define-form form)
1146 (setq coding-system-alist (cons (list name) coding-system-alist)))))
1148 (defun set-buffer-file-coding-system (coding-system &optional force nomodify)
1149 "Set the file coding-system of the current buffer to CODING-SYSTEM.
1150 This means that when you save the buffer, it will be converted
1151 according to CODING-SYSTEM. For a list of possible values of CODING-SYSTEM,
1152 use \\[list-coding-systems].
1154 If CODING-SYSTEM leaves the text conversion unspecified, or if it
1155 leaves the end-of-line conversion unspecified, FORCE controls what to
1156 do. If FORCE is nil, get the unspecified aspect (or aspects) from the
1157 buffer's previous `buffer-file-coding-system' value (if it is
1158 specified there). Otherwise, leave it unspecified.
1160 This marks the buffer modified so that the succeeding \\[save-buffer]
1161 surely saves the buffer with CODING-SYSTEM. From a program, if you
1162 don't want to mark the buffer modified, specify t for NOMODIFY.
1163 If you know exactly what coding system you want to use,
1164 just set the variable `buffer-file-coding-system' directly."
1165 (interactive "zCoding system for saving file (default nil): \nP")
1166 (check-coding-system coding-system)
1167 (if (and coding-system buffer-file-coding-system (null force))
1169 (merge-coding-systems coding-system buffer-file-coding-system)))
1170 (setq buffer-file-coding-system coding-system)
1171 ;; This is in case of an explicit call. Normally, `normal-mode' and
1172 ;; `set-buffer-major-mode-hook' take care of setting the table.
1173 (if (fboundp 'ucs-set-table-for-input) ; don't lose when building
1174 (ucs-set-table-for-input))
1176 (set-buffer-modified-p t))
1177 (force-mode-line-update))
1179 (defun revert-buffer-with-coding-system (coding-system &optional force)
1180 "Visit the current buffer's file again using coding system CODING-SYSTEM.
1181 For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems].
1183 If CODING-SYSTEM leaves the text conversion unspecified, or if it
1184 leaves the end-of-line conversion unspecified, FORCE controls what to
1185 do. If FORCE is nil, get the unspecified aspect (or aspects) from the
1186 buffer's previous `buffer-file-coding-system' value (if it is
1187 specified there). Otherwise, determine it from the file contents as
1188 usual for visiting a file."
1189 (interactive "zCoding system for visited file (default nil): \nP")
1190 (check-coding-system coding-system)
1191 (if (and coding-system buffer-file-coding-system (null force))
1193 (merge-coding-systems coding-system buffer-file-coding-system)))
1194 (let ((coding-system-for-read coding-system))
1197 (defun set-file-name-coding-system (coding-system)
1198 "Set coding system for decoding and encoding file names to CODING-SYSTEM.
1199 It actually just set the variable `file-name-coding-system' (which
1200 see) to CODING-SYSTEM."
1201 (interactive "zCoding system for file names (default nil): ")
1202 (check-coding-system coding-system)
1203 (if (and coding-system
1204 (not (coding-system-get coding-system :ascii-compatible-p))
1205 (not (coding-system-get coding-system :suitable-for-file-name)))
1206 (error "%s is not suitable for file names" coding-system))
1207 (setq file-name-coding-system coding-system))
1209 (defvar default-terminal-coding-system nil
1210 "Default value for the terminal coding system.
1211 This is normally set according to the selected language environment.
1212 See also the command `set-terminal-coding-system'.")
1214 (defun set-terminal-coding-system (coding-system)
1215 "Set coding system of your terminal to CODING-SYSTEM.
1216 All text output to the terminal will be encoded
1217 with the specified coding system.
1218 For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems].
1219 The default is determined by the selected language environment
1220 or by the previous use of this command."
1222 (list (let ((default (if (and (not (terminal-coding-system))
1223 default-terminal-coding-system)
1224 default-terminal-coding-system)))
1226 (format "Coding system for terminal display (default %s): "
1229 (if (and (not coding-system)
1230 (not (terminal-coding-system)))
1231 (setq coding-system default-terminal-coding-system))
1233 (setq default-terminal-coding-system coding-system))
1234 (set-terminal-coding-system-internal coding-system)
1235 (redraw-frame (selected-frame)))
1237 (defvar default-keyboard-coding-system nil
1238 "Default value of the keyboard coding system.
1239 This is normally set according to the selected language environment.
1240 See also the command `set-keyboard-coding-system'.")
1242 (defun set-keyboard-coding-system (coding-system)
1243 "Set coding system for keyboard input to CODING-SYSTEM.
1244 In addition, this command enables Encoded-kbd minor mode.
1245 \(If CODING-SYSTEM is nil, Encoded-kbd mode is turned off -- see
1246 `encoded-kbd-mode'.)
1247 For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems].
1248 The default is determined by the selected language environment
1249 or by the previous use of this command."
1251 (list (let ((default (if (and (not (keyboard-coding-system))
1252 default-keyboard-coding-system)
1253 default-keyboard-coding-system)))
1255 (format "Coding system for keyboard input (default %s): "
1258 (if (and (not coding-system)
1259 (not (keyboard-coding-system)))
1260 (setq coding-system default-keyboard-coding-system))
1262 (setq default-keyboard-coding-system coding-system))
1263 (if (and coding-system
1264 (not (coding-system-get coding-system :ascii-compatible-p))
1265 (not (coding-system-get coding-system :suitable-for-keyboard)))
1266 (error "%s is not suitable for keyboard" coding-system))
1267 (set-keyboard-coding-system-internal coding-system)
1268 (setq keyboard-coding-system coding-system)
1269 (encoded-kbd-mode (if coding-system 1 0)))
1271 (defcustom keyboard-coding-system nil
1272 "Specify coding system for keyboard input.
1273 If you set this on a terminal which can't distinguish Meta keys from
1274 8-bit characters, you will have to use ESC to type Meta characters.
1275 See Info node `Terminal Coding' and Info node `Unibyte Mode'.
1277 On non-windowing terminals, this is set from the locale by default.
1279 Setting this variable directly does not take effect;
1280 use either \\[customize] or \\[set-keyboard-coding-system]."
1281 :type '(coding-system :tag "Coding system")
1282 :link '(info-link "(emacs)Terminal Coding")
1283 :link '(info-link "(emacs)Unibyte Mode")
1284 :set (lambda (symbol value)
1285 ;; Don't load encoded-kbd-mode unnecessarily.
1286 (if (or value (boundp 'encoded-kbd-mode))
1287 (set-keyboard-coding-system value)
1288 (set-default 'keyboard-coding-system nil))) ; must initialize
1293 (defun set-buffer-process-coding-system (decoding encoding)
1294 "Set coding systems for the process associated with the current buffer.
1295 DECODING is the coding system to be used to decode input from the process,
1296 ENCODING is the coding system to be used to encode output to the process.
1298 For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems]."
1300 "zCoding-system for output from the process: \nzCoding-system for input to the process: ")
1301 (let ((proc (get-buffer-process (current-buffer))))
1303 (error "No process")
1304 (check-coding-system decoding)
1305 (check-coding-system encoding)
1306 (set-process-coding-system proc decoding encoding)))
1307 (force-mode-line-update))
1309 (defalias 'set-clipboard-coding-system 'set-selection-coding-system)
1311 (defun set-selection-coding-system (coding-system)
1312 "Make CODING-SYSTEM used for communicating with other X clients.
1313 When sending or receiving text via cut_buffer, selection, and clipboard,
1314 the text is encoded or decoded by CODING-SYSTEM."
1315 (interactive "zCoding system for X selection: ")
1316 (check-coding-system coding-system)
1317 (setq selection-coding-system coding-system))
1319 ;; Coding system lastly specified by the command
1320 ;; set-next-selection-coding-system.
1321 (defvar last-next-selection-coding-system nil)
1323 (defun set-next-selection-coding-system (coding-system)
1324 "Use CODING-SYSTEM for next communication with other window system clients.
1325 This setting is effective for the next communication only."
1327 (list (read-coding-system
1328 (if last-next-selection-coding-system
1329 (format "Coding system for the next selection (default %S): "
1330 last-next-selection-coding-system)
1331 "Coding system for the next selection: ")
1332 last-next-selection-coding-system)))
1334 (setq last-next-selection-coding-system coding-system)
1335 (setq coding-system last-next-selection-coding-system))
1336 (check-coding-system coding-system)
1338 (setq next-selection-coding-system coding-system))
1340 (defun set-coding-priority (arg)
1341 "Set priority of coding categories according to ARG.
1342 ARG is a list of coding categories ordered by priority.
1344 This function is provided for backward compatibility.
1345 Now we have more convenient function `set-coding-system-priority'."
1346 (apply 'set-coding-system-priority
1347 (mapcar #'(lambda (x) (symbol-value x)) arg)))
1348 (make-obsolete 'set-coding-priority 'set-coding-system-priority "23.1")
1352 (defvar ctext-non-standard-encodings-alist
1353 '(("big5-0" big5 2 big5)
1354 ("ISO8859-14" iso-8859-14 1 latin-iso8859-14)
1355 ("ISO8859-15" iso-8859-15 1 latin-iso8859-15)
1356 ("gbk-0" gbk 2 chinese-gbk))
1357 "Alist of non-standard encoding names vs the corresponding usages in CTEXT.
1359 It controls how extended segments of a compound text are handled
1360 by the coding system `compound-text-with-extensions'.
1362 Each element has the form (ENCODING-NAME CODING-SYSTEM N-OCTET CHARSET).
1364 ENCODING-NAME is an encoding name of an \"extended segments\".
1366 CODING-SYSTEM is the coding-system to encode (or decode) the
1367 characters into (or from) the extended segment.
1369 N-OCTET is the number of octets (bytes) that encodes a character
1370 in the segment. It can be 0 (meaning the number of octets per
1371 character is variable), 1, 2, 3, or 4.
1373 CHARSET is a charater set containing characters that are encoded
1374 in the segment. It can be a list of character sets.
1376 On decoding CTEXT, all encoding names listed here are recognized.
1378 On encoding CTEXT, encoding names in the variable
1379 `ctext-non-standard-encodings' (which see) and in the information
1380 listed for the current language environment under the key
1381 `ctext-non-standard-encodings' are used.")
1383 (defvar ctext-non-standard-encodings nil
1384 "List of non-standard encoding names used in extended segments of CTEXT.
1385 Each element must be one of the names listed in the variable
1386 `ctext-non-standard-encodings-alist' (which see).")
1388 (defvar ctext-non-standard-encodings-regexp
1389 (string-to-multibyte
1391 ;; For non-standard encodings.
1392 "\\(\e%/[0-4][\200-\377][\200-\377]\\([^\002]+\\)\002\\)"
1394 ;; For UTF-8 encoding.
1395 "\\(\e%G[^\e]*\e%@\\)")))
1397 ;; Functions to support "Non-Standard Character Set Encodings" defined
1398 ;; by the COMPOUND-TEXT spec. They also support "The UTF-8 encoding"
1399 ;; described in the section 7 of the documentation of COMPOUND-TEXT
1400 ;; distributed with XFree86.
1402 (defun ctext-post-read-conversion (len)
1403 "Decode LEN characters encoded as Compound Text with Extended Segments."
1404 ;; We don't need the following because it is expected that this
1405 ;; function is mainly used for decoding X selection which is not
1407 ;;(buffer-disable-undo) ; minimize consing due to insertions and deletions
1410 (narrow-to-region (point) (+ (point) len))
1411 (let ((case-fold-search nil)
1412 last-coding-system-used
1414 (decode-coding-region (point-min) (point-max) 'ctext)
1415 (while (re-search-forward ctext-non-standard-encodings-regexp
1417 (setq pos (match-beginning 0))
1418 (if (match-beginning 1)
1419 ;; ESC % / [0-4] M L --ENCODING-NAME-- \002 --BYTES--
1420 (let* ((M (multibyte-char-to-unibyte (char-after (+ pos 4))))
1421 (L (multibyte-char-to-unibyte (char-after (+ pos 5))))
1422 (encoding (match-string 2))
1423 (encoding-info (assoc-string
1425 ctext-non-standard-encodings-alist t))
1426 (coding (if encoding-info
1427 (nth 1 encoding-info)
1428 (setq encoding (intern (downcase encoding)))
1429 (and (coding-system-p encoding)
1431 (setq bytes (- (+ (* (- M 128) 128) (- L 128))
1432 (- (point) (+ pos 6))))
1434 (delete-region pos (point))
1435 (forward-char bytes)
1436 (decode-coding-region (- (point) bytes) (point) coding)))
1437 ;; ESC % G --UTF-8-BYTES-- ESC % @
1439 (delete-region pos (+ pos 3))
1440 (decode-coding-region pos (point) 'utf-8))))
1441 (goto-char (point-min))
1442 (- (point-max) (point)))))
1444 ;; Return an alist of CHARSET vs CTEXT-USAGE-INFO generated from
1445 ;; `ctext-non-standard-encodings' and a list specified by the key
1446 ;; `ctext-non-standard-encodings' for the currrent language
1447 ;; environment. CTEXT-USAGE-INFO is one of the element of
1448 ;; `ctext-non-standard-encodings-alist' or nil. In the former case, a
1449 ;; character in CHARSET is encoded using extended segment. In the
1450 ;; latter case, a character in CHARSET is encoded using normal ISO2022
1451 ;; designation sequence. If a character is not in any of CHARSETs, it
1452 ;; is encoded using UTF-8 encoding extention.
1454 (defun ctext-non-standard-encodings-table ()
1456 ;; Setup charsets specified by the key
1457 ;; `ctext-non-standard-encodings' for the current language
1458 ;; environment and in `ctext-non-standard-encodings'.
1459 (dolist (encoding (append
1460 (get-language-info current-language-environment
1461 'ctext-non-standard-encodings)
1462 ctext-non-standard-encodings))
1463 (let* ((slot (assoc encoding ctext-non-standard-encodings-alist))
1464 (charset (nth 3 slot)))
1465 (if (charsetp charset)
1466 (push (cons charset slot) table)
1467 (dolist (cs charset)
1468 (push (cons cs slot) table)))))
1470 ;; Next prepend charsets for ISO2022 designation sequence.
1471 (dolist (charset charset-list)
1472 (let ((final (plist-get (charset-plist charset) :iso-final-char)))
1473 (if (and (integerp final)
1474 (>= final #x40) (<= final #x7e)
1475 ;; Exclude ascii and chinese-cns11643-X.
1476 (not (eq charset 'ascii))
1477 (not (string-match "cns11643" (symbol-name charset))))
1478 (push (cons charset nil) table))))
1480 ;; Returned reversed list so that the charsets specified by the
1481 ;; key `ctext-non-standard-encodings' for the current language
1482 ;; have the highest priority.
1485 (defun ctext-pre-write-conversion (from to)
1486 "Encode characters between FROM and TO as Compound Text w/Extended Segments.
1488 If FROM is a string, or if the current buffer is not the one set up for us
1489 by encode-coding-string, generate a new temp buffer, insert the
1490 text, and convert it in the temporary buffer. Otherwise, convert in-place."
1492 ;; Setup a working buffer if necessary.
1493 (when (stringp from)
1494 (set-buffer (generate-new-buffer " *temp"))
1495 (set-buffer-multibyte (multibyte-string-p from))
1498 ;; Now we can encode the whole buffer.
1499 (let ((encoding-table (ctext-non-standard-encodings-table))
1500 last-coding-system-used
1501 last-pos last-encoding-info
1502 encoding-info end-pos ch)
1503 (goto-char (setq last-pos (point-min)))
1504 (setq end-pos (point-marker))
1505 (while (re-search-forward "[^\000-\177]+" nil t)
1506 ;; Found a sequence of non-ASCII characters.
1507 (setq last-pos (match-beginning 0)
1508 ch (char-after last-pos)
1509 last-encoding-info (catch 'tag
1510 (dolist (elt encoding-table)
1511 (if (encode-char ch (car elt))
1512 (throw 'tag (cdr elt))))
1514 (set-marker end-pos (match-end 0))
1515 (goto-char (1+ last-pos))
1519 (if (< (point) end-pos)
1521 (setq ch (following-char))
1522 (dolist (elt encoding-table)
1523 (if (encode-char ch (car elt))
1524 (throw 'tag (cdr elt))))
1526 (unless (eq last-encoding-info encoding-info)
1527 (cond ((consp last-encoding-info)
1528 ;; Encode the previous range using an extended
1530 (let ((encoding-name (car last-encoding-info))
1531 (coding-system (nth 1 last-encoding-info))
1532 (noctets (nth 2 last-encoding-info))
1534 (encode-coding-region last-pos (point) coding-system)
1535 (setq len (+ (length encoding-name) 1
1536 (- (point) last-pos)))
1537 ;; According to the spec of CTEXT, it is not
1538 ;; necessary to produce this extra designation
1539 ;; sequence, but some buggy application
1540 ;; (e.g. crxvt-gb) requires it.
1543 (goto-char last-pos)
1544 (insert (format "\e%%/%d" noctets))
1545 (insert-byte (+ (/ len 128) 128) 1)
1546 (insert-byte (+ (% len 128) 128) 1)
1547 (insert encoding-name)
1549 ((eq last-encoding-info 'utf-8)
1550 ;; Encode the previous range using UTF-8 encoding
1552 (encode-coding-region last-pos (point) 'mule-utf-8)
1554 (goto-char last-pos)
1557 (setq last-pos (point)
1558 last-encoding-info encoding-info))
1559 (if (< (point) end-pos)
1561 (throw 'tag nil)))))
1562 (set-marker end-pos nil)
1563 (goto-char (point-min))))
1564 ;; Must return nil, as build_annotations_2 expects that.
1569 (defcustom auto-coding-alist
1570 ;; .exe and .EXE are added to support archive-mode looking at DOS
1571 ;; self-extracting exe archives.
1572 '(("\\.\\(arc\\|zip\\|lzh\\|lha\\|zoo\\|[jew]ar\\|xpi\\|exe\\)\\'" . no-conversion)
1573 ("\\.\\(ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|EXE\\)\\'" . no-conversion)
1574 ("\\.\\(sx[dmicw]\\|odt\\|tar\\|tgz\\)\\'" . no-conversion)
1575 ("\\.\\(gz\\|Z\\|bz\\|bz2\\|gpg\\)\\'" . no-conversion)
1576 ("\\.\\(jpe?g\\|png\\|gif\\|tiff?\\|p[bpgn]m\\)\\'" . no-conversion)
1577 ("\\.pdf\\'" . no-conversion)
1578 ("/#[^/]+#\\'" . emacs-mule))
1579 "Alist of filename patterns vs corresponding coding systems.
1580 Each element looks like (REGEXP . CODING-SYSTEM).
1581 A file whose name matches REGEXP is decoded by CODING-SYSTEM on reading.
1583 The settings in this alist take priority over `coding:' tags
1584 in the file (see the function `set-auto-coding')
1585 and the contents of `file-coding-system-alist'."
1588 :type '(repeat (cons (regexp :tag "File name regexp")
1589 (symbol :tag "Coding system"))))
1591 (defcustom auto-coding-regexp-alist
1592 '(("^BABYL OPTIONS:[ \t]*-\\*-[ \t]*rmail[ \t]*-\\*-" . no-conversion)
1593 ("\\`\xFE\xFF" . utf-16be-with-signature)
1594 ("\\`\xFF\xFE" . utf-16le-with-signature)
1595 ("\\`\xEF\xBB\xBF" . utf-8)
1596 ("\\`;ELC\024\0\0\0" . emacs-mule)) ; Emacs 20-compiled
1597 "Alist of patterns vs corresponding coding systems.
1598 Each element looks like (REGEXP . CODING-SYSTEM).
1599 A file whose first bytes match REGEXP is decoded by CODING-SYSTEM on reading.
1601 The settings in this alist take priority over `coding:' tags
1602 in the file (see the function `set-auto-coding')
1603 and the contents of `file-coding-system-alist'."
1606 :type '(repeat (cons (regexp :tag "Regexp")
1607 (symbol :tag "Coding system"))))
1609 (defun auto-coding-regexp-alist-lookup (from to)
1610 "Lookup `auto-coding-regexp-alist' for the contents of the current buffer.
1611 The value is a coding system is specified for the region FROM and TO,
1615 (let ((alist auto-coding-regexp-alist)
1617 (while (and alist (not coding-system))
1618 (let ((regexp (car (car alist))))
1619 (if enable-multibyte-characters
1620 (setq regexp (string-to-multibyte regexp)))
1621 (if (re-search-forward regexp to t)
1622 (setq coding-system (cdr (car alist)))
1623 (setq alist (cdr alist)))))
1626 ;; See the bottom of this file for built-in auto coding functions.
1627 (defcustom auto-coding-functions '(sgml-xml-auto-coding-function
1628 sgml-html-meta-auto-coding-function)
1629 "A list of functions which attempt to determine a coding system.
1631 Each function in this list should be written to operate on the
1632 current buffer, but should not modify it in any way. The buffer
1633 will contain undecoded text of parts of the file. Each function
1634 should take one argument, SIZE, which says how many
1635 characters (starting from point) it should look at.
1637 If one of these functions succeeds in determining a coding
1638 system, it should return that coding system. Otherwise, it
1641 If a file has a `coding:' tag, that takes precedence over these
1642 functions, so they won't be called at all."
1645 :type '(repeat function))
1647 (defvar set-auto-coding-for-load nil
1648 "Non-nil means look for `load-coding' property instead of `coding'.
1649 This is used for loading and byte-compiling Emacs Lisp files.")
1651 (defun auto-coding-alist-lookup (filename)
1652 "Return the coding system specified by `auto-coding-alist' for FILENAME."
1653 (let ((alist auto-coding-alist)
1654 (case-fold-search (memq system-type '(vax-vms windows-nt ms-dos cygwin)))
1656 (while (and alist (not coding-system))
1657 (if (string-match (car (car alist)) filename)
1658 (setq coding-system (cdr (car alist)))
1659 (setq alist (cdr alist))))
1662 (put 'enable-character-translation 'permanent-local t)
1663 (put 'enable-character-translation 'safe-local-variable 'booleanp)
1665 (defun find-auto-coding (filename size)
1666 "Find a coding system for a file FILENAME of which SIZE bytes follow point.
1667 These bytes should include at least the first 1k of the file
1668 and the last 3k of the file, but the middle may be omitted.
1670 The function checks FILENAME against the variable `auto-coding-alist'.
1671 If FILENAME doesn't match any entries in the variable, it checks the
1672 contents of the current buffer following point against
1673 `auto-coding-regexp-alist'. If no match is found, it checks for a
1674 `coding:' tag in the first one or two lines following point. If no
1675 `coding:' tag is found, it checks any local variables list in the last
1676 3K bytes out of the SIZE bytes. Finally, if none of these methods
1677 succeed, it checks to see if any function in `auto-coding-functions'
1680 If a coding system is specifed, the return value is a
1681 cons (CODING . SOURCE), where CODING is the specified coding
1682 system and SOURCE is a symbol `auto-coding-alist',
1683 `auto-coding-regexp-alist', `coding:', or `auto-coding-functions'
1684 indicating by what CODING is specified. Note that the validity
1685 of CODING is not checked; it's the caller's responsibility to check it.
1687 If nothing is specified, the return value is nil."
1688 (or (let ((coding-system (auto-coding-alist-lookup filename)))
1690 (cons coding-system 'auto-coding-alist)))
1691 ;; Try using `auto-coding-regexp-alist'.
1692 (let ((coding-system (auto-coding-regexp-alist-lookup (point)
1695 (cons coding-system 'auto-coding-regexp-alist)))
1696 (let* ((case-fold-search t)
1697 (head-start (point))
1698 (head-end (+ head-start (min size 1024)))
1699 (tail-start (+ head-start (max (- size 3072) 0)))
1700 (tail-end (+ head-start size))
1701 coding-system head-found tail-found pos char-trans)
1702 ;; Try a short cut by searching for the string "coding:"
1703 ;; and for "unibyte:" at the head and tail of SIZE bytes.
1704 (setq head-found (or (search-forward "coding:" head-end t)
1705 (search-forward "unibyte:" head-end t)
1706 (search-forward "enable-character-translation:"
1708 (if (and head-found (> head-found tail-start))
1709 ;; Head and tail are overlapped.
1710 (setq tail-found head-found)
1711 (goto-char tail-start)
1712 (setq tail-found (or (search-forward "coding:" tail-end t)
1713 (search-forward "unibyte:" tail-end t)
1714 (search-forward "enable-character-translation:"
1717 ;; At first check the head.
1719 (goto-char head-start)
1720 (setq head-end (set-auto-mode-1))
1721 (setq head-start (point))
1722 (when (and head-end (< head-found head-end))
1723 (goto-char head-start)
1724 (when (and set-auto-coding-for-load
1726 "\\(.*;\\)?[ \t]*unibyte:[ \t]*\\([^ ;]+\\)"
1728 (setq coding-system 'raw-text))
1729 (when (and (not coding-system)
1731 "\\(.*;\\)?[ \t]*coding:[ \t]*\\([^ ;]+\\)"
1733 (setq coding-system (intern (match-string 2))))
1734 (when (re-search-forward
1735 "\\(.*;\\)?[ \t]*enable-character-translation:[ \t]*\\([^ ;]+\\)"
1737 (setq char-trans (match-string 2)))))
1739 ;; If no coding: tag in the head, check the tail.
1740 ;; Here we must pay attention to the case that the end-of-line
1741 ;; is just "\r" and we can't use "^" nor "$" in regexp.
1742 (when (and tail-found (or (not coding-system) (not char-trans)))
1743 (goto-char tail-start)
1744 (re-search-forward "[\r\n]\^L" tail-end t)
1745 (if (re-search-forward
1746 "[\r\n]\\([^[\r\n]*\\)[ \t]*Local Variables:[ \t]*\\([^\r\n]*\\)[\r\n]"
1748 ;; The prefix is what comes before "local variables:" in its
1749 ;; line. The suffix is what comes after "local variables:"
1751 (let* ((prefix (regexp-quote (match-string 1)))
1752 (suffix (regexp-quote (match-string 2)))
1756 ;; N.B. without the \n below, the regexp can
1758 "[ \t]*coding[ \t]*:[ \t]*\\([^ \t\r\n]+\\)[ \t]*"
1763 "[ \t]*unibyte[ \t]*:[ \t]*\\([^ \t\r\n]+\\)[ \t]*"
1768 "[ \t]*enable-character-translation[ \t]*:[ \t]*\\([^ \t\r\n]+\\)[ \t]*"
1771 (concat "[\r\n]" prefix "[ \t]*End *:[ \t]*" suffix
1774 (forward-char -1) ; skip back \r or \n.
1775 (re-search-forward re-end tail-end 'move)
1776 (setq tail-end (point))
1778 (when (and set-auto-coding-for-load
1779 (re-search-forward re-unibyte tail-end t))
1780 (setq coding-system 'raw-text))
1781 (when (and (not coding-system)
1782 (re-search-forward re-coding tail-end t))
1783 (setq coding-system (intern (match-string 1))))
1784 (when (and (not char-trans)
1785 (re-search-forward re-char-trans tail-end t))
1786 (setq char-trans (match-string 1))))))
1788 ;; If the coding-system name ends with "!", remove it and
1789 ;; set char-trans to "nil".
1790 (let ((name (symbol-name coding-system)))
1791 (if (= (aref name (1- (length name))) ?!)
1792 (setq coding-system (intern (substring name 0 -1))
1793 char-trans "nil"))))
1794 (when (and char-trans
1795 (not (setq char-trans (intern char-trans))))
1796 (make-local-variable 'enable-character-translation)
1797 (setq enable-character-translation nil))
1799 (cons coding-system :coding)))
1800 ;; Finally, try all the `auto-coding-functions'.
1801 (let ((funcs auto-coding-functions)
1802 (coding-system nil))
1803 (while (and funcs (not coding-system))
1804 (setq coding-system (condition-case e
1806 (goto-char (point-min))
1807 (funcall (pop funcs) size))
1810 (cons coding-system 'auto-coding-functions)))))
1812 (defun set-auto-coding (filename size)
1813 "Return coding system for a file FILENAME of which SIZE bytes follow point.
1814 See `find-auto-coding' for how the coding system is found.
1815 Return nil if an invalid coding system is found.
1817 The variable `set-auto-coding-function' (which see) is set to this
1818 function by default."
1819 (let ((found (find-auto-coding filename size)))
1820 (if (and found (coding-system-p (car found)))
1823 (setq set-auto-coding-function 'set-auto-coding)
1825 ;; This variable is set in these two cases:
1826 ;; (1) A file is read by a coding system specified explicitly.
1827 ;; after-insert-file-set-coding sets this value to
1828 ;; coding-system-for-read.
1829 ;; (2) A buffer is saved.
1830 ;; After writing, basic-save-buffer-1 sets this value to
1831 ;; last-coding-system-used.
1832 ;; This variable is used for decoding in revert-buffer.
1833 (defvar buffer-file-coding-system-explicit nil
1834 "The file coding system explicitly specified for the current buffer.
1835 Internal use only.")
1836 (make-variable-buffer-local 'buffer-file-coding-system-explicit)
1837 (put 'buffer-file-coding-system-explicit 'permanent-local t)
1839 (defun after-insert-file-set-coding (inserted &optional visit)
1840 "Set `buffer-file-coding-system' of current buffer after text is inserted.
1841 INSERTED is the number of characters that were inserted, as figured
1842 in the situation before this function. Return the number of characters
1843 inserted, as figured in the situation after. The two numbers can be
1844 different if the buffer has become unibyte.
1845 The optional second arg VISIT non-nil means that we are visiting a file."
1847 coding-system-for-read
1848 (not (eq coding-system-for-read 'auto-save-coding)))
1849 (setq buffer-file-coding-system-explicit coding-system-for-read))
1850 (if last-coding-system-used
1851 (let ((coding-system
1852 (find-new-buffer-file-coding-system last-coding-system-used)))
1854 ;; Tell set-buffer-file-coding-system not to mark the file
1855 ;; as modified; we just read it, and it's supposed to be unmodified.
1856 ;; Marking it modified would try to lock it, which would
1857 ;; check the modtime, and we don't want to do that again now.
1858 (set-buffer-file-coding-system coding-system t t))))
1861 ;; The coding-spec and eol-type of coding-system returned is decided
1862 ;; independently in the following order.
1863 ;; 1. That of buffer-file-coding-system locally bound.
1864 ;; 2. That of CODING.
1866 (defun find-new-buffer-file-coding-system (coding)
1867 "Return a coding system for a buffer when a file of CODING is inserted.
1868 The local variable `buffer-file-coding-system' of the current buffer
1869 is set to the returned value.
1870 Return nil if there's no need to set `buffer-file-coding-system'."
1871 (let (local-coding local-eol
1872 found-coding found-eol
1875 ;; Nothing found about coding.
1878 ;; Get information of `buffer-file-coding-system' in LOCAL-EOL
1879 ;; and LOCAL-CODING.
1880 (setq local-eol (coding-system-eol-type buffer-file-coding-system))
1881 (if (null (numberp local-eol))
1882 ;; But eol-type is not yet set.
1883 (setq local-eol nil))
1884 (if (and buffer-file-coding-system
1885 (not (eq (coding-system-type buffer-file-coding-system)
1887 (setq local-coding (coding-system-base buffer-file-coding-system)))
1889 (if (and (local-variable-p 'buffer-file-coding-system)
1890 local-eol local-coding)
1891 ;; The current buffer has already set full coding-system, we
1892 ;; had better not change it.
1895 (setq found-eol (coding-system-eol-type coding))
1896 (if (null (numberp found-eol))
1897 ;; But eol-type is not found.
1898 ;; If EOL conversions are inhibited, force unix eol-type.
1899 (setq found-eol (if inhibit-eol-conversion 0)))
1900 (setq found-coding (coding-system-base coding))
1902 (if (and (not found-eol) (eq found-coding 'undecided))
1903 ;; No valid coding information found.
1906 ;; Some coding information (eol or text) found.
1908 ;; The local setting takes precedence over the found one.
1909 (setq new-coding (if (local-variable-p 'buffer-file-coding-system)
1910 (or local-coding found-coding)
1911 (or found-coding local-coding)))
1912 (setq new-eol (if (local-variable-p 'buffer-file-coding-system)
1913 (or local-eol found-eol)
1914 (or found-eol local-eol)))
1916 (let ((eol-type (coding-system-eol-type new-coding)))
1917 (if (and (numberp new-eol) (vectorp eol-type))
1918 (aref eol-type new-eol)
1921 (defun modify-coding-system-alist (target-type regexp coding-system)
1922 "Modify one of look up tables for finding a coding system on I/O operation.
1923 There are three of such tables, `file-coding-system-alist',
1924 `process-coding-system-alist', and `network-coding-system-alist'.
1926 TARGET-TYPE specifies which of them to modify.
1927 If it is `file', it affects `file-coding-system-alist' (which see).
1928 If it is `process', it affects `process-coding-system-alist' (which see).
1929 If it is `network', it affects `network-coding-system-alist' (which see).
1931 REGEXP is a regular expression matching a target of I/O operation.
1932 The target is a file name if TARGET-TYPE is `file', a program name if
1933 TARGET-TYPE is `process', or a network service name or a port number
1934 to connect to if TARGET-TYPE is `network'.
1936 CODING-SYSTEM is a coding system to perform code conversion on the I/O
1937 operation, or a cons cell (DECODING . ENCODING) specifying the coding systems
1938 for decoding and encoding respectively,
1939 or a function symbol which, when called, returns such a cons cell."
1940 (or (memq target-type '(file process network))
1941 (error "Invalid target type: %s" target-type))
1942 (or (stringp regexp)
1943 (and (eq target-type 'network) (integerp regexp))
1944 (error "Invalid regular expression: %s" regexp))
1945 (if (symbolp coding-system)
1946 (if (not (fboundp coding-system))
1948 (check-coding-system coding-system)
1949 (setq coding-system (cons coding-system coding-system))))
1950 (check-coding-system (car coding-system))
1951 (check-coding-system (cdr coding-system)))
1952 (cond ((eq target-type 'file)
1953 (let ((slot (assoc regexp file-coding-system-alist)))
1955 (setcdr slot coding-system)
1956 (setq file-coding-system-alist
1957 (cons (cons regexp coding-system)
1958 file-coding-system-alist)))))
1959 ((eq target-type 'process)
1960 (let ((slot (assoc regexp process-coding-system-alist)))
1962 (setcdr slot coding-system)
1963 (setq process-coding-system-alist
1964 (cons (cons regexp coding-system)
1965 process-coding-system-alist)))))
1967 (let ((slot (assoc regexp network-coding-system-alist)))
1969 (setcdr slot coding-system)
1970 (setq network-coding-system-alist
1971 (cons (cons regexp coding-system)
1972 network-coding-system-alist)))))))
1974 (defun decode-coding-inserted-region (from to filename
1975 &optional visit beg end replace)
1976 "Decode the region between FROM and TO as if it is read from file FILENAME.
1977 The idea is that the text between FROM and TO was just inserted somehow.
1978 Optional arguments VISIT, BEG, END, and REPLACE are the same as those
1979 of the function `insert-file-contents'.
1980 Part of the job of this function is setting `buffer-undo-list' appropriately."
1983 (let ((coding coding-system-for-read)
1986 ;; Temporarily turn off undo recording, if we're decoding the
1987 ;; text of a visited file.
1988 (setq buffer-undo-list t)
1989 ;; Otherwise, if we can recognize the undo elt for the insertion,
1990 ;; remove it and get ready to replace it later.
1991 ;; In the mean time, turn off undo recording.
1992 (let ((last (car-safe buffer-undo-list)))
1993 (if (and (consp last) (eql (car last) from) (eql (cdr last) to))
1994 (setq undo-list-saved (cdr buffer-undo-list)
1995 buffer-undo-list t))))
1996 (narrow-to-region from to)
1997 (goto-char (point-min))
1999 (setq coding (funcall set-auto-coding-function
2000 filename (- (point-max) (point-min)))))
2002 (setq coding (car (find-operation-coding-system
2003 'insert-file-contents
2004 (cons filename (current-buffer))
2005 visit beg end replace))))
2006 (if (coding-system-p coding)
2007 (or enable-multibyte-characters
2009 (coding-system-change-text-conversion coding 'raw-text)))
2012 (decode-coding-region (point-min) (point-max) coding)
2013 (setq last-coding-system-used coding))
2014 ;; If we're decoding the text of a visited file,
2015 ;; the undo list should start out empty.
2017 (setq buffer-undo-list nil)
2018 ;; If we decided to replace the undo entry for the insertion,
2021 (setq buffer-undo-list
2022 (cons (cons from (point-max)) undo-list-saved))))))))
2024 (defun recode-region (start end new-coding coding)
2025 "Re-decode the region (previously decoded by CODING) by NEW-CODING."
2027 (list (region-beginning) (region-end)
2028 (read-coding-system "Text was really in: ")
2029 (let ((coding (or buffer-file-coding-system last-coding-system-used)))
2031 (concat "But was interpreted as"
2032 (if coding (format " (default %S): " coding) ": "))
2034 (or (and new-coding coding)
2035 (error "Coding system not specified"))
2036 ;; Check it before we encode the region.
2037 (check-coding-system new-coding)
2039 (narrow-to-region start end)
2040 (encode-coding-region (point-min) (point-max) coding)
2041 (decode-coding-region (point-min) (point-max) new-coding)))
2043 (defun make-translation-table (&rest args)
2044 "Make a translation table from arguments.
2045 A translation table is a char table intended for character
2046 translation in CCL programs.
2048 Each argument is a list of elements of the form (FROM . TO), where FROM
2049 is a character to be translated to TO.
2051 The arguments and forms in each argument are processed in the given
2052 order, and if a previous form already translates TO to some other
2053 character, say TO-ALT, FROM is also translated to TO-ALT."
2054 (let ((table (make-char-table 'translation-table))
2058 (let ((from (car elt))
2060 to-alt rev-from rev-to)
2061 ;; If we have already translated TO to TO-ALT, FROM should
2062 ;; also be translated to TO-ALT.
2063 (if (setq to-alt (aref table to))
2065 (aset table from to)
2066 ;; If we have already translated some chars to FROM, they
2067 ;; should also be translated to TO.
2068 (when (setq rev-from (assq from revlist))
2069 (dolist (elt (cdr rev-from))
2070 (aset table elt to))
2071 (setq revlist (delq rev-from revlist)
2072 rev-from (cdr rev-from)))
2073 ;; Now update REVLIST.
2074 (setq rev-to (assq to revlist))
2076 (setcdr rev-to (cons from (cdr rev-to)))
2077 (setq rev-to (list to from)
2078 revlist (cons rev-to revlist)))
2080 (setcdr rev-to (append rev-from (cdr rev-to)))))))
2081 ;; Return TABLE just created.
2082 (set-char-table-extra-slot table 1 1)
2085 (defun make-translation-table-from-vector (vec)
2086 "Make translation table from decoding vector VEC.
2087 VEC is an array of 256 elements to map unibyte codes to multibyte
2088 characters. Elements may be nil for undefined code points.
2089 See also the variable `nonascii-translation-table'."
2090 (let ((table (make-char-table 'translation-table))
2091 (rev-table (make-char-table 'translation-table))
2094 (setq ch (aref vec i))
2098 (aset rev-table ch i))))
2099 (set-char-table-extra-slot table 0 rev-table)
2100 (set-char-table-extra-slot table 1 1)
2101 (set-char-table-extra-slot rev-table 1 1)
2104 (defun make-translation-table-from-alist (alist)
2105 "Make translation table from N<->M mapping in ALIST.
2106 ALIST is an alist, each element has the form (FROM . TO).
2107 FROM and TO are a character or a vector of characters.
2108 If FROM is a character, that character is translated to TO.
2109 If FROM is a vector of characters, that sequence is translated to TO.
2110 The first extra-slot of the value is a translation table for reverse mapping."
2111 (let ((tables (vector (make-char-table 'translation-table)
2112 (make-char-table 'translation-table)))
2113 table max-lookup from to idx val)
2115 (setq table (aref tables i))
2119 (setq from (car elt) to (cdr elt))
2120 (setq from (cdr elt) to (car elt)))
2121 (if (characterp from)
2123 (setq idx (aref from 0)
2124 max-lookup (max max-lookup (length from))))
2125 (setq val (aref table idx))
2129 (setq val (list (cons (vector idx) val))))
2130 (if (characterp from)
2131 (setq from (vector from)))
2132 (setq val (nconc val (list (cons from to)))))
2133 (if (characterp from)
2135 (setq val (list (cons from to)))))
2136 (aset table idx val))
2137 (set-char-table-extra-slot table 1 max-lookup))
2138 (set-char-table-extra-slot (aref tables 0) 0 (aref tables 1))
2141 (defun define-translation-table (symbol &rest args)
2142 "Define SYMBOL as the name of translation table made by ARGS.
2143 This sets up information so that the table can be used for
2144 translations in a CCL program.
2146 If the first element of ARGS is a char-table whose purpose is
2147 `translation-table', just define SYMBOL to name it. (Note that this
2148 function does not bind SYMBOL.)
2150 Any other ARGS should be suitable as arguments of the function
2151 `make-translation-table' (which see).
2153 This function sets properties `translation-table' and
2154 `translation-table-id' of SYMBOL to the created table itself and the
2155 identification number of the table respectively. It also registers
2156 the table in `translation-table-vector'."
2157 (let ((table (if (and (char-table-p (car args))
2158 (eq (char-table-subtype (car args))
2159 'translation-table))
2161 (apply 'make-translation-table args)))
2162 (len (length translation-table-vector))
2165 (put symbol 'translation-table table)
2168 (setq translation-table-vector
2169 (vconcat translation-table-vector (make-vector len nil))))
2170 (let ((slot (aref translation-table-vector id)))
2172 (eq (car slot) symbol))
2174 (aset translation-table-vector id (cons symbol table))
2176 (setq id (1+ id)))))
2177 (put symbol 'translation-table-id id)
2180 (defun translate-region (start end table)
2181 "From START to END, translate characters according to TABLE.
2182 TABLE is a string or a char-table.
2183 If TABLE is a string, the Nth character in it is the mapping
2184 for the character with code N.
2185 If TABLE is a char-table, the element for character N is the mapping
2186 for the character with code N.
2187 It returns the number of characters changed."
2189 (list (region-beginning)
2192 (dotimes (i (length translation-table-vector))
2193 (if (consp (aref translation-table-vector i))
2194 (push (list (symbol-name
2195 (car (aref translation-table-vector i)))) l)))
2197 (error "No translation table defined"))
2199 (setq table (completing-read "Translation table: " l nil t)))
2202 (let ((val (get table 'translation-table)))
2203 (or (char-table-p val)
2204 (error "Invalid translation table name: %s" table))
2206 (translate-region-internal start end table))
2208 (put 'with-category-table 'lisp-indent-function 1)
2210 (defmacro with-category-table (table &rest body)
2211 "Execute BODY like `progn' with CATEGORY-TABLE the current category table.
2212 The category table of the current buffer is saved, BODY is evaluated,
2213 then the saved table is restored, even in case of an abnormal exit.
2214 Value is what BODY returns."
2215 (let ((old-table (make-symbol "old-table"))
2216 (old-buffer (make-symbol "old-buffer")))
2217 `(let ((,old-table (category-table))
2218 (,old-buffer (current-buffer)))
2221 (set-category-table ,table)
2223 (with-current-buffer ,old-buffer
2224 (set-category-table ,old-table))))))
2226 (defun define-translation-hash-table (symbol table)
2227 "Define SYMBOL as the name of the hash translation TABLE for use in CCL.
2229 Analogous to `define-translation-table', but updates
2230 `translation-hash-table-vector' and the table is for use in the CCL
2231 `lookup-integer' and `lookup-character' functions."
2232 (unless (and (symbolp symbol)
2233 (hash-table-p table))
2234 (error "Bad args to define-translation-hash-table"))
2235 (let ((len (length translation-hash-table-vector))
2238 (put symbol 'translation-hash-table table)
2241 (setq translation-hash-table-vector
2242 (vconcat translation-hash-table-vector [nil])))
2243 (let ((slot (aref translation-hash-table-vector id)))
2245 (eq (car slot) symbol))
2247 (aset translation-hash-table-vector id (cons symbol table))
2249 (setq id (1+ id)))))
2250 (put symbol 'translation-hash-table-id id)
2253 ;;; Initialize some variables.
2255 (put 'use-default-ascent 'char-table-extra-slots 0)
2256 (setq use-default-ascent (make-char-table 'use-default-ascent))
2257 (put 'ignore-relative-composition 'char-table-extra-slots 0)
2258 (setq ignore-relative-composition
2259 (make-char-table 'ignore-relative-composition))
2261 (make-obsolete 'set-char-table-default
2262 "Generic characters no longer exist" "23.1")
2264 ;;; Built-in auto-coding-functions:
2266 (defun sgml-xml-auto-coding-function (size)
2267 "Determine whether the buffer is XML, and if so, its encoding.
2268 This function is intended to be added to `auto-coding-functions'."
2269 (setq size (+ (point) size))
2270 (when (re-search-forward "\\`[[:space:]\n]*<\\?xml" size t)
2271 (let ((end (save-excursion
2273 (re-search-forward "[\"']\\s-*\\?>" size t))))
2275 (if (re-search-forward "encoding=[\"']\\(.+?\\)[\"']" end t)
2276 (let* ((match (match-string 1))
2277 (sym (intern (downcase match))))
2278 (if (coding-system-p sym)
2280 (message "Warning: unknown coding system \"%s\"" match)
2284 (defun sgml-html-meta-auto-coding-function (size)
2285 "If the buffer has an HTML meta tag, use it to determine encoding.
2286 This function is intended to be added to `auto-coding-functions'."
2287 (setq size (min (+ (point) size)
2289 ;; Limit the search by the end of the HTML header.
2290 (or (search-forward "</head>" size t)
2291 ;; In case of no header, search only 10 lines.
2294 ;; Make sure that the buffer really contains an HTML document, by
2295 ;; checking that it starts with a doctype or a <HTML> start tag
2296 ;; (allowing for whitespace at bob). Note: 'DOCTYPE NETSCAPE' is
2297 ;; useful for Mozilla bookmark files.
2298 (when (and (re-search-forward "\\`[[:space:]\n]*\\(<!doctype[[:space:]\n]+\\(html\\|netscape\\)\\|<html\\)" size t)
2299 (re-search-forward "<meta\\s-+http-equiv=[\"']?content-type[\"']?\\s-+content=[\"']text/\\sw+;\\s-*charset=\\(.+?\\)[\"']" size t))
2300 (let* ((match (match-string 1))
2301 (sym (intern (downcase match))))
2302 (if (coding-system-p sym)
2304 (message "Warning: unknown coding system \"%s\"" match)
2310 ;; arch-tag: 9aebaa6e-0e8a-40a9-b857-cb5d04a39e7c
2311 ;;; mule.el ends here