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> 2002-02-13 Kim F. Storm <storm@cua.dk>
   
* cus-start.el (mode-line-in-non-selected-windows): * cus-start.el (mode-line-in-non-selected-windows):
......
...@@ -36,6 +36,7 @@ ...@@ -36,6 +36,7 @@
:type 'boolean :type 'boolean
:group 'pp) :group 'pp)
;;;###autoload
(defun pp-to-string (object) (defun pp-to-string (object)
"Return a string containing the pretty-printed representation of OBJECT. "Return a string containing the pretty-printed representation of OBJECT.
OBJECT can be any Lisp object. Quoting characters are used as needed OBJECT can be any Lisp object. Quoting characters are used as needed
......
;;; facemenu.el --- create a face menu for interactively adding fonts to text ;;; 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> ;; Author: Boris Goldowsky <boris@gnu.org>
;; Keywords: faces ;; Keywords: faces
...@@ -94,6 +94,10 @@ ...@@ -94,6 +94,10 @@
(provide 'facemenu) (provide 'facemenu)
(eval-when-compile
(require 'help)
(require 'button))
;;; Provide some binding for startup: ;;; Provide some binding for startup:
;;;###autoload (define-key global-map "\M-g" 'facemenu-keymap) ;;;###autoload (define-key global-map "\M-g" 'facemenu-keymap)
;;;###autoload (autoload 'facemenu-keymap "facemenu" "Keymap for face-changing commands." t 'keymap) ;;;###autoload (autoload 'facemenu-keymap "facemenu" "Keymap for face-changing commands." t 'keymap)
...@@ -240,8 +244,8 @@ when they are created." ...@@ -240,8 +244,8 @@ when they are created."
(let ((map facemenu-menu)) (let ((map facemenu-menu))
(define-key map [dc] (cons (purecopy "Display Colors") 'list-colors-display)) (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 [df] (cons (purecopy "Display Faces") 'list-faces-display))
(define-key map [dp] (cons (purecopy "List Properties") (define-key map [dp] (cons (purecopy "Describe Text")
'list-text-properties-at)) 'describe-text-at))
(define-key map [ra] (cons (purecopy "Remove Text Properties") (define-key map [ra] (cons (purecopy "Remove Text Properties")
'facemenu-remove-all)) 'facemenu-remove-all))
(define-key map [rm] (cons (purecopy "Remove Face Properties") (define-key map [rm] (cons (purecopy "Remove Face Properties")
...@@ -463,6 +467,177 @@ These special properties include `invisible', `intangible' and `read-only'." ...@@ -463,6 +467,177 @@ These special properties include `invisible', `intangible' and `read-only'."
(remove-text-properties (remove-text-properties
start end '(invisible nil intangible nil read-only nil)))) 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 ;;;###autoload
(defun list-text-properties-at (p) (defun list-text-properties-at (p)
"Pop up a buffer listing text-properties at LOCATION." "Pop up a buffer listing text-properties at LOCATION."
......
...@@ -4,8 +4,6 @@ ...@@ -4,8 +4,6 @@
;; ;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk> ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: extensions ;; Keywords: extensions
;; Version: 1.9914
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs. ;; This file is part of GNU Emacs.
......
;;; wid-edit.el --- Functions for creating and using widgets -*-byte-compile-dynamic: t;-*- ;;; 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> ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Maintainer: FSF ;; Maintainer: FSF
...@@ -468,6 +468,14 @@ new value.") ...@@ -468,6 +468,14 @@ new value.")
"Return the type of WIDGET, a symbol." "Return the type of WIDGET, a symbol."
(car widget)) (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) (defun widget-get-indirect (widget property)
"In WIDGET, get the value of PROPERTY. "In WIDGET, get the value of PROPERTY.
If the value is a symbol, return its binding. If the value is a symbol, return its binding.
...@@ -747,6 +755,7 @@ The optional ARGS are additional keyword arguments." ...@@ -747,6 +755,7 @@ The optional ARGS are additional keyword arguments."
;; Return the newly create widget. ;; Return the newly create widget.
widget)) widget))
;;;###autoload
(defun widget-insert (&rest args) (defun widget-insert (&rest args)
"Call `insert' with ARGS even if surrounding text is read only." "Call `insert' with ARGS even if surrounding text is read only."
(let ((inhibit-read-only t) (let ((inhibit-read-only t)
...@@ -801,6 +810,7 @@ button end points." ...@@ -801,6 +810,7 @@ button end points."
;;; Keymap and Commands. ;;; Keymap and Commands.
;;;###autoload
(defvar widget-keymap (defvar widget-keymap
(let ((map (make-sparse-keymap))) (let ((map (make-sparse-keymap)))
(define-key map "\t" 'widget-forward) (define-key map "\t" 'widget-forward)
...@@ -1083,6 +1093,7 @@ When not inside a field, move to the previous button or field." ...@@ -1083,6 +1093,7 @@ When not inside a field, move to the previous button or field."
(or (get-char-property (or pos (point)) 'button) (or (get-char-property (or pos (point)) 'button)
(widget-field-at pos))) (widget-field-at pos)))
;;;###autoload
(defun widget-setup () (defun widget-setup ()
"Setup current buffer so editing string widgets works." "Setup current buffer so editing string widgets works."
(let ((inhibit-read-only t) (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