From: Per Abrahamsen <abraham@dina.kvl.dk>
Subject: List Text Properties
Date: Tue, 12 Feb 2002 16:25:06 +0100 [thread overview]
Message-ID: <rju1smwwml.fsf@ssv2.dina.kvl.dk> (raw)
A long time ago, I complained that
Edit -> Text Properties -> List Properties
did not list overlays, which made it hard to use it as a "here is some
weird text, what is going on?" tool, and got an OK to include
overlays in the list.
Here is an implementation that list widgets, buttons, overlays and
text properties. I called it `describe-text-at'. I'd like to replace
the call to `list-text-properties-at' in the menu with this function.
Is it ok to install?
Eval the code, and type `M-x describe-text-at <ret>' while point is
somewhere interesting to test.
;;;; Move to wid-edit.el:
;;;###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))))
;;;; Move to facemenu.el:
;;; 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 nil
"Keymap for `describe-text-mode'.")
(unless describe-text-mode-map
(setq describe-text-mode-map (make-sparse-keymap))
(set-keymap-parent describe-text-mode-map widget-keymap)
(define-key describe-text-mode-map "q" 'describe-text-done))
(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.
(define-widget 'describe-text-close 'push-button
"Add a `close' button."
:tag "Close"
:action (lambda (&rest ignore) (describe-text-done)))
(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 value)
(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))
(widget-insert "\n")
(widget-create 'describe-text-close)
(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 "Self inspection not supported"))
(when (get-buffer "*Text Description*")
(kill-buffer "*Text Description*"))
(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))
(button (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)))
(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 `"
(format "%S" 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))
(widget-insert "\n")
(widget-create 'describe-text-close)
(describe-text-mode)
(goto-char (point-min))))))
;;; Code to facemenu.el ends here.
_______________________________________________
Emacs-devel mailing list
Emacs-devel@gnu.org
http://mail.gnu.org/mailman/listinfo/emacs-devel
next reply other threads:[~2002-02-12 15:25 UTC|newest]
Thread overview: 4+ messages / expand[flat|nested] mbox.gz Atom feed top
2002-02-12 15:25 Per Abrahamsen [this message]
2002-02-14 3:11 ` List Text Properties Richard Stallman
2002-02-14 9:36 ` Per Abrahamsen
2002-02-14 16:49 ` Per Abrahamsen
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=rju1smwwml.fsf@ssv2.dina.kvl.dk \
--to=abraham@dina.kvl.dk \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).