[PATCH] fix for (list-coding-systems) from mule-diag.el

Salam, I've fixed `list-coding-systems', both with C-u (it simply works now ;) and without it (it now lists only base coding systems, as per documentation). It was broken because interface of appropriate functions changed heavily. It was necessary to change record separator from colon to semicolon because some coding systems have colons in their names. Hope it will go into base XEmacs (notify me in that case, please :) --- mule-diag.el 2001/05/04 06:46:35 1.1 +++ mule-diag.el 2001/05/06 21:18:05 ＠＠ -390,68 +390,69 ＠＠ ;; Print detailed information on CODING-SYSTEM. (defun print-coding-system (coding-system) - (let ((type (coding-system-type coding-system)) - (eol-type (coding-system-eol-type coding-system)) - (flags (coding-system-flags coding-system)) - (aliases (coding-system-get coding-system 'alias-coding-systems))) - (if (not (eq (car aliases) coding-system)) - (princ (format "%s (alias of %s)\n" coding-system (car aliases))) - (princ coding-system) - (setq aliases (cdr aliases)) - (while aliases - (princ ",") - (princ (car aliases)) - (setq aliases (cdr aliases))) - (princ (format ":%s:%c:%d:" + (princ coding-system) + (if (coding-system-alias-p coding-system) + (princ (format " (alias of %s)\n" (coding-system-aliasee coding-system))) + (let ((type (coding-system-type coding-system)) + (eol-type (coding-system-eol-type coding-system))) + (princ (format ";%s;%s;%s;" type (coding-system-mnemonic coding-system) - (if (integerp eol-type) eol-type 3))) - (cond ((eq type 2) ; ISO-2022 - (let ((idx 0) - charset) - (while (< idx 4) - (setq charset (aref flags idx)) - (cond ((null charset) - (princ -1)) - ((eq charset t) - (princ -2)) - ((charsetp charset) - (princ charset)) - ((listp charset) - (princ "(") - (princ (car charset)) - (setq charset (cdr charset)) - (while charset - (princ ",") - (princ (car charset)) - (setq charset (cdr charset))) - (princ ")"))) - (princ ",") - (setq idx (1+ idx))) - (while (< idx 12) - (princ (if (aref flags idx) 1 0)) - (princ ",") - (setq idx (1+ idx))) - (princ (if (aref flags idx) 1 0)))) - ((eq type 4) ; CCL - (let (i len) - (if (symbolp (car flags)) - (princ (format " %s" (car flags))) - (setq i 0 len (length (car flags))) - (while (< i len) - (princ (format " %x" (aref (car flags) i))) - (setq i (1+ i)))) - (princ ",") - (if (symbolp (cdr flags)) - (princ (format "%s" (cdr flags))) - (setq i 0 len (length (cdr flags))) - (while (< i len) - (princ (format " %x" (aref (cdr flags) i))) - (setq i (1+ i)))))) - (t (princ 0))) - (princ ":") + (symbol-name eol-type))) + (let ((flags '())) + (cond ((eq type 'iso2022) ; ISO-2022 + ;; G0, G1, G2, G3 + ;; probably this should be implemented with (defmacro)? + (mapcar* + (lambda (GX charset force-charset) + (let ((charset-name (coding-system-get coding-system (intern charset)))) + (if charset-name + (let (flag) + (if (coding-system-property coding-system (intern force-charset)) + (setq flag (concat GX ":[" (symbol-name charset-name) "]")) + (setq flag (concat GX ":" (symbol-name charset-name)))) + (setq flags (append (list flag) flags)))))) + + '("G0" "G1" "G2" "G3") + '("charset-g0" "charset-g1" "charset-g2" "charset-g3") + '("force-g0-on-output" "force-g1-on-output" + "force-g2-on-output" "force-g3-on-output")) + + ;; various other flags + (if (coding-system-get coding-system 'short) + (setq flags (append '("SHORT-FORM") flags))) + + (unless (coding-system-get coding-system 'no-ascii-eol) + (setq flags (append '("ASCII-EOL") flags))) + + (unless (coding-system-get coding-system 'no-ascii-cntl) + (setq flags (append '("ASCII-CNTL") flags))) + + (if (coding-system-get coding-system 'seven) + (setq flags (append '("SEVEN") flags))) + + (if (coding-system-get coding-system 'lock-shift) + (setq flags (append '("LOCKING-SHIFT") flags))) + + (if (coding-system-get coding-system 'no-iso6429) + (setq flags (append '("NO-ISO6429") flags)))) + + ((eq type 'ccl) ; CCL + (princ (format "%s, %s" + (coding-system-get coding-system 'encode) + (coding-system-get coding-system 'decode) flags)))) + (setq flags (reverse flags)) + (if (car flags) + (progn + (princ (format "%s" (car flags))) + (mapc + (lambda (flag) + (princ (format ", %s" flag))) + (cdr flags)))) + )) + (princ ";") (princ (coding-system-doc-string coding-system)) - (princ "\n")))) + (princ "\n"))) ;;;###autoload (defun list-coding-systems (&optional arg) ＠＠ -480,35 +481,49 ＠＠ ## LIST OF CODING SYSTEMS ## Each line corresponds to one coding system ## Format of a line is: -## NAME[,ALIAS...]:TYPE:MNEMONIC:EOL:FLAGS:POST-READ-CONVERSION -## :PRE-WRITE-CONVERSION:DOC-STRING, +## NAME[,ALIAS...];TYPE;MNEMONIC;EOL;FLAGS;POST-READ-CONVERSION +## ;PRE-WRITE-CONVERSION;DOC-STRING, ## where ## NAME = coding system name ## ALIAS = alias of the coding system ## TYPE = nil (no conversion), t (undecided or automatic detection), ## 0 (EMACS-MULE), 1 (SJIS), 2 (ISO2022), 3 (BIG5), or 4 (CCL) -## EOL = 0 (LF), 1 (CRLF), 2 (CR), or 3 (Automatic detection) +## EOL = lf (LF), crlf (CRLF), cr (CR), or nil (Automatic detection) ## FLAGS = -## if TYPE = 2 then +## if TYPE = 'ISO2022 then ## comma (`,') separated data of the followings: ## G0, G1, G2, G3, SHORT-FORM, ASCII-EOL, ASCII-CNTL, SEVEN, -## LOCKING-SHIFT, SINGLE-SHIFT, USE-ROMAN, USE-OLDJIS, NO-ISO6429 -## else if TYPE = 4 then +## LOCKING-SHIFT, NO-ISO6429 +## else if TYPE = 'CCL then ## comma (`,') separated CCL programs for read and write ## else ## 0 ## POST-READ-CONVERSION, PRE-WRITE-CONVERSION = function name to be called ## ")) - (let ((bases (coding-system-list)) - ;;(coding-system-list 'base-only)) - coding-system) - (while bases - (setq coding-system (car bases)) - (if (null arg) - (print-coding-system-briefly coding-system 'doc-string) + (if (null arg) + ;; print only base coding systems (w/o "-dos", "-unix", "-mac") + (let ((bases (make-hash-table))) + ;; put base coding systems into hash-table + (mapc + (lambda (coding-system) + (let* ((base (coding-system-base coding-system)) + (base-name (coding-system-name base))) + + (unless (gethash base-name bases) + (puthash base-name base bases)))) + (coding-system-list)) + + ;; traverse hash-table and print each coding system + (maphash + (lambda (key value) (print-coding-system-briefly value 'doc-string)) + bases)) + + ;; print all coding systems in details + (mapc + '(lambda (coding-system) (print-coding-system coding-system)) - (setq bases (cdr bases))))) + (coding-system-list)))) ;;;###autoload (defun list-coding-categories () --alexm