[Emacs-diffs] Changes to emacs/lisp/facemenu.el

[Per Abrahamsen]

Index: emacs/lisp/facemenu.el
diff -c emacs/lisp/facemenu.el:1.57 emacs/lisp/facemenu.el:1.58
*** emacs/lisp/facemenu.el:1.57 Fri Jan 25 08:11:49 2002
--- emacs/lisp/facemenu.el      Thu Feb 14 11:47:11 2002
***************
*** 1,6 ****
  ;;; facemenu.el --- create a face menu for interactively adding fonts to text
  
! ;; Copyright (c) 1994, 1995, 1996, 2001 Free Software Foundation, Inc.
  
  ;; Author: Boris Goldowsky <address@hidden>
  ;; Keywords: faces
--- 1,6 ----
  ;;; facemenu.el --- create a face menu for interactively adding fonts to text
  
! ;; Copyright (c) 1994, 1995, 1996, 2001, 2002 Free Software Foundation, Inc.
  
  ;; Author: Boris Goldowsky <address@hidden>
  ;; Keywords: faces
***************
*** 94,99 ****
--- 94,103 ----
  
  (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)
***************
*** 240,247 ****
  (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 [ra] (cons (purecopy "Remove Text Properties")
                             'facemenu-remove-all))
    (define-key map [rm] (cons (purecopy "Remove Face Properties")
--- 244,251 ----
  (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 "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")
***************
*** 462,467 ****
--- 466,642 ----
    (let ((inhibit-read-only t))
      (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 <address@hidden>, 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)