From: Per Abrahamsen Date: Thu, 14 Feb 2002 16:47:11 +0000 (+0000) Subject: 2002-02-14 Per Abrahamsen X-Git-Tag: ttn-vms-21-2-B4~16681 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=0e520006a8a15f16971c5603c7821c03732ec23f;p=emacs.git 2002-02-14 Per Abrahamsen * facemenu.el (describe-text-done): New function. (describe-text-mode-map): New variable. (describe-text-mode-hook): New option. (describe-text-mode): New function. (describe-text-widget): New function. (describe-text-sexp): New function. (describe-text-properties): New function. (describe-text-category): New command. (describe-text-at): New command. (facemenu-menu): Replace `list-text-properties-at' with `describe-text-at' in the menu. * wid-edit.el (widgetp): New function. * wid-edit.el (widget-keymap, widget-insert, widget-setup): Autoloaded. * emacs-lisp/pp.el (pp-to-string): Autoloaded. * wid-browse.el: Removed version and x-url keywords. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index d78c26b5546..5650b1df7f7 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,26 @@ +2002-02-14 Per Abrahamsen + + * facemenu.el (describe-text-done): New function. + (describe-text-mode-map): New variable. + (describe-text-mode-hook): New option. + (describe-text-mode): New function. + (describe-text-widget): New function. + (describe-text-sexp): New function. + (describe-text-properties): New function. + (describe-text-category): New command. + (describe-text-at): New command. + (facemenu-menu): Replace `list-text-properties-at' with + `describe-text-at' in the menu. + (button): Require. + + * wid-edit.el (widgetp): New function. + * wid-edit.el (widget-keymap, widget-insert, widget-setup): + Autoloaded. + + * emacs-lisp/pp.el (pp-to-string): Autoloaded. + + * wid-browse.el: Removed version and x-url keywords. + 2002-02-13 Kim F. Storm * cus-start.el (mode-line-in-non-selected-windows): diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index c9b71f4f03d..b209c210c4f 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -36,6 +36,7 @@ :type 'boolean :group 'pp) +;;;###autoload (defun pp-to-string (object) "Return a string containing the pretty-printed representation of OBJECT. OBJECT can be any Lisp object. Quoting characters are used as needed diff --git a/lisp/facemenu.el b/lisp/facemenu.el index 7e44fa5012c..59e27e2dbd5 100644 --- a/lisp/facemenu.el +++ b/lisp/facemenu.el @@ -1,6 +1,6 @@ ;;; 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 ;; Keywords: faces @@ -94,6 +94,10 @@ (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,8 +244,8 @@ when they are created." (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") @@ -463,6 +467,177 @@ These special properties include `invisible', `intangible' and `read-only'." (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 , 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." diff --git a/lisp/wid-browse.el b/lisp/wid-browse.el index f93e1d9611a..eb5dac08fdf 100644 --- a/lisp/wid-browse.el +++ b/lisp/wid-browse.el @@ -4,8 +4,6 @@ ;; ;; Author: Per Abrahamsen ;; Keywords: extensions -;; Version: 1.9914 -;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;; This file is part of GNU Emacs. diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 6ef77a3bfd5..626f4c7c713 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1,6 +1,6 @@ ;;; wid-edit.el --- Functions for creating and using widgets -*-byte-compile-dynamic: t;-*- ;; -;; Copyright (C) 1996, 1997, 1999, 2000, 2001 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002 Free Software Foundation, Inc. ;; ;; Author: Per Abrahamsen ;; Maintainer: FSF @@ -468,6 +468,14 @@ new value.") "Return the type of WIDGET, a symbol." (car widget)) +;;;###autoload +(defun widgetp (widget) + "Return non-nil iff WIDGET is a widget." + (if (symbolp widget) + (get widget 'widget-type) + (and (consp widget) + (get (widget-type widget) 'widget-type)))) + (defun widget-get-indirect (widget property) "In WIDGET, get the value of PROPERTY. If the value is a symbol, return its binding. @@ -747,6 +755,7 @@ The optional ARGS are additional keyword arguments." ;; Return the newly create widget. widget)) +;;;###autoload (defun widget-insert (&rest args) "Call `insert' with ARGS even if surrounding text is read only." (let ((inhibit-read-only t) @@ -801,6 +810,7 @@ button end points." ;;; Keymap and Commands. +;;;###autoload (defvar widget-keymap (let ((map (make-sparse-keymap))) (define-key map "\t" 'widget-forward) @@ -1083,6 +1093,7 @@ When not inside a field, move to the previous button or field." (or (get-char-property (or pos (point)) 'button) (widget-field-at pos))) +;;;###autoload (defun widget-setup () "Setup current buffer so editing string widgets works." (let ((inhibit-read-only t)