;;; facemenu.el --- create a face menu for interactively adding fonts to text
-;; Copyright (c) 1994, 1995, 1996, 2001 Free Software Foundation, Inc.
+;; Copyright (c) 1994, 1995, 1996, 2001, 2002 Free Software Foundation, Inc.
;; Author: Boris Goldowsky <boris@gnu.org>
;; Keywords: faces
(provide 'facemenu)
+(eval-when-compile
+ (require 'help)
+ (require 'button))
+
;;; Provide some binding for startup:
;;;###autoload (define-key global-map "\M-g" 'facemenu-keymap)
;;;###autoload (autoload 'facemenu-keymap "facemenu" "Keymap for face-changing commands." t 'keymap)
(let ((map facemenu-menu))
(define-key map [dc] (cons (purecopy "Display Colors") 'list-colors-display))
(define-key map [df] (cons (purecopy "Display Faces") 'list-faces-display))
- (define-key map [dp] (cons (purecopy "List Properties")
- 'list-text-properties-at))
+ (define-key map [dp] (cons (purecopy "Describe Text")
+ 'describe-text-at))
(define-key map [ra] (cons (purecopy "Remove Text Properties")
'facemenu-remove-all))
(define-key map [rm] (cons (purecopy "Remove Face Properties")
(remove-text-properties
start end '(invisible nil intangible nil read-only nil))))
+;;; Describe-Text Mode.
+
+(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)))
+ (if (boundp 'widget-keymap)
+ (set-keymap-parent map widget-keymap)
+ ;; Copy from wid-edit.el if widget-keymap isn't in loaddefs.el
+ ;; Needed for bootstrap purposes, can hopefully be removed when
+ ;; loaddefs.el is updated.
+ ;; -- Per Abrahamsen <abraham@dina.kvl.dk>, 2002-02-14.
+ (define-key map "\t" 'widget-forward)
+ (define-key map [(shift tab)] 'widget-backward)
+ (define-key map [backtab] 'widget-backward)
+ (define-key map [down-mouse-2] 'widget-button-click)
+ (define-key map "\C-m" 'widget-button-press))
+ (define-key map "q" 'describe-text-done)
+ map)
+ "Keymap for `describe-text-mode'.")
+
+(defcustom describe-text-mode-hook nil
+ "List of hook functions ran by `describe-text-mode'."
+ :type 'hook)
+
+(defun describe-text-mode ()
+ "Major mode for buffers created by `describe-text-at'.
+
+\\{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)
+ (run-hooks 'describe-text-mode-hook))
+
+;;; 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"))
+
+(defun describe-text-sexp (sexp)
+ "Insert a short description of SEXP in the current buffer."
+ (let ((pp (condition-case signal
+ (pp-to-string sexp)
+ (error (prin1-to-string signal)))))
+ (when (string-match "\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))
+ (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))))
+
+
+(defun describe-text-properties (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
+`describe-text-category' when pushed."
+ (while properties
+ (widget-insert (format " %-20s " (car properties)))
+ (let ((key (nth 0 properties))
+ (value (nth 1 properties)))
+ (cond ((eq key 'category)
+ (widget-create 'link
+ :notify `(lambda (&rest ignore)
+ (describe-text-category ',value))
+ (format "%S" value)))
+ ((widgetp value)
+ (describe-text-widget value))
+ (t
+ (describe-text-sexp value))))
+ (widget-insert "\n")
+ (setq properties (cdr (cdr properties)))))
+
+;;; Describe-Text Commands.
+
+(defun describe-text-category (category)
+ "Describe a text property category."
+ (interactive "S")
+ (when (get-buffer "*Text Category*")
+ (kill-buffer "*Text Category*"))
+ (save-excursion
+ (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-text-mode)
+ (goto-char (point-min)))))
+
+;;;###autoload
+(defun describe-text-at (pos)
+ "Describe widgets, buttons, overlays and text properties at POS."
+ (interactive "d")
+ (when (eq (current-buffer) (get-buffer "*Text Description*"))
+ (error "Can't do self inspection"))
+ (let* ((properties (text-properties-at pos))
+ (overlays (overlays-at pos))
+ overlay
+ (wid-field (get-char-property pos 'field))
+ (wid-button (get-char-property pos 'button))
+ (wid-doc (get-char-property pos 'widget-doc))
+ ;; If button.el is not loaded, we have no buttons in the text.
+ (button (and (fboundp 'button-at) (button-at pos)))
+ (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*"))
+ (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)))))))
+
+;;; List Text Properties
+
;;;###autoload
(defun list-text-properties-at (p)
"Pop up a buffer listing text-properties at LOCATION."
projects / emacs.git / commitdiff