;;; 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 <boris@gnu.org>
;; Maintainer: FSF
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; 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 3, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
(let ((pp (condition-case signal
(pp-to-string sexp)
(error (prin1-to-string signal)))))
- (when (string-match "\n\\'" pp)
+ (when (string-match-p "\n\\'" pp)
(setq pp (substring pp 0 (1- (length pp)))))
- (if (cond ((string-match "\n" pp)
- nil)
- ((> (length pp) (- (window-width) (current-column)))
- nil)
- (t t))
+
+ (if (and (not (string-match-p "\n" pp))
+ (<= (length pp) (- (window-width) (current-column))))
(insert pp)
(insert-text-button
"[Show]" 'action `(lambda (&rest ignore)
- (with-output-to-temp-buffer
- "*Pp Eval Output*"
- (princ ',pp)))
+ (with-output-to-temp-buffer
+ "*Pp Eval Output*"
+ (princ ',pp)))
'help-echo "mouse-2, RET: pretty print value in another buffer"))))
(defun describe-property-list (properties)
"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.
: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.
;; 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
(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
(cond
((and show-trailing-whitespace
(save-excursion (goto-char pos)
- (looking-at "[ \t]+$")))
+ (looking-at-p "[ \t]+$")))
'trailing-whitespace)
((and nobreak-char-display char (eq char '#xa0))
'nobreak-space)
,@(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)))
(if (eq (car-safe clm) 'insert-text-button)
(progn (insert " ") (eval clm))
(when (>= (+ (current-column)
- (or (string-match "\n" clm)
+ (or (string-match-p "\n" clm)
(string-width clm))
1)
(window-width))
(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")
(if (cadr composition)
(insert " with the following character(s) \""
(cadr 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))
+ (if (and (vectorp (nth 2 composition))
+ (vectorp (aref (nth 2 composition) 0)))
(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%02X)" (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"))
-
- (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)
HCoop / bpt / emacs.git / blobdiff