Commit 0e520006 authored by Per Abrahamsen's avatar Per Abrahamsen
Browse files

2002-02-14 Per Abrahamsen <abraham@dina.kvl.dk>

	* 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.
parent 8df9f2a3
2002-02-14 Per Abrahamsen <abraham@dina.kvl.dk>
* 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 <storm@cua.dk>
* cus-start.el (mode-line-in-non-selected-windows):
......
......@@ -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
......
;;; 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
......@@ -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 <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."
......
......@@ -4,8 +4,6 @@
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: extensions
;; Version: 1.9914
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs.
......
;;; 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 <abraham@dina.kvl.dk>
;; 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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment