X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/cbfde7a0798d4218e7638ef756d22f51d1a68a42..89aab5d47c1ee4b0851c90ef179bf5b350baa8cd:/lisp/descr-text.el diff --git a/lisp/descr-text.el b/lisp/descr-text.el index e206e2c269..6200be63d6 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -1,9 +1,10 @@ ;;; descr-text.el --- describe text mode -;; Copyright (c) 1994, 1995, 1996, 2001, 2002, 2003, 2004, 2005 -;; Free Software Foundation, Inc. +;; Copyright (C) 1994, 1995, 1996, 2001, 2002, 2003, 2004, +;; 2005, 2006 Free Software Foundation, Inc. ;; Author: Boris Goldowsky +;; Maintainer: FSF ;; Keywords: faces, i18n, Unicode, multilingual ;; This file is part of GNU Emacs. @@ -29,52 +30,21 @@ ;;; Code: -(eval-when-compile (require 'button) (require 'quail)) - -(defun describe-text-done () - "Delete the current window or bury the current buffer." - (interactive) - (if (> (count-windows) 1) - (delete-window) - (bury-buffer))) - -(defvar describe-text-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map widget-keymap) - map) - "Keymap for `describe-text-mode'.") - -(defcustom describe-text-mode-hook nil - "List of hook functions ran by `describe-text-mode'." - :type 'hook - :group 'facemenu) - -(defun describe-text-mode () - "Major mode for buffers created by `describe-char'. - -\\{describe-text-mode-map} -Entry to this mode calls the value of `describe-text-mode-hook' -if that value is non-nil." - (kill-all-local-variables) - (setq major-mode 'describe-text-mode - mode-name "Describe-Text") - (use-local-map describe-text-mode-map) - (widget-setup) - (add-hook 'change-major-mode-hook 'font-lock-defontify nil t) - (run-mode-hooks 'describe-text-mode-hook)) +(eval-when-compile (require 'quail)) +(require 'help-fns) ;;; Describe-Text Utilities. (defun describe-text-widget (widget) "Insert text to describe WIDGET in the current buffer." - (widget-create 'link - :notify `(lambda (&rest ignore) - (widget-browse ',widget)) - (format "%S" (if (symbolp widget) - widget - (car widget)))) - (widget-insert " ") - (widget-create 'info-link :tag "widget" "(widget)Top")) + (insert-text-button + (symbol-name (if (symbolp widget) widget (car widget))) + 'action `(lambda (&rest ignore) + (widget-browse ',widget)) + 'help-echo "mouse-2, RET: browse this widget") + (insert " ") + (insert-text-button + "(widget)Top" 'type 'help-info 'help-args '("(widget)Top"))) (defun describe-text-sexp (sexp) "Insert a short description of SEXP in the current buffer." @@ -88,58 +58,58 @@ if that value is non-nil." ((> (length pp) (- (window-width) (current-column))) nil) (t t)) - (widget-insert pp) - (widget-create 'push-button - :tag "show" - :action (lambda (widget &optional event) - (with-output-to-temp-buffer - "*Pp Eval Output*" - (princ (widget-get widget :value)))) - pp)))) + (insert pp) + (insert-text-button + "[Show]" 'action `(lambda (&rest ignore) + (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) "Insert a description of PROPERTIES in the current buffer. PROPERTIES should be a list of overlay or text properties. The `category', `face' and `font-lock-face' properties are made -into widget buttons that call `describe-text-category' or +into help buttons that call `describe-text-category' or `describe-face' when pushed." ;; Sort the properties by the size of their value. (dolist (elt (sort (let (ret) (while properties (push (list (pop properties) (pop properties)) ret)) ret) - (lambda (a b) (string< (nth 0 a) (nth 0 b))))) + (lambda (a b) (string< (prin1-to-string (nth 0 a) t) + (prin1-to-string (nth 0 b) t))))) (let ((key (nth 0 elt)) (value (nth 1 elt))) - (widget-insert (propertize (format " %-20s " key) - 'font-lock-face 'italic)) + (insert (propertize (format " %-20s " key) + 'face 'help-argument-name)) (cond ((eq key 'category) - (widget-create 'link - :notify `(lambda (&rest ignore) - (describe-text-category ',value)) - (format "%S" value))) + (insert-text-button + (symbol-name value) + 'action `(lambda (&rest ignore) + (describe-text-category ',value)) + 'help-echo "mouse-2, RET: describe this category")) ((memq key '(face font-lock-face mouse-face)) - (widget-create 'link - :notify `(lambda (&rest ignore) - (describe-face ',value)) - (format "%S" value))) + (insert-text-button + (format "%S" value) + 'type 'help-face 'help-args (list value))) ((widgetp value) (describe-text-widget value)) (t (describe-text-sexp value)))) - (widget-insert "\n"))) + (insert "\n"))) ;;; Describe-Text Commands. (defun describe-text-category (category) "Describe a text property category." - (interactive "S") + (interactive "SCategory: ") + (help-setup-xref (list #'describe-text-category category) (interactive-p)) (save-excursion (with-output-to-temp-buffer "*Help*" (set-buffer standard-output) - (widget-insert "Category " (format "%S" category) ":\n\n") + (insert "Category " (format "%S" category) ":\n\n") (describe-property-list (symbol-plist category)) - (describe-text-mode) (goto-char (point-min))))) ;;;###autoload @@ -159,15 +129,14 @@ otherwise." (let ((buffer (current-buffer)) (target-buffer "*Help*")) (when (eq buffer (get-buffer target-buffer)) - (setq target-buffer "*Help-2*")) + (setq target-buffer "*Help*<2>")) (save-excursion (with-output-to-temp-buffer target-buffer (set-buffer standard-output) (setq output-buffer (current-buffer)) - (widget-insert "Text content at position " (format "%d" pos) ":\n\n") + (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) @@ -185,33 +154,33 @@ otherwise." ;; 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 ") + (insert (cond (wid-field "This is an editable text area") + (wid-button "This is an active area") + (wid-doc "This is documentation text"))) + (insert " of a ") (describe-text-widget widget) - (widget-insert ".\n\n")) + (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")) + (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)) + (insert "There is an overlay here:\n") + (insert "There are " (format "%d" (length overlays)) " overlays here:\n")) (dolist (overlay overlays) - (widget-insert " From " (format "%d" (overlay-start overlay)) + (insert " From " (format "%d" (overlay-start overlay)) " to " (format "%d" (overlay-end overlay)) "\n") (describe-property-list (overlay-properties overlay))) - (widget-insert "\n")) + (insert "\n")) ;; Text properties (when properties (newline) - (widget-insert "There are text properties here:\n") + (insert "There are text properties here:\n") (describe-property-list properties))))) (defcustom describe-char-unicodedata-file nil @@ -222,8 +191,8 @@ looked up from it. This facility is mostly of use to people doing multilingual development. This is a fairly large file, not typically present on GNU systems. At -the time of writing it is at -." +the time of writing it is at the URL +`http://www.unicode.org/Public/UNIDATA/UnicodeData.txt'." :group 'mule :version "22.1" :type '(choice (const :tag "None" nil) @@ -457,6 +426,19 @@ as well as widgets, buttons, overlays, and text properties." (multibyte-p enable-multibyte-characters) (overlays (mapcar #'(lambda (o) (overlay-properties o)) (overlays-at pos))) + (char-description (if (not multibyte-p) + (single-key-description char) + (if (< char 128) + (single-key-description char) + (string-to-multibyte + (char-to-string char))))) + (text-props-desc + (let ((tmp-buf (generate-new-buffer " *text-props*"))) + (unwind-protect + (progn + (describe-text-properties pos tmp-buf) + (with-current-buffer tmp-buf (buffer-string))) + (kill-buffer tmp-buf)))) item-list max-width unicode) (if (or (< char 256) @@ -466,40 +448,36 @@ as well as widgets, buttons, overlays, and text properties." (encode-char char 'ucs)))) (setq item-list `(("character" - ,(format "%s (0%o, %d, 0x%x%s)" - (apply 'propertize (if (not multibyte-p) - (single-key-description char) - (if (< char 128) - (single-key-description char) - (string-to-multibyte - (char-to-string char)))) - (text-properties-at pos)) - char char char - (if unicode - (format ", U+%04X" unicode) - ""))) + ,(format "%s (%d, #o%o, #x%x%s)" + (apply 'propertize char-description + (text-properties-at pos)) + char char char + (if unicode + (format ", U+%04X" unicode) + ""))) ("charset" - ,`(widget-create 'link - :notify (lambda (&rest ignore) - (describe-character-set ',charset)) - ,(symbol-name charset)) + ,`(insert-text-button + ,(symbol-name charset) + 'type 'help-character-set 'help-args '(,charset)) ,(format "(%s)" (charset-description charset))) ("code point" ,(let ((split (split-char char))) - `(widget-create - 'link - :notify (lambda (&rest ignore) + `(insert-text-button + ,(if (= (charset-dimension charset) 1) + (format "#x%02X" (nth 1 split)) + (format "#x%02X #x%02X" (nth 1 split) + (nth 2 split))) + 'action (lambda (&rest ignore) (list-charset-chars ',charset) (with-selected-window (get-buffer-window "*Character List*" 0) (goto-char (point-min)) - (forward-line 2) ;Skip the header. - (let ((case-fold-search nil)) - (search-forward ,(char-to-string char) - nil t)))) - ,(if (= (charset-dimension charset) 1) - (format "%d" (nth 1 split)) - (format "%d %d" (nth 1 split) (nth 2 split)))))) + (forward-line 2) ;Skip the header. + (let ((case-fold-search nil)) + (search-forward ,(char-to-string char) + nil t)))) + 'help-echo + "mouse-2, RET: show this character in its character set"))) ("syntax" ,(let ((syntax (syntax-after pos))) (with-temp-buffer @@ -509,7 +487,7 @@ as well as widgets, buttons, overlays, and text properties." ,@(let ((category-set (char-category-set char))) (if (not category-set) '("-- none --") - (mapcar #'(lambda (x) (format "%c:%s " + (mapcar #'(lambda (x) (format "%c:%s" x (category-docstring x))) (category-set-mnemonics category-set))))) ,@(let ((props (aref char-code-property-table char)) @@ -528,12 +506,10 @@ as well as widgets, buttons, overlays, and text properties." (mapconcat #'(lambda (x) (concat "\"" x "\"")) key-list " or ") "with" - `(widget-create - 'link - :notify (lambda (&rest ignore) - (describe-input-method - ',current-input-method)) - ,(format "%s" current-input-method)))))) + `(insert-text-button + ,current-input-method + 'type 'help-input-method + 'help-args '(,current-input-method)))))) ("buffer code" ,(encoded-string-description (string-as-unibyte (char-to-string char)) nil)) @@ -582,7 +558,7 @@ as well as widgets, buttons, overlays, and text properties." (if display (concat "by this font (glyph code)\n" - (format " %s (0x%02X)" + (format " %s (#x%02X)" (car display) (cdr display))) "no font available") (if display @@ -602,11 +578,9 @@ as well as widgets, buttons, overlays, and text properties." ((and (< char 32) (not (memq char '(9 10)))) 'escape-glyph))))) (if face (list (list "hardcoded face" - `(widget-create - 'link - :notify (lambda (&rest ignore) - (describe-face ',face)) - ,(format "%s" face)))))) + `(insert-text-button + ,(symbol-name face) + 'type 'help-face 'help-args '(,face)))))) ,@(let ((unicodedata (and unicode (describe-char-unicode-data unicode)))) (if unicodedata @@ -614,7 +588,8 @@ as well as widgets, buttons, overlays, and text properties." (setq max-width (apply #'max (mapcar #'(lambda (x) (if (cadr x) (length (car x)) 0)) item-list))) - (with-output-to-temp-buffer "*Help*" + (help-setup-xref nil (interactive-p)) + (with-output-to-temp-buffer (help-buffer) (with-current-buffer standard-output (set-buffer-multibyte multibyte-p) (let ((formatter (format "%%%ds:" max-width))) @@ -622,7 +597,7 @@ as well as widgets, buttons, overlays, and text properties." (when (cadr elt) (insert (format formatter (car elt))) (dolist (clm (cdr elt)) - (if (eq (car-safe clm) 'widget-create) + (if (eq (car-safe clm) 'insert-text-button) (progn (insert " ") (eval clm)) (when (>= (+ (current-column) (or (string-match "\n" clm) @@ -634,17 +609,17 @@ as well as widgets, buttons, overlays, and text properties." (insert " " clm))) (insert "\n")))) - (save-excursion - (goto-char (point-min)) - (re-search-forward "character:[ \t\n]+") - (setq pos (point))) - (if overlays - (mapc #'(lambda (props) - (let ((o (make-overlay pos (1+ pos)))) - (while props - (overlay-put o (car props) (nth 1 props)) - (setq props (cddr props))))) - overlays)) + (when overlays + (save-excursion + (goto-char (point-min)) + (re-search-forward "character:[ \t\n]+") + (let* ((end (+ (point) (length char-description)))) + (mapc #'(lambda (props) + (let ((o (make-overlay (point) end))) + (while props + (overlay-put o (car props) (nth 1 props)) + (setq props (cddr props))))) + overlays)))) (when disp-vector (insert @@ -656,23 +631,21 @@ as well as widgets, buttons, overlays, and text properties." (insert (logand (car (aref disp-vector i)) #x7ffff) ?: (propertize " " 'display '(space :align-to 5)) (if (cdr (aref disp-vector i)) - (format "%s (0x%02X)" (cadr (aref disp-vector i)) + (format "%s (#x%02X)" (cadr (aref disp-vector i)) (cddr (aref disp-vector i))) "-- no font --") "\n") (when (> (car (aref disp-vector i)) #x7ffff) (let* ((face-id (lsh (car (aref disp-vector i)) -19)) - (face (car (delq nil (mapcar (lambda (face) - (and (eq (face-id face) - face-id) face)) - (face-list)))))) + (face (car (delq nil (mapcar + (lambda (face) + (and (eq (face-id face) + face-id) face)) + (face-list)))))) (when face (insert (propertize " " 'display '(space :align-to 5)) "face: ") - (widget-create 'link - :notify `(lambda (&rest ignore) - (describe-face ',face)) - (format "%S" face)) + (insert (concat "`" (symbol-name face) "'")) (insert "\n")))))) (insert "these terminal codes:\n") (dotimes (i (length disp-vector)) @@ -707,7 +680,7 @@ as well as widgets, buttons, overlays, and text properties." (insert "\n " (car elt) ?: (propertize " " 'display '(space :align-to 5)) (if (cdr elt) - (format "%s (0x%02X)" (cadr elt) (cddr elt)) + (format "%s (#x%02X)" (cadr elt) (cddr elt)) "-- no font --")))) (insert "these terminal codes:") (dolist (elt component-chars) @@ -717,8 +690,10 @@ as well as widgets, buttons, overlays, and text properties." (insert "\nSee the variable `reference-point-alist' for " "the meaning of the rule.\n")) - (describe-text-properties pos (current-buffer)) - (describe-text-mode))))) + (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))))) (defalias 'describe-char-after 'describe-char) (make-obsolete 'describe-char-after 'describe-char "22.1")