From 4adb7c0968a15e528a36f720484a2c4d9e90c536 Mon Sep 17 00:00:00 2001 From: "Richard M. Stallman" Date: Mon, 17 Jun 2002 16:12:47 +0000 Subject: [PATCH] (describe-char): Moved from mule-diag.el, renamed from describe-char-after. Now calls describe-text-properties. (describe-property-list): Renamed from describe-text-properties. (describe-text-properties): Renamed from describe-text-at. New arg OUTPUT-BUFFER. (describe-text-properties-1): New subroutine, broken out from describe-text-properties. Output a newline before each section of the output. --- lisp/descr-text.el | 235 +++++++++++++++++++++++++++++++++++++-------- 1 file changed, 194 insertions(+), 41 deletions(-) diff --git a/lisp/descr-text.el b/lisp/descr-text.el index f1037e15db2..e75769078b0 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -46,7 +46,7 @@ :type 'hook) (defun describe-text-mode () - "Major mode for buffers created by `describe-text-at'. + "Major mode for buffers created by `describe-char'. \\{describe-text-mode-map} Entry to this mode calls the value of `describe-text-mode-hook' @@ -92,7 +92,7 @@ if that value is non-nil." (princ (widget-get widget :value)))) pp)))) -(defun describe-text-properties (properties) +(defun describe-property-list (properties) "Insert a description of PROPERTIES in the current buffer. PROPERTIES should be a list of overlay or text properties. The `category' property is made into a widget button that call @@ -141,16 +141,40 @@ The `category' property is made into a widget button that call (with-output-to-temp-buffer "*Text Category*" (set-buffer "*Text Category*") (widget-insert "Category " (format "%S" category) ":\n\n") - (describe-text-properties (symbol-plist category)) + (describe-property-list (symbol-plist category)) (describe-text-mode) (goto-char (point-min))))) ;;;###autoload -(defun describe-text-at (pos) - "Describe widgets, buttons, overlays and text properties at POS." +(defun describe-text-properties (pos &optional output-buffer) + "Describe widgets, buttons, overlays and text properties at POS. +Interactively, describe them for the character after point. +If optional second argument OUTPUT-BUFFER is non-nil, +insert the output into that buffer, and don't initialize or clear it +otherwise." (interactive "d") (when (eq (current-buffer) (get-buffer "*Text Description*")) (error "Can't do self inspection")) + (if (>= pos (point-max)) + (error "No character follows specified position")) + (if output-buffer + (describe-text-properties-1 pos output-buffer) + (if (not (or (text-properties-at pos) (overlays-at pos))) + (message "This is plain text.") + (when (get-buffer "*Text Description*") + (kill-buffer "*Text Description*")) + (let ((buffer (current-buffer))) + (save-excursion + (with-output-to-temp-buffer "*Text Description*" + (set-buffer "*Text Description*") + (setq output-buffer (current-buffer)) + (widget-insert "Text content at position " (format "%d" pos) ":\n\n") + (with-current-buffer buffer + (describe-text-properties-1 pos output-buffer)) + (describe-text-mode) + (goto-char (point-min)))))))) + +(defun describe-text-properties-1 (pos output-buffer) (let* ((properties (text-properties-at pos)) (overlays (overlays-at pos)) overlay @@ -162,43 +186,172 @@ The `category' property is made into a widget button that call (button-type (and button (button-type button))) (button-label (and button (button-label button))) (widget (or wid-field wid-button wid-doc))) - (if (not (or properties overlays)) - (message "This is plain text.") - (when (get-buffer "*Text Description*") - (kill-buffer "*Text Description*")) + (with-current-buffer output-buffer + ;; Widgets + (when (widgetp widget) + (newline) + (widget-insert (cond (wid-field "This is an editable text area") + (wid-button "This is an active area") + (wid-doc "This is documentation text"))) + (widget-insert " of a ") + (describe-text-widget widget) + (widget-insert ".\n\n")) + ;; Buttons + (when (and button (not (widgetp wid-button))) + (newline) + (widget-insert "Here is a " (format "%S" button-type) + " button labeled `" button-label "'.\n\n")) + ;; Overlays + (when overlays + (newline) + (if (eq (length overlays) 1) + (widget-insert "There is an overlay here:\n") + (widget-insert "There are " (format "%d" (length overlays)) + " overlays here:\n")) + (dolist (overlay overlays) + (widget-insert " From " (format "%d" (overlay-start overlay)) + " to " (format "%d" (overlay-end overlay)) "\n") + (describe-property-list (overlay-properties overlay))) + (widget-insert "\n")) + ;; Text properties + (when properties + (newline) + (widget-insert "There are text properties here:\n") + (describe-property-list properties))))) + +;;;###autoload +(defun describe-char (pos) + "Describe the character after POS (interactively, the character after point). +The information includes character code, charset and code points in it, +syntax, category, how the character is encoded in a file, +character composition information (if relevant), +as well as widgets, buttons, overlays, and text properties." + (interactive "d") + (when (eq (current-buffer) (get-buffer "*Text Description*")) + (error "Can't do self inspection")) + (if (>= pos (point-max)) + (error "No character follows specified position")) + (let* ((char (char-after pos)) + (charset (char-charset char)) + (buffer (current-buffer)) + (composition (find-composition (point) nil nil t)) + (composed (if composition (buffer-substring (car composition) + (nth 1 composition)))) + (multibyte-p enable-multibyte-characters) + item-list max-width) + (if (eq charset 'unknown) + (setq item-list + `(("character" + ,(format "%s (0%o, %d, 0x%x) -- invalid character code" + (if (< char 256) + (single-key-description char) + (char-to-string char)) + char char char)))) + (setq item-list + `(("character" + ,(format "%s (0%o, %d, 0x%x)" (if (< char 256) + (single-key-description char) + (char-to-string char)) + char char char)) + ("charset" + ,(symbol-name charset) + ,(format "(%s)" (charset-description charset))) + ("code point" + ,(let ((split (split-char char))) + (if (= (charset-dimension charset) 1) + (format "%d" (nth 1 split)) + (format "%d %d" (nth 1 split) (nth 2 split))))) + ("syntax" + ,(let ((syntax (get-char-property (point) 'syntax-table))) + (with-temp-buffer + (internal-describe-syntax-value + (if (consp syntax) syntax + (aref (or syntax (syntax-table)) char))) + (buffer-string)))) + ("category" + ,@(let ((category-set (char-category-set char))) + (if (not category-set) + '("-- none --") + (mapcar #'(lambda (x) (format "%c:%s " + x (category-docstring x))) + (category-set-mnemonics category-set))))) + ,@(let ((props (aref char-code-property-table char)) + ps) + (when props + (while props + (push (format "%s:" (pop props)) ps) + (push (format "%s;" (pop props)) ps)) + (list (cons "Properties" (nreverse ps))))) + ("buffer code" + ,(encoded-string-description + (string-as-unibyte (char-to-string char)) nil)) + ("file code" + ,@(let* ((coding buffer-file-coding-system) + (encoded (encode-coding-char char coding))) + (if encoded + (list (encoded-string-description encoded coding) + (format "(encoded by coding system %S)" coding)) + (list "not encodable by coding system" + (symbol-name coding))))) + ,@(if (or (memq 'mule-utf-8 + (find-coding-systems-region (point) (1+ (point)))) + (get-char-property (point) 'untranslated-utf-8)) + (let ((uc (or (get-char-property (point) + 'untranslated-utf-8) + (encode-char (char-after) 'ucs)))) + (if uc + (list (list "Unicode" + (format "%04X" uc)))))) + ,(if (display-graphic-p (selected-frame)) + (list "font" (or (internal-char-font (point)) + "-- none --")) + (list "terminal code" + (let* ((coding (terminal-coding-system)) + (encoded (encode-coding-char char coding))) + (if encoded + (encoded-string-description encoded coding) + "not encodable"))))))) + (setq max-width (apply #'max (mapcar #'(lambda (x) (length (car x))) + item-list))) + (when (get-buffer "*Help*") + (kill-buffer "*Help*")) + (with-output-to-temp-buffer "*Help*" (save-excursion - (with-output-to-temp-buffer "*Text Description*" - (set-buffer "*Text Description*") - (widget-insert "Text content at position " (format "%d" pos) ":\n\n") - ;; Widgets - (when (widgetp widget) - (widget-insert (cond (wid-field "This is an editable text area") - (wid-button "This is an active area") - (wid-doc "This is documentation text"))) - (widget-insert " of a ") - (describe-text-widget widget) - (widget-insert ".\n\n")) - ;; Buttons - (when (and button (not (widgetp wid-button))) - (widget-insert "Here is a " (format "%S" button-type) - " button labeled `" button-label "'.\n\n")) - ;; Overlays - (when overlays - (if (eq (length overlays) 1) - (widget-insert "There is an overlay here:\n") - (widget-insert "There are " (format "%d" (length overlays)) - " overlays here:\n")) - (dolist (overlay overlays) - (widget-insert " From " (format "%d" (overlay-start overlay)) - " to " (format "%d" (overlay-end overlay)) "\n") - (describe-text-properties (overlay-properties overlay))) - (widget-insert "\n")) - ;; Text properties - (when properties - (widget-insert "There are text properties here:\n") - (describe-text-properties properties)) - (describe-text-mode) - (goto-char (point-min))))))) + (set-buffer standard-output) + (set-buffer-multibyte multibyte-p) + (let ((formatter (format "%%%ds:" max-width))) + (dolist (elt item-list) + (insert (format formatter (car elt))) + (dolist (clm (cdr elt)) + (when (>= (+ (current-column) + (or (string-match "\n" clm) + (string-width clm)) 1) + (frame-width)) + (insert "\n") + (indent-to (1+ max-width))) + (insert " " clm)) + (insert "\n"))) + (when composition + (insert "\nComposed with the following character(s) " + (mapconcat (lambda (x) (format "`%c'" x)) + (substring composed 1) + ", ") + " to form `" composed "'") + (if (nth 3 composition) + (insert ".\n") + (insert "\nby the rule (" + (mapconcat (lambda (x) + (format (if (consp x) "%S" "?%c") x)) + (nth 2 composition) + " ") + ").\n" + "See the variable `reference-point-alist' for " + "the meaning of the rule.\n"))) + + (let ((output (current-buffer))) + (with-current-buffer buffer + (describe-text-properties pos output)) + (describe-text-mode)))))) (provide 'descr-text) -- 2.39.2