/[emacs]/emacs/lisp/international/mule.el
ViewVC logotype

Diff of /emacs/lisp/international/mule.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.147.2.1 by miles, Mon Aug 26 09:55:07 2002 UTC revision 1.147.2.2 by miles, Fri Apr 4 06:20:22 2003 UTC
# Line 64  Return t if file exists." Line 64  Return t if file exists."
64              (message "Loading %s (source)..." file)              (message "Loading %s (source)..." file)
65            (message "Loading %s..." file)))            (message "Loading %s..." file)))
66        (when purify-flag        (when purify-flag
67          (setq preloaded-file-list (cons file preloaded-file-list)))          (push file preloaded-file-list))
68        (unwind-protect        (unwind-protect
69            (let ((load-file-name fullname)            (let ((load-file-name fullname)
70                  (set-auto-coding-for-load t)                  (set-auto-coding-for-load t)
# Line 309  See also the documentation of `make-char Line 309  See also the documentation of `make-char
309    "Return character specified by coded character set CCS and CODE-POINT in it.    "Return character specified by coded character set CCS and CODE-POINT in it.
310  Return nil if such a character is not supported.  Return nil if such a character is not supported.
311  Currently the only supported coded character set is `ucs' (ISO/IEC  Currently the only supported coded character set is `ucs' (ISO/IEC
312  10646: Universal Multi-Octet Coded Character Set).  10646: Universal Multi-Octet Coded Character Set), and the result is
313    translated through the translation-table named
314    `utf-translation-table-for-decode' or the translation-hash-table named
315    `utf-subst-table-for-decode'.
316    
317  Optional argument RESTRICTION specifies a way to map the pair of CCS  Optional argument RESTRICTION specifies a way to map the pair of CCS
318  and CODE-POINT to a character.   Currently not supported and just ignored."  and CODE-POINT to a character.  Currently not supported and just ignored."
319    (cond ((eq ccs 'ucs)    (cond
320           (cond ((< code-point 160)     ((eq ccs 'ucs)
321                  code-point)      (or (gethash code-point
322                 ((< code-point 256)                   (get 'utf-subst-table-for-decode 'translation-hash-table))
323                  (make-char 'latin-iso8859-1 code-point))          (let ((c (cond
324                 ((< code-point #x2500)                    ((< code-point 160)
325                  (setq code-point (- code-point #x0100))                     code-point)
326                  (make-char 'mule-unicode-0100-24ff                    ((< code-point 256)
327                             (+ (/ code-point 96) 32) (+ (% code-point 96) 32)))                     (make-char 'latin-iso8859-1 code-point))
328                 ((< code-point #x3400)                    ((< code-point #x2500)
329                  (setq code-point (- code-point #x2500))                     (setq code-point (- code-point #x0100))
330                  (make-char 'mule-unicode-2500-33ff                     (make-char 'mule-unicode-0100-24ff
331                             (+ (/ code-point 96) 32) (+ (% code-point 96) 32)))                                (+ (/ code-point 96) 32) (+ (% code-point 96) 32)))
332                 ((and (>= code-point #xe000) (< code-point #x10000))                    ((< code-point #x3400)
333                  (setq code-point (- code-point #xe000))                     (setq code-point (- code-point #x2500))
334                  (make-char 'mule-unicode-e000-ffff                     (make-char 'mule-unicode-2500-33ff
335                             (+ (/ code-point 96) 32) (+ (% code-point 96) 32)))                                (+ (/ code-point 96) 32) (+ (% code-point 96) 32)))
336                 ))))                    ((and (>= code-point #xe000) (< code-point #x10000))
337                       (setq code-point (- code-point #xe000))
338                       (make-char 'mule-unicode-e000-ffff
339                                  (+ (/ code-point 96) 32)
340                                  (+ (% code-point 96) 32))))))
341              (when c
342                (or (aref (get 'utf-translation-table-for-decode
343                               'translation-table) c)
344                    c)))))))
345    
346  (defun encode-char (char ccs &optional restriction)  (defun encode-char (char ccs &optional restriction)
347    "Return code-point in coded character set CCS that corresponds to CHAR.    "Return code-point in coded character set CCS that corresponds to CHAR.
348  Return nil if CHAR is not included in CCS.  Return nil if CHAR is not included in CCS.
349  Currently the only supported coded character set is `ucs' (ISO/IEC  Currently the only supported coded character set is `ucs' (ISO/IEC
350  10646: Universal Multi-Octet Coded Character Set).  10646: Universal Multi-Octet Coded Character Set), and CHAR is first
351    translated through the translation-table named
352    `utf-translation-table-for-encode' or the translation-hash-table named
353    `utf-subst-table-for-encode'.
354    
355  CHAR should be in one of these charsets:  CHAR should be in one of these charsets:
356    ascii, latin-iso8859-1, mule-unicode-0100-24ff, mule-unicode-2500-33ff,    ascii, latin-iso8859-1, mule-unicode-0100-24ff, mule-unicode-2500-33ff,
# Line 346  Otherwise, return nil. Line 360  Otherwise, return nil.
360  Optional argument RESTRICTION specifies a way to map CHAR to a  Optional argument RESTRICTION specifies a way to map CHAR to a
361  code-point in CCS.  Currently not supported and just ignored."  code-point in CCS.  Currently not supported and just ignored."
362    (let* ((split (split-char char))    (let* ((split (split-char char))
363           (charset (car split)))           (charset (car split))
364             trans)
365      (cond ((eq ccs 'ucs)      (cond ((eq ccs 'ucs)
366             (cond ((eq charset 'ascii)             (or (gethash char (get 'utf-subst-table-for-encode
367                    char)                                    'translation-hash-table))
368                   ((eq charset 'latin-iso8859-1)                 (let ((table (get 'utf-translation-table-for-encode
369                    (+ (nth 1 split) 128))                                   'translation-table)))
370                   ((eq charset 'mule-unicode-0100-24ff)                   (setq trans (aref table char))
371                    (+ #x0100 (+ (* (- (nth 1 split) 32) 96)                   (if trans
372                                 (- (nth 2 split) 32))))                       (setq split (split-char trans)
373                   ((eq charset 'mule-unicode-2500-33ff)                             charset (car split)))
374                    (+ #x2500 (+ (* (- (nth 1 split) 32) 96)                   (cond ((eq charset 'ascii)
375                                 (- (nth 2 split) 32))))                          char)
376                   ((eq charset 'mule-unicode-e000-ffff)                         ((eq charset 'latin-iso8859-1)
377                    (+ #xe000 (+ (* (- (nth 1 split) 32) 96)                          (+ (nth 1 split) 128))
378                                 (- (nth 2 split) 32))))                         ((eq charset 'mule-unicode-0100-24ff)
379                   ((eq charset 'eight-bit-control)                          (+ #x0100 (+ (* (- (nth 1 split) 32) 96)
380                    char))))))                                       (- (nth 2 split) 32))))
381                           ((eq charset 'mule-unicode-2500-33ff)
382                            (+ #x2500 (+ (* (- (nth 1 split) 32) 96)
383                                         (- (nth 2 split) 32))))
384                           ((eq charset 'mule-unicode-e000-ffff)
385                            (+ #xe000 (+ (* (- (nth 1 split) 32) 96)
386                                         (- (nth 2 split) 32))))
387                           ((eq charset 'eight-bit-control)
388                            char))))))))
389    
390    
391  ;; Coding system stuff  ;; Coding system stuff
# Line 492  detected automatically.  Nth element of Line 515  detected automatically.  Nth element of
515  coding system whose eol-type is N."  coding system whose eol-type is N."
516    (get coding-system 'eol-type))    (get coding-system 'eol-type))
517    
518    (defun coding-system-eol-type-mnemonic (coding-system)
519      "Return the string indicating end-of-line format of CODING-SYSTEM."
520      (let* ((eol-type (coding-system-eol-type coding-system))
521             (val (cond ((eq eol-type 0) eol-mnemonic-unix)
522                        ((eq eol-type 1) eol-mnemonic-dos)
523                        ((eq eol-type 2) eol-mnemonic-mac)
524                        (t eol-mnemonic-undecided))))
525        (if (stringp val)
526            val
527          (char-to-string val))))
528    
529  (defun coding-system-lessp (x y)  (defun coding-system-lessp (x y)
530    (cond ((eq x 'no-conversion) t)    (cond ((eq x 'no-conversion) t)
531          ((eq y 'no-conversion) nil)          ((eq y 'no-conversion) nil)
# Line 561  character code range.  Thus FUNC should Line 595  character code range.  Thus FUNC should
595                   (make-char charset (+ i start) (+ start chars -1)))))))                   (make-char charset (+ i start) (+ start chars -1)))))))
596    
597  (defun register-char-codings (coding-system safe-chars)  (defun register-char-codings (coding-system safe-chars)
598    "Add entries for CODING-SYSTEM to `char-coding-system-table'.    "This is an obsolete function.
599  If SAFE-CHARS is a char-table, its non-nil entries specify characters  It exists just for backward compatibility, and it does nothing.")
600  which CODING-SYSTEM encodes safely.  If SAFE-CHARS is t, register  (make-obsolete 'register-char-codings
601  CODING-SYSTEM as a general one which can encode all characters."                 "Unnecessary function.  Calling it has no effect."
602    (let ((general (char-table-extra-slot char-coding-system-table 0))                 "21.3")
603          ;; Charsets which have some members in the table, but not all  
604          ;; of them (i.e. not just a generic character):  (defconst char-coding-system-table nil
605          (partials (char-table-extra-slot char-coding-system-table 1)))    "This is an obsolete variable.
606      (if (eq safe-chars t)  It exists just for backward compatibility, and the value is always nil.")
         (or (memq coding-system general)  
             (set-char-table-extra-slot char-coding-system-table 0  
                                        (cons coding-system general)))  
       (map-char-table  
        (lambda (key val)  
          (if (and (>= key 128) val)  
              (let ((codings (aref char-coding-system-table key))  
                    (charset (char-charset key)))  
                (unless (memq coding-system codings)  
                  (if (and (generic-char-p key)  
                           (memq charset partials))  
                      ;; The generic char would clobber individual  
                      ;; entries already in the table.  First save the  
                      ;; separate existing entries for all chars of the  
                      ;; charset (with the generic entry added, if  
                      ;; necessary).  
                      (let (entry existing)  
                        (map-charset-chars  
                         (lambda (start end)  
                           (while (<= start end)  
                             (setq entry (aref char-coding-system-table start))  
                             (when entry  
                               (push (cons  
                                      start  
                                      (if (memq coding-system entry)  
                                          entry  
                                        (cons coding-system entry)))  
                                     existing))  
                             (setq start (1+ start))))  
                         charset)  
                        ;; Update the generic entry.  
                        (aset char-coding-system-table key  
                              (cons coding-system codings))  
                        ;; Override with the saved entries.  
                        (dolist (elt existing)  
                          (aset char-coding-system-table (car elt) (cdr elt))))  
                    (aset char-coding-system-table key  
                          (cons coding-system codings))  
                    (unless (or (memq charset partials)  
                                (generic-char-p key))  
                      (push charset partials)))))))  
        safe-chars)  
       (set-char-table-extra-slot char-coding-system-table 1 partials))))  
   
607    
608  (defun make-subsidiary-coding-system (coding-system)  (defun make-subsidiary-coding-system (coding-system)
609    "Make subsidiary coding systems (eol-type variants) of CODING-SYSTEM."    "Make subsidiary coding systems (eol-type variants) of CODING-SYSTEM."
# Line 779  PROPERTIES is an alist of properties vs Line 769  PROPERTIES is an alist of properties vs
769  following properties are recognized:  following properties are recognized:
770    
771    o post-read-conversion    o post-read-conversion
772    
773    The value is a function to call after some text is inserted and    The value is a function to call after some text is inserted and
774    decoded by the coding system itself and before any functions in    decoded by the coding system itself and before any functions in
775    `after-insert-functions' are called.  The argument of this    `after-insert-functions' are called.  The argument of this
776    function is the same as for a function in    function is the same as for a function in
777    `after-insert-file-functions', i.e. LENGTH of the text inserted,    `after-insert-file-functions', i.e. LENGTH of the text inserted,
778    with point at the head of the text to be decoded.    with point at the head of the text to be decoded.
779    
780    o pre-write-conversion    o pre-write-conversion
781    
782    The value is a function to call after all functions in    The value is a function to call after all functions in
783    `write-region-annotate-functions' and `buffer-file-format' are    `write-region-annotate-functions' and `buffer-file-format' are
784    called, and before the text is encoded by the coding system itself.    called, and before the text is encoded by the coding system itself.
785    The arguments to this function are the same as those of a function    The arguments to this function are the same as those of a function
786    in `write-region-annotate-functions', i.e. FROM and TO, specifying    in `write-region-annotate-functions', i.e. FROM and TO, specifying
787    a region of text.    a region of text.
788    
789    o translation-table-for-decode    o translation-table-for-decode
790    
791    The value is a translation table to be applied on decoding.  See    The value is a translation table to be applied on decoding.  See
792    the function `make-translation-table' for the format of translation    the function `make-translation-table' for the format of translation
793    table.  This is not applicable to type 4 (CCL-based) coding systems.    table.  This is not applicable to type 4 (CCL-based) coding systems.
794    
795    o translation-table-for-encode    o translation-table-for-encode
796    
797    The value is a translation table to be applied on encoding.  This is    The value is a translation table to be applied on encoding.  This is
798    not applicable to type 4 (CCL-based) coding systems.    not applicable to type 4 (CCL-based) coding systems.
799    
800    o safe-chars    o safe-chars
801    
802    The value is a char table.  If a character has non-nil value in it,    The value is a char table.  If a character has non-nil value in it,
803    the character is safely supported by the coding system.  This    the character is safely supported by the coding system.  This
804    overrides the specification of safe-charsets.    overrides the specification of safe-charsets.
# Line 821  following properties are recognized: Line 811  following properties are recognized:
811    mean that the charset can't be encoded in the coding system;    mean that the charset can't be encoded in the coding system;
812    it just means that some other receiver of text encoded    it just means that some other receiver of text encoded
813    in the coding system won't be able to handle that charset.    in the coding system won't be able to handle that charset.
814    
815    o mime-charset    o mime-charset
816    
817    The value is a symbol whose name is the `MIME-charset' parameter of    The value is a symbol whose name is the `MIME-charset' parameter of
818    the coding system.    the coding system.
819    
820    o valid-codes (meaningful only for a coding system based on CCL)    o valid-codes (meaningful only for a coding system based on CCL)
821    
822    The value is a list to indicate valid byte ranges of the encoded    The value is a list to indicate valid byte ranges of the encoded
823    file.  Each element of the list is an integer or a cons of integer.    file.  Each element of the list is an integer or a cons of integer.
824    In the former case, the integer value is a valid byte code.  In the    In the former case, the integer value is a valid byte code.  In the
825    latter case, the integers specify the range of valid byte codes.    latter case, the integers specify the range of valid byte codes.
826    
827      o composition (meaningful only when TYPE is 0 or 2)
828    
829      If the value is non-nil, the coding system preserves composition
830      information.
831    
832  These properties are set in PLIST, a property list.  This function  These properties are set in PLIST, a property list.  This function
833  also sets properties `coding-category' and `alias-coding-systems'  also sets properties `coding-category' and `alias-coding-systems'
834  automatically.  automatically.
# Line 1028  a value of `safe-charsets' in PLIST." Line 1023  a value of `safe-charsets' in PLIST."
1023                  (if (and (symbolp val)                  (if (and (symbolp val)
1024                           (get val 'translation-table))                           (get val 'translation-table))
1025                      (setq safe-chars (get val 'translation-table)))                      (setq safe-chars (get val 'translation-table)))
                 (register-char-codings coding-system safe-chars)  
1026                  (setq val safe-chars)))                  (setq val safe-chars)))
1027            (plist-put plist prop val)))            (plist-put plist prop val)))
1028        ;; The property `coding-category' may have been set differently        ;; The property `coding-category' may have been set differently
# Line 1062  a value of `safe-charsets' in PLIST." Line 1056  a value of `safe-charsets' in PLIST."
1056                 (error "Invalid EOL-TYPE spec:%S" eol-type))))                 (error "Invalid EOL-TYPE spec:%S" eol-type))))
1057    (put coding-system 'eol-type eol-type)    (put coding-system 'eol-type eol-type)
1058    
1059      (define-coding-system-internal coding-system)
1060    
1061    ;; At last, register CODING-SYSTEM in `coding-system-list' and    ;; At last, register CODING-SYSTEM in `coding-system-list' and
1062    ;; `coding-system-alist'.    ;; `coding-system-alist'.
1063    (add-to-coding-system-list coding-system)    (add-to-coding-system-list coding-system)
# Line 1090  a value of `safe-charsets' in PLIST." Line 1086  a value of `safe-charsets' in PLIST."
1086    
1087    coding-system)    coding-system)
1088    
1089    (put 'safe-chars 'char-table-extra-slots 0)
1090    
1091  (defun define-coding-system-alias (alias coding-system)  (defun define-coding-system-alias (alias coding-system)
1092    "Define ALIAS as an alias for coding system CODING-SYSTEM."    "Define ALIAS as an alias for coding system CODING-SYSTEM."
1093    (put alias 'coding-system (coding-system-spec coding-system))    (put alias 'coding-system (coding-system-spec coding-system))
   (nconc (coding-system-get alias 'alias-coding-systems) (list alias))  
1094    (add-to-coding-system-list alias)    (add-to-coding-system-list alias)
1095    (setq coding-system-alist (cons (list (symbol-name alias))    (setq coding-system-alist (cons (list (symbol-name alias))
1096                                    coding-system-alist))                                    coding-system-alist))
1097    (let ((eol-type (coding-system-eol-type coding-system)))    (let ((eol-type (coding-system-eol-type coding-system)))
1098      (if (vectorp eol-type)      (if (vectorp eol-type)
1099          (put alias 'eol-type (make-subsidiary-coding-system alias))          (progn
1100              (nconc (coding-system-get alias 'alias-coding-systems) (list alias))
1101              (put alias 'eol-type (make-subsidiary-coding-system alias)))
1102        (put alias 'eol-type eol-type))))        (put alias 'eol-type eol-type))))
1103    
1104    (defun merge-coding-systems (first second)
1105      "Fill in any unspecified aspects of coding system FIRST from SECOND.
1106    Return the resulting coding system."
1107      (let ((base (coding-system-base second))
1108            (eol (coding-system-eol-type second)))
1109        ;; If FIRST doesn't specify text conversion, merge with that of SECOND.
1110        (if (eq (coding-system-base first) 'undecided)
1111            (setq first (coding-system-change-text-conversion first base)))
1112        ;; If FIRST doesn't specify eol conversion, merge with that of SECOND.
1113        (if (and (vectorp (coding-system-eol-type first))
1114                 (numberp eol) (>= eol 0) (<= eol 2))
1115            (setq first (coding-system-change-eol-conversion
1116                         first eol)))
1117        first))
1118    
1119  (defun set-buffer-file-coding-system (coding-system &optional force)  (defun set-buffer-file-coding-system (coding-system &optional force)
1120    "Set the file coding-system of the current buffer to CODING-SYSTEM.    "Set the file coding-system of the current buffer to CODING-SYSTEM.
1121  This means that when you save the buffer, it will be converted  This means that when you save the buffer, it will be converted
1122  according to CODING-SYSTEM.  For a list of possible values of CODING-SYSTEM,  according to CODING-SYSTEM.  For a list of possible values of CODING-SYSTEM,
1123  use \\[list-coding-systems].  use \\[list-coding-systems].
1124    
1125  If the buffer's previous file coding-system value specifies end-of-line  If CODING-SYSTEM leaves the text conversion unspecified, or if it
1126  conversion, and CODING-SYSTEM does not specify one, CODING-SYSTEM is  leaves the end-of-line conversion unspecified, FORCE controls what to
1127  merged with the already-specified end-of-line conversion.  do.  If FORCE is nil, get the unspecified aspect (or aspects) from the
1128    buffer's previous `buffer-file-coding-system' value (if it is
1129  If the buffer's previous file coding-system value specifies text  specified there).  Otherwise, levae it unspecified.
 conversion, and CODING-SYSTEM does not specify one, CODING-SYSTEM is  
 merged with the already-specified text conversion.  
   
 However, if the optional prefix argument FORCE is non-nil, then  
 CODING-SYSTEM is used exactly as specified.  
1130    
1131  This marks the buffer modified so that the succeeding \\[save-buffer]  This marks the buffer modified so that the succeeding \\[save-buffer]
1132  surely saves the buffer with CODING-SYSTEM.  From a program, if you  surely saves the buffer with CODING-SYSTEM.  From a program, if you
1133  don't want to mark the buffer modified, just set the variable  don't want to mark the buffer modified, just set the variable
1134  `buffer-file-coding-system' directly."  `buffer-file-coding-system' directly."
1135    (interactive "zCoding system for visited file (default, nil): \nP")    (interactive "zCoding system for saving file (default, nil): \nP")
1136    (check-coding-system coding-system)    (check-coding-system coding-system)
1137    (if (and coding-system buffer-file-coding-system (null force))    (if (and coding-system buffer-file-coding-system (null force))
1138        (let ((base (coding-system-base buffer-file-coding-system))        (setq coding-system
1139              (eol (coding-system-eol-type buffer-file-coding-system)))              (merge-coding-systems coding-system buffer-file-coding-system)))
         ;; If CODING-SYSTEM doesn't specify text conversion, merge  
         ;; with that of buffer-file-coding-system.  
         (if (eq (coding-system-base coding-system) 'undecided)  
             (setq coding-system (coding-system-change-text-conversion  
                                  coding-system base)))  
         ;; If CODING-SYSTEM doesn't specify eol conversion, merge with  
         ;; that of buffer-file-coding-system.  
         (if (and (vectorp (coding-system-eol-type coding-system))  
                  (numberp eol) (>= eol 0) (<= eol 2))  
             (setq coding-system (coding-system-change-eol-conversion  
                                  coding-system eol)))))  
1140    (setq buffer-file-coding-system coding-system)    (setq buffer-file-coding-system coding-system)
1141      ;; This is in case of an explicit call.  Normally, `normal-mode' and
1142      ;; `set-buffer-major-mode-hook' take care of setting the table.
1143      (if (fboundp 'ucs-set-table-for-input) ; don't lose when building
1144          (ucs-set-table-for-input))
1145    (set-buffer-modified-p t)    (set-buffer-modified-p t)
1146    (force-mode-line-update))    (force-mode-line-update))
1147    
1148    (defun revert-buffer-with-coding-system (coding-system &optional force)
1149      "Visit the current buffer's file again using coding system CODING-SYSTEM.
1150    For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems].
1151    
1152    If CODING-SYSTEM leaves the text conversion unspecified, or if it
1153    leaves the end-of-line conversion unspecified, FORCE controls what to
1154    do.  If FORCE is nil, get the unspecified aspect (or aspects) from the
1155    buffer's previous `buffer-file-coding-system' value (if it is
1156    specified there).  Otherwise, determine it from the file contents as
1157    usual for visiting a file."
1158      (interactive "zCoding system for visited file (default, nil): \nP")
1159      (check-coding-system coding-system)
1160      (if (and coding-system buffer-file-coding-system (null force))
1161          (setq coding-system
1162                (merge-coding-systems coding-system buffer-file-coding-system)))
1163      (let ((coding-system-for-read coding-system))
1164        (revert-buffer)))
1165    
1166    (defun set-file-name-coding-system (coding-system)
1167      "Set coding system for decoding and encoding file names to CODING-SYSTEM.
1168    It actually just set the variable `file-name-coding-system' (which
1169    see) to CODING-SYSTEM."
1170      (interactive "zCoding system for file names (default, nil): ")
1171      (check-coding-system coding-system)
1172      (setq file-name-coding-system coding-system))
1173    
1174  (defvar default-terminal-coding-system nil  (defvar default-terminal-coding-system nil
1175    "Default value for the terminal coding system.    "Default value for the terminal coding system.
1176  This is normally set according to the selected language environment.  This is normally set according to the selected language environment.
# Line 1207  If you set this on a terminal which can' Line 1235  If you set this on a terminal which can'
1235  8-bit characters, you will have to use ESC to type Meta characters.  8-bit characters, you will have to use ESC to type Meta characters.
1236  See Info node `Specify Coding' and Info node `Single-Byte Character Support'.  See Info node `Specify Coding' and Info node `Single-Byte Character Support'.
1237    
1238    On non-windowing terminals, this is set from the locale by default.
1239    
1240  Setting this variable directly does not take effect;  Setting this variable directly does not take effect;
1241  use either M-x customize or \\[set-keyboard-coding-system]."  use either M-x customize or \\[set-keyboard-coding-system]."
1242    :type '(coding-system :tag "Coding system")    :type '(coding-system :tag "Coding system")
# Line 1217  use either M-x customize or \\[set-keybo Line 1247  use either M-x customize or \\[set-keybo
1247           (if (or value (boundp 'encoded-kbd-mode))           (if (or value (boundp 'encoded-kbd-mode))
1248               (set-keyboard-coding-system value)               (set-keyboard-coding-system value)
1249             (set-default 'keyboard-coding-system nil))) ; must initialize             (set-default 'keyboard-coding-system nil))) ; must initialize
1250    :version "21.1"    :version "21.4"
1251    :group 'keyboard    :group 'keyboard
1252    :group 'mule)    :group 'mule)
1253    
# Line 1240  For a list of possible values of CODING- Line 1270  For a list of possible values of CODING-
1270  (defalias 'set-clipboard-coding-system 'set-selection-coding-system)  (defalias 'set-clipboard-coding-system 'set-selection-coding-system)
1271    
1272  (defun set-selection-coding-system (coding-system)  (defun set-selection-coding-system (coding-system)
1273    "Make CODING-SYSTEM used for communicating with other X clients .    "Make CODING-SYSTEM used for communicating with other X clients.
1274  When sending or receiving text via cut_buffer, selection, and clipboard,  When sending or receiving text via cut_buffer, selection, and clipboard,
1275  the text is encoded or decoded by CODING-SYSTEM."  the text is encoded or decoded by CODING-SYSTEM."
1276    (interactive "zCoding system for X selection: ")    (interactive "zCoding system for X selection: ")
# Line 1293  ARG is a list of coding categories order Line 1323  ARG is a list of coding categories order
1323      ("ISO8859-14" . latin-iso8859-14)      ("ISO8859-14" . latin-iso8859-14)
1324      ("KOI8-R" . koi8-r)      ("KOI8-R" . koi8-r)
1325      ("BIG5-0" . big5))      ("BIG5-0" . big5))
1326    "Alist of font charset names defined by XLFD, and the corresponding Emacs    "Alist of font charset names defined by XLFD.
1327  charsets or coding systems.")  The cdr of each element is the corresponding Emacs charset or coding system.")
1328    
1329  ;; Functions to support "Non-Standard Character Set Encodings" defined  ;; Functions to support "Non-Standard Character Set Encodings" defined
1330  ;; by the ICCCM spec.  We support that by converting the leading  ;; by the COMPOUND-TEXT spec.
1331  ;; sequence of the ``extended segment'' to the corresponding ISO-2022  ;; We support that by converting the leading sequence of the
1332  ;; sequences (if the leading sequence names an Emacs charset), or decode  ;; ``extended segment'' to the corresponding ISO-2022 sequences (if
1333  ;; the segment (if it names a coding system).  Encoding does the reverse.  ;; the leading sequence names an Emacs charset), or decode the segment
1334    ;; (if it names a coding system).  Encoding does the reverse.
1335    ;; This function also supports "The UTF-8 encoding" described in the
1336    ;; section 7 of the documentation fo COMPOUND-TEXT distributed with
1337    ;; XFree86.
1338    
1339  (defun ctext-post-read-conversion (len)  (defun ctext-post-read-conversion (len)
1340    "Decode LEN characters encoded as Compound Text with Extended Segments."    "Decode LEN characters encoded as Compound Text with Extended Segments."
1341    (buffer-disable-undo) ; minimize consing due to insertions and deletions    (buffer-disable-undo) ; minimize consing due to insertions and deletions
# Line 1311  charsets or coding systems.") Line 1346  charsets or coding systems.")
1346            (newpt (make-marker))            (newpt (make-marker))
1347            (modified-p (buffer-modified-p))            (modified-p (buffer-modified-p))
1348            (case-fold-search nil)            (case-fold-search nil)
1349              ;; We need multibyte conversion of "TO" type because the
1350              ;; buffer may be multibyte, and, in that case, the pattern
1351              ;; must contain eight-bit-control/graphic characters.
1352              (pattern (string-to-multibyte "\\(\e\\)%/[0-4]\\([\200-\377][\200-\377]\\)\\([^\002]+\\)\002\\|\e%G[^\e]+\e%@"))
1353            last-coding-system-used            last-coding-system-used
1354            encoding textlen chset)            encoding textlen chset)
1355        (while (re-search-forward        (while (re-search-forward pattern nil 'move)
               "\\(\e\\)%/[0-4]\\([\200-\377][\200-\377]\\)\\([^\002]+\\)\002"  
               nil 'move)  
1356          (set-marker newpt (point))          (set-marker newpt (point))
1357          (set-marker pt (match-beginning 0))          (set-marker pt (match-beginning 0))
1358          (setq encoding (match-string 3))          (if (= (preceding-char) ?@)
1359          (setq textlen (- (+ (* (- (aref (match-string 2) 0) 128) 128)              ;; We found embedded utf-8 sequence.
1360                              (- (aref (match-string 2) 1) 128))              (progn
1361                           (1+ (length encoding))))                (delete-char -3)          ; delete ESC % @ at the tail
1362          (setq                (goto-char pt)
1363           chset (cdr (assoc-ignore-case encoding                (delete-char 3)           ; delete ESC % G at the head
1364                                         non-standard-icccm-encodings-alist)))                (if (> pt oldpt)
1365          (cond ((null chset)                    (decode-coding-region oldpt pt 'ctext-no-compositions))
1366                 ;; This charset is not supported--leave this extended                (decode-coding-region pt newpt 'mule-utf-8)
1367                 ;; segment unaltered and skip over it.                (goto-char newpt)
1368                 (goto-char (+ (point) textlen)))                (set-marker oldpt newpt))
1369                ((charsetp chset)            (setq encoding (match-string 3))
1370               ;; If it's a charset, replace the leading escape sequence            (setq textlen (- (+ (* (- (aref (match-string 2) 0) 128) 128)
1371               ;; with a standard ISO-2022 sequence.  We will decode all                                (- (aref (match-string 2) 1) 128))
1372                ;; such segments later, in one go, when we exit the loop                             (1+ (length encoding))))
1373                 ;; or find an extended segment that names a coding            (setq
1374                 ;; system, not a charset.             chset (cdr (assoc-ignore-case encoding
1375                 (replace-match                                           non-standard-icccm-encodings-alist)))
1376                  (concat "\\1"            (cond ((null chset)
1377                          (if (= 0 (charset-iso-graphic-plane chset))                   ;; This charset is not supported--leave this extended
1378                              ;; GL charsets                   ;; segment unaltered and skip over it.
1379                              (if (= 1 (charset-dimension chset)) "(" "$(")                   (goto-char (+ (point) textlen)))
1380                            ;; GR charsets                  ((charsetp chset)
1381                            (if (= 96 (charset-chars chset))                   ;; If it's a charset, replace the leading escape sequence
1382                                "-"                   ;; with a standard ISO-2022 sequence.  We will decode all
1383                              (if (= 1 (charset-dimension chset)) ")" "$)")))                   ;; such segments later, in one go, when we exit the loop
1384                          (string (charset-iso-final-char chset)))                   ;; or find an extended segment that names a coding
1385                  t)                   ;; system, not a charset.
1386                 (goto-char (+ (point) textlen)))                   (replace-match
1387                ((coding-system-p chset)                    (concat "\\1"
1388               ;; If it's a coding system, we need to decode the segment                            (if (= 0 (charset-iso-graphic-plane chset))
1389                 ;; right away.  But first, decode what we've skipped                                ;; GL charsets
1390                 ;; across until now.                                (if (= 1 (charset-dimension chset)) "(" "$(")
1391                 (when (> pt oldpt)                              ;; GR charsets
1392                   (decode-coding-region oldpt pt 'ctext-no-compositions))                              (if (= 96 (charset-chars chset))
1393                 (delete-region pt newpt)                                  "-"
1394                 (set-marker newpt (+ newpt textlen))                                (if (= 1 (charset-dimension chset)) ")" "$)")))
1395                 (decode-coding-region pt newpt chset)                            (string (charset-iso-final-char chset)))
1396                 (goto-char newpt)                    t)
1397                 (set-marker oldpt newpt))))                   (goto-char (+ (point) textlen)))
1398                    ((coding-system-p chset)
1399                     ;; If it's a coding system, we need to decode the segment
1400                     ;; right away.  But first, decode what we've skipped
1401                     ;; across until now.
1402                     (when (> pt oldpt)
1403                       (decode-coding-region oldpt pt 'ctext-no-compositions))
1404                     (delete-region pt newpt)
1405                     (set-marker newpt (+ newpt textlen))
1406                     (decode-coding-region pt newpt chset)
1407                     (goto-char newpt)
1408                     (set-marker oldpt newpt)))))
1409        ;; Decode what's left.        ;; Decode what's left.
1410        (when (> (point) oldpt)        (when (> (point) oldpt)
1411          (decode-coding-region oldpt (point) 'ctext-no-compositions))          (decode-coding-region oldpt (point) 'ctext-no-compositions))
1412       ;; This buffer started as unibyte, because the string we get from        ;; This buffer started as unibyte, because the string we get from
1413        ;; the X selection is a unibyte string.  We must now make it        ;; the X selection is a unibyte string.  We must now make it
1414        ;; multibyte, so that the decoded text is inserted as multibyte        ;; multibyte, so that the decoded text is inserted as multibyte
1415        ;; into its buffer.        ;; into its buffer.
# Line 1369  charsets or coding systems.") Line 1417  charsets or coding systems.")
1417        (set-buffer-modified-p modified-p)        (set-buffer-modified-p modified-p)
1418        (- (point-max) (point-min)))))        (- (point-max) (point-min)))))
1419    
1420    ;; If you add charsets here, be sure to modify the regexp used by
1421    ;; ctext-pre-write-conversion to look up non-standard charsets.
1422  (defvar non-standard-designations-alist  (defvar non-standard-designations-alist
1423    '(("$(0" . (big5 "big5-0" 2))    '(("$(0" . (big5 "big5-0" 2))
1424      ("$(1" . (big5 "big5-0" 2))      ("$(1" . (big5 "big5-0" 2))
1425      ("-V"  . (t "iso8859-10" 1))      ;; The following are actually standard; generating extended
1426      ("-Y"  . (t "iso8859-13" 1))      ;; segments for them is wrong and screws e.g. Latin-9 users.
1427      ("-_"  . (t "iso8859-14" 1))      ;; 8859-{10,13,16} aren't Emacs charsets anyhow.  -- fx
1428      ("-b"  . (t "iso8859-15" 1))  ;;     ("-V"  . (t "iso8859-10" 1))
1429      ("-f"  . (t "iso8859-16" 1)))  ;;     ("-Y"  . (t "iso8859-13" 1))
1430    ;;     ("-_"  . (t "iso8859-14" 1))
1431    ;;     ("-b"  . (t "iso8859-15" 1))
1432    ;;     ("-f"  . (t "iso8859-16" 1))
1433        )
1434    "Alist of ctext control sequences that introduce character sets which    "Alist of ctext control sequences that introduce character sets which
1435  are not in the list of approved ICCCM encodings, and the corresponding  are not in the list of approved encodings, and the corresponding
1436  coding system, identifier string, and number of octets per encoded  coding system, identifier string, and number of octets per encoded
1437  character.  character.
1438    
# Line 1388  set in the text encoded by compound-text Line 1442  set in the text encoded by compound-text
1442  symbol; if it is t, it means that the ctext coding system already encodes  symbol; if it is t, it means that the ctext coding system already encodes
1443  the text correctly, and only the leading control sequence needs to be altered.  the text correctly, and only the leading control sequence needs to be altered.
1444  If ENCODING is a coding system, we need to re-encode the text with that  If ENCODING is a coding system, we need to re-encode the text with that
1445  coding system.  CHARSET is the ICCCM name of the charset we need to put into  coding system.  CHARSET is the name of the charset we need to put into
1446  the leading control sequence.  NOCTETS is the number of octets (bytes) that  the leading control sequence.  NOCTETS is the number of octets (bytes) that
1447  encode each character in this charset.  NOCTETS can be 0 (meaning the number  encode each character in this charset.  NOCTETS can be 0 (meaning the number
1448  of octets per character is variable), 1, 2, 3, or 4.")  of octets per character is variable), 1, 2, 3, or 4.")
# Line 1410  text, and convert it in the temporary bu Line 1464  text, and convert it in the temporary bu
1464             (buffer-disable-undo)             (buffer-disable-undo)
1465             (if (stringp from)             (if (stringp from)
1466                 (insert from)                 (insert from)
1467               (insert-buffer-substring buf from to)))))               (insert-buffer-substring buf from to))
1468               (setq from (point-min) to (point-max)))))
1469    (encode-coding-region from to 'ctext-no-compositions)    (encode-coding-region from to 'ctext-no-compositions)
1470    ;; Replace ISO-2022 charset designations with extended segments, for    ;; Replace ISO-2022 charset designations with extended segments, for
1471    ;; those charsets that are not part of the official X registry.    ;; those charsets that are not part of the official X registry.
# Line 1420  text, and convert it in the temporary bu Line 1475  text, and convert it in the temporary bu
1475            (case-fold-search nil)            (case-fold-search nil)
1476            pt desig encode-info encoding chset noctets textlen)            pt desig encode-info encoding chset noctets textlen)
1477        (set-buffer-multibyte nil)        (set-buffer-multibyte nil)
1478        ;; The regexp below finds the leading sequences for big5 and        ;; The regexp below finds the leading sequences for big5.
1479        ;; iso8859-1[03-6] charsets.        (while (re-search-forward "\e\\(\$([01]\\)" nil 'move)
       (while (re-search-forward "\e\\(\$([01]\\|-[VY_bf]\\)" nil 'move)  
1480          (setq desig (match-string 1)          (setq desig (match-string 1)
1481                pt (point-marker)                pt (point-marker)
1482                encode-info (cdr (assoc desig non-standard-designations-alist))                encode-info (cdr (assoc desig non-standard-designations-alist))
# Line 1462  text, and convert it in the temporary bu Line 1516  text, and convert it in the temporary bu
1516  ;;; FILE I/O  ;;; FILE I/O
1517    
1518  (defcustom auto-coding-alist  (defcustom auto-coding-alist
1519    '(("\\.\\(arc\\|zip\\|lzh\\|zoo\\|jar\\|tar\\|tgz\\)\\'" . no-conversion)    '(("\\.\\(arc\\|zip\\|lzh\\|zoo\\|jar\\|sx[dmicw]\\|tar\\|tgz\\)\\'" . no-conversion)
1520      ("\\.\\(gz\\|Z\\|bz\\|bz2\\|gpg\\)\\'" . no-conversion)      ("\\.\\(gz\\|Z\\|bz\\|bz2\\|gpg\\)\\'" . no-conversion)
1521      ("/#[^/]+#\\'" . emacs-mule))      ("/#[^/]+#\\'" . emacs-mule))
1522    "Alist of filename patterns vs corresponding coding systems.    "Alist of filename patterns vs corresponding coding systems.
# Line 1515  This is used for loading and byte-compil Line 1569  This is used for loading and byte-compil
1569  (defun auto-coding-alist-lookup (filename)  (defun auto-coding-alist-lookup (filename)
1570    "Return the coding system specified by `auto-coding-alist' for FILENAME."    "Return the coding system specified by `auto-coding-alist' for FILENAME."
1571    (let ((alist auto-coding-alist)    (let ((alist auto-coding-alist)
1572          (case-fold-search (memq system-type '(vax-vms windows-nt ms-dos)))          (case-fold-search (memq system-type '(vax-vms windows-nt ms-dos cygwin)))
1573          coding-system)          coding-system)
1574      (while (and alist (not coding-system))      (while (and alist (not coding-system))
1575        (if (string-match (car (car alist)) filename)        (if (string-match (car (car alist)) filename)
# Line 1528  This is used for loading and byte-compil Line 1582  This is used for loading and byte-compil
1582  These bytes should include at least the first 1k of the file  These bytes should include at least the first 1k of the file
1583  and the last 3k of the file, but the middle may be omitted.  and the last 3k of the file, but the middle may be omitted.
1584    
1585  It checks FILENAME against the variable `auto-coding-alist'.  If  The function checks FILENAME against the variable `auto-coding-alist'.
1586  FILENAME doesn't match any entries in the variable, it checks the  If FILENAME doesn't match any entries in the variable, it checks the
1587  contents of the current buffer following point against  contents of the current buffer following point against
1588  `auto-coding-regexp-alist'.  If no match is found, it checks for a  `auto-coding-regexp-alist'.  If no match is found, it checks for a
1589  `coding:' tag in the first one or two lines following point.  If no  `coding:' tag in the first one or two lines following point.  If no
1590  `coding:' tag is found, it checks for local variables list in the last  `coding:' tag is found, it checks any local variables list in the last
1591  3K bytes out of the SIZE bytes.  Finally, if none of these methods  3K bytes out of the SIZE bytes.  Finally, if none of these methods
1592  succeed, then it checks to see if any function in  succeed, it checks to see if any function in `auto-coding-functions'
1593  `auto-coding-functions' gives a match.  gives a match.
1594    
1595  The return value is the specified coding system,  The return value is the specified coding system, or nil if nothing is
1596  or nil if nothing specified.  specified.
1597    
1598  The variable `set-auto-coding-function' (which see) is set to this  The variable `set-auto-coding-function' (which see) is set to this
1599  function by default."  function by default."
# Line 1552  function by default." Line 1606  function by default."
1606              (let ((regexp (car (car alist))))              (let ((regexp (car (car alist))))
1607                (when (re-search-forward regexp (+ (point) size) t)                (when (re-search-forward regexp (+ (point) size) t)
1608                  (setq coding-system (cdr (car alist)))))                  (setq coding-system (cdr (car alist)))))
1609              (setq alist (cdr alist)))              (setq alist (cdr alist)))
1610            coding-system))            coding-system))
1611        (let* ((case-fold-search t)        (let* ((case-fold-search t)
1612               (head-start (point))               (head-start (point))
# Line 1783  or a function symbol which, when called, Line 1837  or a function symbol which, when called,
1837                     (cons (cons regexp coding-system)                     (cons (cons regexp coding-system)
1838                           network-coding-system-alist)))))))                           network-coding-system-alist)))))))
1839    
1840    (defun decode-coding-inserted-region (from to filename
1841                                               &optional visit beg end replace)
1842      "Decode the region between FROM and TO as if it is read from file FILENAME.
1843    Optional arguments VISIT, BEG, END, and REPLACE are the same as those
1844    of the function `insert-file-contents'."
1845      (save-excursion
1846        (save-restriction
1847          (narrow-to-region from to)
1848          (goto-char (point-min))
1849          (let ((coding coding-system-for-read))
1850            (or coding
1851                (setq coding (funcall set-auto-coding-function
1852                                      filename (- (point-max) (point-min)))))
1853            (or coding
1854                (setq coding (find-operation-coding-system
1855                              'insert-file-contents
1856                              filename visit beg end replace)))
1857            (if (coding-system-p coding)
1858                (or enable-multibyte-characters
1859                    (setq coding
1860                          (coding-system-change-text-conversion coding 'raw-text)))
1861              (setq coding nil))
1862            (if coding
1863                (decode-coding-region (point-min) (point-max) coding))
1864            (setq last-coding-system-used coding)))))
1865    
1866  (defun make-translation-table (&rest args)  (defun make-translation-table (&rest args)
1867    "Make a translation table from arguments.    "Make a translation table from arguments.
1868  A translation table is a char table intended for character  A translation table is a char table intended for character
# Line 1907  the table in `translation-table-vector'. Line 1987  the table in `translation-table-vector'.
1987    
1988  (put 'with-category-table 'lisp-indent-function 1)  (put 'with-category-table 'lisp-indent-function 1)
1989    
1990  (defmacro with-category-table (category-table &rest body)  (defmacro with-category-table (table &rest body)
1991    `(let ((current-category-table (category-table)))    "Evaluate BODY with category table of current buffer set to TABLE.
1992       (set-category-table ,category-table)  The category table of the current buffer is saved, BODY is evaluated,
1993       (unwind-protect  then the saved table is restored, even in case of an abnormal exit.
1994           (progn ,@body)  Value is what BODY returns."
1995         (set-category-table current-category-table))))    (let ((old-table (make-symbol "old-table"))
1996            (old-buffer (make-symbol "old-buffer")))
1997        `(let ((,old-table (category-table))
1998               (,old-buffer (current-buffer)))
1999           (unwind-protect
2000               (progn
2001                 (set-category-table ,table)
2002                 ,@body)
2003             (save-current-buffer
2004               (set-buffer ,old-buffer)
2005               (set-category-table ,old-table))))))
2006    
2007    (defun define-translation-hash-table (symbol table)
2008      "Define SYMBOL as the name of the hash translation TABLE for use in CCL.
2009    
2010    Analogous to `define-translation-table', but updates
2011    `translation-hash-table-vector' and the table is for use in the CCL
2012    `lookup-integer' and `lookup-character' functions."
2013      (unless (and (symbolp symbol)
2014                   (hash-table-p table))
2015        (error "Bad args to define-translation-hash-table"))
2016      (let ((len (length translation-hash-table-vector))
2017            (id 0)
2018            done)
2019        (put symbol 'translation-hash-table table)
2020        (while (not done)
2021          (if (>= id len)
2022              (setq translation-hash-table-vector
2023                    (vconcat translation-hash-table-vector [nil])))
2024          (let ((slot (aref translation-hash-table-vector id)))
2025            (if (or (not slot)
2026                    (eq (car slot) symbol))
2027                (progn
2028                  (aset translation-hash-table-vector id (cons symbol table))
2029                  (setq done t))
2030              (setq id (1+ id)))))
2031        (put symbol 'translation-hash-table-id id)
2032        id))
2033    
2034  ;;; Initialize some variables.  ;;; Initialize some variables.
2035    
# Line 1928  the table in `translation-table-vector'. Line 2045  the table in `translation-table-vector'.
2045  (defun sgml-xml-auto-coding-function (size)  (defun sgml-xml-auto-coding-function (size)
2046    "Determine whether the buffer is XML, and if so, its encoding.    "Determine whether the buffer is XML, and if so, its encoding.
2047  This function is intended to be added to `auto-coding-functions'."  This function is intended to be added to `auto-coding-functions'."
2048    (when (re-search-forward "\\`[[:space:]\n]*<\\?xml")    (when (re-search-forward "\\`[[:space:]\n]*<\\?xml" nil t)
2049      (let ((end (save-excursion      (let ((end (save-excursion
2050                   ;; This is a hack.                   ;; This is a hack.
2051                   (re-search-forward "\"\\s-*\\?>" size t))))                   (re-search-forward "\"\\s-*\\?>" size t))))
# Line 1958  This function is intended to be added to Line 2075  This function is intended to be added to
2075              sym              sym
2076            (message "Warning: unknown coding system \"%s\"" match)            (message "Warning: unknown coding system \"%s\"" match)
2077            nil))))            nil))))
2078          
2079  ;;;  ;;;
2080  (provide 'mule)  (provide 'mule)
2081    

Legend:
Removed from v.1.147.2.1  
changed lines
  Added in v.1.147.2.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26