X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/57cb2e6f261bb0aad81a9f7e6f3017b54adee068..781424c2f372d40d69d6aa77d62adc236e795323:/lisp/descr-text.el diff --git a/lisp/descr-text.el b/lisp/descr-text.el index 9f6cbb4013..7b7a209451 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -1,7 +1,7 @@ ;;; descr-text.el --- describe text mode ;; Copyright (C) 1994, 1995, 1996, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007 Free Software Foundation, Inc. +;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Boris Goldowsky ;; Maintainer: FSF @@ -11,7 +11,7 @@ ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) +;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, @@ -187,22 +187,23 @@ otherwise." "List of Unicode-based character property names shown by `describe-char'." :group 'mule :version "23.1" - :type '(set - (const :tag "Unicode Name" name) - (const :tag "Unicode general category " general-category) - (const :tag "Unicode canonical combining class" - canonical-combining-class) - (const :tag "Unicode bidi class" bidi-class) - (const :tag "Unicode decomposition mapping" decomposition) - (const :tag "Unicode decimal digit value" decimal-digit-value) - (const :tag "Unicode digit value" digit-value) - (const :tag "Unicode numeric value" numeric-value) - (const :tag "Unicode mirrored" mirrored) - (const :tag "Unicode old name" old-name) - (const :tag "Unicode ISO 10646 comment" iso-10646-comment) - (const :tag "Unicode simple uppercase mapping" uppercase) - (const :tag "Unicode simple lowercase mapping" lowercase) - (const :tag "Unicode simple titlecase mapping" titlecase))) + :type '(choice (const :tag "All properties" t) + (set + (const :tag "Unicode Name" name) + (const :tag "Unicode general category " general-category) + (const :tag "Unicode canonical combining class" + canonical-combining-class) + (const :tag "Unicode bidi class" bidi-class) + (const :tag "Unicode decomposition mapping" decomposition) + (const :tag "Unicode decimal digit value" decimal-digit-value) + (const :tag "Unicode digit value" digit-value) + (const :tag "Unicode numeric value" numeric-value) + (const :tag "Unicode mirrored" mirrored) + (const :tag "Unicode old name" old-name) + (const :tag "Unicode ISO 10646 comment" iso-10646-comment) + (const :tag "Unicode simple uppercase mapping" uppercase) + (const :tag "Unicode simple lowercase mapping" lowercase) + (const :tag "Unicode simple titlecase mapping" titlecase)))) (defcustom describe-char-unicodedata-file nil "Location of Unicode data file. @@ -219,13 +220,6 @@ At the time of writing it is at the URL :type '(choice (const :tag "None" nil) file)) -;; We could convert the unidata file into a Lispy form once-for-all -;; and distribute it for loading on demand. It might be made more -;; space-efficient by splitting strings word-wise and replacing them -;; with lists of symbols interned in a private obarray, e.g. -;; "LATIN SMALL LETTER A" => '(LATIN SMALL LETTER A). - -;; Fixme: Check whether this needs updating for Unicode 4. (defun describe-char-unicode-data (char) "Return a list of Unicode data for unicode CHAR. Each element is a list of a property description and the property value. @@ -330,11 +324,19 @@ This function is semi-obsolete. Use `get-char-code-property'." ;; Return information about how CHAR is displayed at the buffer ;; position POS. If the selected frame is on a graphic display, -;; return a cons (FONTNAME . GLYPH-CODE). Otherwise, return a string -;; describing the terminal codes for the character. +;; return a cons (FONTNAME . GLYPH-CODE) where GLYPH-CODE is a +;; hexadigit string representing the glyph-ID. Otherwise, return a +;; string describing the terminal codes for the character. (defun describe-char-display (pos char) (if (display-graphic-p (selected-frame)) - (internal-char-font pos char) + (let ((char-font-info (internal-char-font pos char))) + (if char-font-info + (if (integerp (cdr char-font-info)) + (setcdr char-font-info (format "%02X" (cdr char-font-info))) + (setcdr char-font-info + (format "%04X%04X" + (cadr char-font-info) (cddr char-font-info))))) + char-font-info) (let* ((coding (terminal-coding-system)) (encoded (encode-coding-char char coding))) (if encoded @@ -482,7 +484,7 @@ as well as widgets, buttons, overlays, and text properties." (if display (concat "by this font (glyph code)\n" - (format " %s (#x%02X)" + (format " %s (#x%s)" (car display) (cdr display))) "no font available") (if display @@ -508,11 +510,11 @@ as well as widgets, buttons, overlays, and text properties." ,@(let ((unicodedata (describe-char-unicode-data char))) (if unicodedata (cons (list "Unicode data" " ") unicodedata))))) - (setq max-width (apply #'max (mapcar #'(lambda (x) + (setq max-width (apply #'max (mapcar #'(lambda (x) (if (cadr x) (length (car x)) 0)) item-list))) (help-setup-xref nil (interactive-p)) - (with-output-to-temp-buffer (help-buffer) + (with-help-window (help-buffer) (with-current-buffer standard-output (set-buffer-multibyte multibyte-p) (let ((formatter (format "%%%ds:" max-width))) @@ -554,7 +556,7 @@ as well as widgets, buttons, overlays, and text properties." (insert (glyph-char (car (aref disp-vector i))) ?: (propertize " " 'display '(space :align-to 5)) (if (cdr (aref disp-vector i)) - (format "%s (#x%02X)" (cadr (aref disp-vector i)) + (format "%s (#x%s)" (cadr (aref disp-vector i)) (cddr (aref disp-vector i))) "-- no font --") "\n") @@ -583,55 +585,68 @@ as well as widgets, buttons, overlays, and text properties." (if (cadr composition) (insert " with the following character(s) \"" (cadr composition) "\""))) - (insert " by the rule:\n\t(" - (mapconcat (lambda (x) - (format (if (consp x) "%S" "?%c") x)) - (nth 2 composition) - " ") - ")") - (insert "\nThe component character(s) are displayed by ") - (if (display-graphic-p (selected-frame)) + (if (and (vectorp (nth 2 composition)) + (vectorp (aref (nth 2 composition) 0))) (progn - (insert "these fonts (glyph codes):") - (dolist (elt component-chars) - (insert "\n " (car elt) ?: - (propertize " " 'display '(space :align-to 5)) - (if (cdr elt) - (format "%s (#x%02X)" (cadr elt) (cddr elt)) - "-- no font --")))) - (insert "these terminal codes:") - (dolist (elt component-chars) - (insert "\n " (car elt) ":" - (propertize " " 'display '(space :align-to 5)) - (or (cdr elt) "-- not encodable --")))) - (insert "\nSee the variable `reference-point-alist' for " - "the meaning of the rule.\n")) - - (if (not describe-char-unidata-list) - (insert "\nCharacter code properties are not shown: ") - (insert "\nCharacter code properties: ")) + (insert " using this font:\n " + (aref (query-font (aref (aref (nth 2 composition) 0) 0)) + 0) + "\nby these glyphs:\n") + (mapc (lambda (x) (insert (format " %S\n" x))) + (nth 2 composition))) + (insert " by the rule:\n\t(" + (mapconcat (lambda (x) + (if (consp x) (format "%S" x) + (if (= x ?\t) + (single-key-description x) + (string ?? x)))) + (nth 2 composition) + " ") + ")") + (insert "\nThe component character(s) are displayed by ") + (if (display-graphic-p (selected-frame)) + (progn + (insert "these fonts (glyph codes):") + (dolist (elt component-chars) + (if (/= (car elt) ?\t) + (insert "\n " (car elt) ?: + (propertize " " 'display '(space :align-to 5)) + (if (cdr elt) + (format "%s (#x%s)" (cadr elt) (cddr elt)) + "-- no font --"))))) + (insert "these terminal codes:") + (dolist (elt component-chars) + (insert "\n " (car elt) ":" + (propertize " " 'display '(space :align-to 4)) + (or (cdr elt) "-- not encodable --")))) + (insert "\nSee the variable `reference-point-alist' for " + "the meaning of the rule.\n"))) + + (insert (if (not describe-char-unidata-list) + "\nCharacter code properties are not shown: " + "\nCharacter code properties: ")) (insert-text-button "customize what to show" 'action (lambda (&rest ignore) (customize-variable 'describe-char-unidata-list))) (insert "\n") - (dolist (elt describe-char-unidata-list) + (dolist (elt (if (eq describe-char-unidata-list t) + (nreverse (mapcar 'car char-code-property-alist)) + describe-char-unidata-list)) (let ((val (get-char-code-property char elt)) description) (when val (setq description (char-code-property-description elt val)) - (if description - (insert (format " %s: %s (%s)\n" elt val description)) - (insert (format " %s: %s\n" elt val)))))) + (insert (if description + (format " %s: %s (%s)\n" elt val description) + (format " %s: %s\n" elt val)))))) (if text-props-desc (insert text-props-desc)) (setq help-xref-stack-item (list 'help-insert-string (buffer-string))) - (toggle-read-only 1) - (print-help-return-message))))) + (toggle-read-only 1))))) -(defalias 'describe-char-after 'describe-char) -(make-obsolete 'describe-char-after 'describe-char "22.1") +(define-obsolete-function-alias 'describe-char-after 'describe-char "22.1") (provide 'descr-text)