1 ;; This is a test file for some enhancement to the possibilities to
2 ;; find out about widgets or buttons at point in a buffer.
4 ;; To use this just load the file. Then put point on a widget or
9 ;; You find a lot of widgets in a Custom buffer. You can find buttons
10 ;; in for example a help buffer. (Please tell me more places so I can
13 ;; TODO: Add backtrace collecting to some more functions!
15 ;; For widget-get-backtrace-info
17 (eval-when-compile (require 'cl)) ;; gensym
23 (intern ":created-in-function")
25 (define-widget 'widget-browse-link 'item
26 "Button for creating a link style button.
27 The :value of the widget shuld be the widget to be browsed."
29 ;;:value-create 'widget-browse-value-create
30 ;;:action 'widget-browse-action
33 (defun define-button-type (name &rest properties)
34 "Define a `button type' called NAME.
35 The remaining arguments form a sequence of PROPERTY VALUE pairs,
36 specifying properties to use as defaults for buttons with this type
37 \(a button's type may be set by giving it a `type' property when
38 creating the button, using the :type keyword argument).
40 In addition, the keyword argument :supertype may be used to specify a
41 button-type from which NAME inherits its default property values
42 \(however, the inheritance happens only when NAME is defined; subsequent
43 changes to a supertype are not reflected in its subtypes)."
44 (let ((catsym (make-symbol (concat (symbol-name name) "-button")))
46 (button-category-symbol
47 (or (plist-get properties 'supertype)
48 (plist-get properties :supertype)
50 ;; Provide a link so that it's easy to find the real symbol.
51 (put name 'button-category-symbol catsym)
52 ;; Initialize NAME's properties using the global defaults.
53 (let ((default-props (symbol-plist super-catsym))
54 (where-fun (widget-get-backtrace-info 8)))
56 (cons :created-in-function
60 (put catsym (pop default-props) (pop default-props))))
61 ;; Add NAME as the `type' property, which will then be returned as
62 ;; the type property of individual buttons.
63 (put catsym 'type name)
64 ;; Add the properties in PROPERTIES to the real symbol.
66 (let ((prop (pop properties)))
67 (when (eq prop :supertype)
68 (setq prop 'supertype))
69 (put catsym prop (pop properties))))
70 ;; Make sure there's a `supertype' property
71 (unless (get catsym 'supertype)
72 (put catsym 'supertype 'button))
75 (defun define-widget (name class doc &rest args)
76 "Define a new widget type named NAME from CLASS.
78 NAME and CLASS should both be symbols, CLASS should be one of the
79 existing widget types, or nil to create the widget from scratch.
81 After the new widget has been defined, the following two calls will
82 create identical widgets:
84 * (widget-create NAME)
86 * (apply 'widget-create CLASS ARGS)
88 The third argument DOC is a documentation string for the widget."
89 (put name 'widget-type (cons class args))
90 (put name 'widget-documentation doc)
91 (put name :created-in-function (widget-get-backtrace-info 8))
94 (defvar describe-temp-help-buffer nil)
95 (defun describe-get-temp-help-buffer ()
96 (setq describe-temp-help-buffer (get-buffer-create "*Copy of *Help* Buffer for Description*")))
98 (defun describe-field (pos)
99 "Describe field at marker POS."
100 (interactive (list (point)))
101 (unless (markerp pos) (setq pos (copy-marker pos)))
102 (when (eq (marker-buffer pos) (get-buffer (help-buffer)))
103 (with-current-buffer (describe-get-temp-help-buffer)
105 (insert (with-current-buffer (help-buffer)
107 (goto-char (marker-position pos))
108 (setq pos (point-marker))))
109 (let (field wbutton doc button widget)
110 (with-current-buffer (marker-buffer pos)
111 (setq field (get-char-property pos 'field))
112 (setq wbutton (get-char-property pos 'button))
113 (setq doc (get-char-property pos 'widget-doc))
114 (setq button (button-at pos))
115 (setq widget (or field wbutton doc)))
118 (get widget 'widget-type)
120 (get (widget-type widget) 'widget-type))))
121 (describe-widget pos))
123 (describe-button pos))
124 ((and (eq major-mode 'Info-mode)
125 (memq (get-text-property pos 'font-lock-face)
126 '(info-xref info-xref-visited)))
127 (message "info link"))
129 (message "No widget or button at point")))))
131 (defun describe-insert-header (pos)
135 (format "Description of the field at position %d in "
136 (marker-position pos))
137 (format "\"%s\"" (marker-buffer pos))
141 (defun describe-widget (pos)
142 ;;(interactive (list (point-marker)))
143 (unless (markerp pos) (setq pos (copy-marker pos)))
144 (with-output-to-temp-buffer (help-buffer)
145 (help-setup-xref (list #'describe-widget pos) (interactive-p))
146 (with-current-buffer (help-buffer)
147 (let ((inhibit-read-only t))
148 (describe-insert-header pos)
149 (insert-text-button "This field"
150 'action (lambda (button)
151 (let* ((m (button-get button 'field-location))
152 (p (marker-position m))
153 (b (marker-buffer m)))
154 (if (not (buffer-live-p b))
155 (message "Sorry the markers buffer is gone")
159 (princ " is of type ")
160 (insert-text-button "widget"
161 'action (lambda (button)
164 (insert-text-button "browse the widget's properties"
165 'action (lambda (button)
167 (button-get button 'field-location)))
168 'field-location pos))
169 (princ " to find out more about it.")
170 (fill-region (point-min) (point-max))
172 (with-no-warnings (print-help-return-message))))
174 (defun describe-button (pos)
175 (let ((button (button-at pos)))
176 (with-output-to-temp-buffer (help-buffer)
177 (help-setup-xref (list #'describe-button pos) (interactive-p))
178 (with-current-buffer (help-buffer)
179 (let ((inhibit-read-only t)
180 ;;(button-marker (gensym))
182 (describe-insert-header pos)
183 (insert-text-button "This field"
184 'action (lambda (button)
185 (let* ((m (button-get button 'field-location))
186 (p (marker-position m))
187 (b (marker-buffer m)))
191 (princ " is of type ")
192 (insert-text-button "button"
193 'action (lambda (button)
194 (info "(elisp) Buttons")))
196 ;;(set button-marker pos)
197 (insert-text-button "browse the button's properties"
198 'action `(lambda (button)
199 ;;(button-browse-at (symbol-value ',button-marker)))))
200 (button-browse-at ,pos))))
201 (princ " to find out more about it.")
202 (fill-region (point-min) (point-max))
204 (with-no-warnings (print-help-return-message)))))
207 ;; (defun whelp-describe-symbol (sym)
208 ;; (interactive "SSymbol: ")
209 ;; (with-output-to-temp-buffer (help-buffer)
210 ;; (help-setup-xref (list #'describe-symbol sym) (interactive-p))
211 ;; (with-current-buffer (help-buffer)
212 ;; (let ((inhibit-read-only t))
213 ;; (if (not (symbolp sym))
215 ;; (princ "Argument does not look like it is a ")
216 ;; (insert-text-button "symbol"
217 ;; 'action (lambda (button)
218 ;; (info "(elisp) Symbols")))
221 ;; (when (fboundp sym) (setq n (1+ n)))
222 ;; (when (boundp sym) (setq n (1+ n)))
223 ;; (when (facep sym) (setq n (1+ n)))
224 ;; (when (custom-group-p sym) (setq n (1+ n)))
227 ;; (princ "Can't determine usage for the ")
228 ;; (insert-text-button "symbol"
229 ;; 'action (lambda (button)
230 ;; (info "(elisp) Symbols")))
232 ;; (princ (symbol-name sym))
235 ;; (insert-text-button "symbol"
236 ;; 'action (lambda (button)
237 ;; (info "(elisp) Symbols")))
239 ;; (princ (symbol-name sym))
243 ;; (cond ((fboundp sym)
244 ;; (princ "function (")
245 ;; (insert-text-button
247 ;; 'action (lambda (button)
248 ;; (let ((value (button-get button 'value)))
249 ;; (describe-function value)))
253 ;; (insert "variable (")
254 ;; (insert-text-button
256 ;; 'action (lambda (button)
257 ;; (let ((value (button-get button 'value)))
258 ;; (describe-variable value)))
263 ;; (insert-text-button
265 ;; 'action (lambda (button)
266 ;; (let ((value (button-get button 'value)))
267 ;; (describe-face value)))
270 ;; ((custom-group-p sym)
271 ;; (insert "customize group (")
272 ;; (insert-text-button
274 ;; 'action (lambda (button)
275 ;; (let ((value (button-get button 'value)))
276 ;; (customize-group value)))
280 ;; (princ " has several usages currently.")
281 ;; (princ " It can be:\n\n")
282 ;; (when (fboundp sym)
283 ;; (princ " - A function (")
284 ;; (insert-text-button "describe it"
285 ;; 'action (lambda (button)
286 ;; (let ((value (button-get button 'value)))
287 ;; (describe-function value)))
290 ;; (when (boundp sym)
291 ;; (princ " - A variable (")
292 ;; (insert-text-button "describe it"
293 ;; 'action (lambda (button)
294 ;; (let ((value (button-get button 'value)))
295 ;; (describe-variable value)))
299 ;; (princ " - A face (")
300 ;; (insert-text-button "describe it"
301 ;; 'action (lambda (button)
302 ;; (let ((value (button-get button 'value)))
303 ;; (describe-face value)))
306 ;; (when (custom-group-p sym)
307 ;; (princ " - A customization group (")
308 ;; (insert-text-button "customize it"
309 ;; 'action (lambda (button)
310 ;; (let ((value (button-get button 'value)))
311 ;; (customize-group value)))
315 ;; (princ "\n\nSymbol's property list:\n\n")
316 ;; (let ((pl (symbol-plist sym))
319 ;; (princ (format " %25s %s\n" "Key" "Value"))
320 ;; (princ (format " %25s %s\n" "---" "-----"))
322 ;; (setq key (car pl))
323 ;; (setq pl (cdr pl))
324 ;; (setq val (car pl))
325 ;; (setq pl (cdr pl))
326 ;; (let ((first (point-marker))
328 ;; (princ (format " %25s - %s" key val))
329 ;; (setq last (point-marker))
330 ;; (let ((adaptive-fill-function
332 ;; (format " %25s - " key))))
333 ;; (fill-region first last)
337 ;; (with-no-warnings (print-help-return-message))))))
341 (defun widget-browse-sexp (widget key value)
342 "Insert description of WIDGET's KEY VALUE.
343 Nothing is assumed about value."
344 (let ((pp (condition-case signal
346 (error (prin1-to-string signal)))))
347 (when (string-match "\n\\'" pp)
348 (setq pp (substring pp 0 (1- (length pp)))))
349 (if (cond ((string-match "\n" pp)
351 ((> (length pp) (- (window-width) (current-column)))
360 (widget-create 'push-button
363 :action '(lambda (widget &optional event)
364 (let ((value (widget-get widget :value))
366 (when (fboundp value) (setq n (1+ n)))
367 (when (boundp value) (setq n (1+ n)))
368 (when (facep value) (setq n (1+ n)))
370 (cond ((fboundp value)
371 (describe-function value))
373 (describe-variable value))
375 (describe-face value)))
376 (describe-symbol value))))))
378 (widget-create 'push-button
380 :value (list (marker-position value) (marker-buffer value))
381 :action '(lambda (widget &optional event)
382 (let ((value (widget-get widget :value)))
383 (let ((pos (car value))
385 (switch-to-buffer-other-window buf)
388 (widget-create 'push-button
390 :value (list (overlay-start value) (overlay-buffer value))
391 :action '(lambda (widget &optional event)
392 (let ((value (widget-get widget :value)))
393 (let ((pos (car value))
395 (switch-to-buffer-other-window buf)
400 (widget-create 'push-button
402 :action (lambda (widget &optional event)
403 (with-output-to-temp-buffer
405 (princ (widget-get widget :value))))
409 (defvar widget-get-backtrace-active t
410 "Whether to collect backtrace info for widgets and buttons.
411 Turn this on only for debugging purposes.
413 Note: This must be t when Emacs is loading to collect the needed
416 (defun widget-get-backtrace-info (n)
417 (if widget-get-backtrace-active
422 (setq frame-n (backtrace-frame n))
424 ;;(message "**BT %s: %s" n (cadr frame-n))
426 (setq fun (cadr frame-n))
427 (when (or (listp fun)
431 widget-get-backtrace-info
456 widget-create-child-and-convert
458 widget-create-child-value
468 ;;(message "---------- fun=%s" fun)
470 "Set widget-get-backtrace-info to show this"))
472 (defun widget-create (type &rest args)
473 "Create widget of TYPE.
474 The optional ARGS are additional keyword arguments."
475 (unless (keywordp :created-in-function) (error ":wcw not interned"))
476 (let ((where-fun (widget-get-backtrace-info 8))
479 (cons :created-in-function
482 (let ((widget (apply 'widget-convert type args)))
483 (widget-apply widget :create)
487 (defun widget-create-child-and-convert (parent type &rest args)
488 "As part of the widget PARENT, create a child widget TYPE.
489 The child is converted, using the keyword arguments ARGS."
490 (let ((widget (apply 'widget-convert type args)))
491 (widget-put widget :parent parent)
492 (widget-put widget :created-in-function (widget-get-backtrace-info 15))
493 (unless (widget-get widget :indent)
494 (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
495 (or (widget-get widget :extra-offset) 0)
496 (widget-get parent :offset))))
497 (widget-apply widget :create)
500 (defun widget-create-child (parent type)
501 "Create widget of TYPE."
502 (let ((widget (widget-copy type)))
503 (widget-put widget :parent parent)
504 (widget-put widget :created-in-function (widget-get-backtrace-info 15))
505 (unless (widget-get widget :indent)
506 (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
507 (or (widget-get widget :extra-offset) 0)
508 (widget-get parent :offset))))
509 (widget-apply widget :create)
512 (defun widget-create-child-value (parent type value)
513 "Create widget of TYPE with value VALUE."
514 (let ((widget (widget-copy type)))
515 (widget-put widget :value (widget-apply widget :value-to-internal value))
516 (widget-put widget :parent parent)
517 (widget-put widget :created-in-function (widget-get-backtrace-info 15))
518 (unless (widget-get widget :indent)
519 (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
520 (or (widget-get widget :extra-offset) 0)
521 (widget-get parent :offset))))
522 (widget-apply widget :create)
525 (defvar widget-browse-fb-history nil
526 "Forward/backward history.")
527 (setq widget-browse-fb-history nil)
529 (defun widget-fb-button-action (widget &ignore)
530 (let* ((num (widget-get widget :history-number))
531 (rec (nth num widget-browse-fb-history))
535 ;;(message "fun=%s, val=%s, loc=%s" fun val loc)(sit-for 4)
538 (defun widget-insert-fb-buttons (current-number)
539 ;;(message "current-number=%s" current-number)(sit-for 2)
540 (if (<= 0 (1- current-number))
541 (widget-create 'push-button
542 :action 'widget-fb-button-action
543 :history-number (1- current-number)
546 (widget-insert (add-string-property "[back]"
549 (if (< (1+ current-number) (length widget-browse-fb-history))
550 (widget-create 'push-button
551 :action 'widget-fb-button-action
552 :history-number (1+ current-number)
555 (widget-insert (add-string-property "[forward]"
557 (widget-insert "\n"))
559 (defun widget-add-fb-history (elt)
560 (let ((last (car widget-browse-fb-history)))
561 (unless (equal elt last)
562 (setq widget-browse-fb-history
564 (reverse widget-browse-fb-history)))))))
566 (defun widget-browse (widget &optional location)
567 "Create a widget browser for WIDGET."
568 (interactive (list (completing-read "Widget: "
571 (get symbol 'widget-type))
572 t nil 'widget-browse-history)))
573 (let (history-number)
574 (if (integerp widget)
576 ;;(message "was integer=%s" widget)(sit-for 2)
577 (setq history-number widget)
578 (setq widget (nth 1 (nth widget widget-browse-fb-history))))
579 ;;(message "was NOT integer=%s" widget)(sit-for 2)
580 (widget-add-fb-history (list 'widget-browse widget location))
581 (setq history-number (1- (length widget-browse-fb-history))))
582 ;;(message "history-number=%s" history-number)(sit-for 2)
585 (setq widget (intern widget)))
586 (unless (if (symbolp widget)
587 (get widget 'widget-type)
589 (get (widget-type widget) 'widget-type)))
590 (error "Not a widget"))
592 ;; Create the buffer.
594 (let ((buffer (format "*Browse %s Widget*" widget)))
595 (kill-buffer (get-buffer-create buffer))
596 (switch-to-buffer (get-buffer-create buffer)))
597 (kill-buffer (get-buffer-create "*Browse Widget*"))
598 (switch-to-buffer (get-buffer-create "*Browse Widget*")))
601 (make-local-variable 'widget-button-face)
602 (setq widget-button-face 'link)
603 (set (make-local-variable 'widget-push-button-prefix) "")
604 (set (make-local-variable 'widget-push-button-suffix) "")
605 (set (make-local-variable 'widget-link-prefix) "")
606 (set (make-local-variable 'widget-link-suffix) "")
608 ;; Top text indicating whether it is a class or object browser.
609 (widget-insert-fb-buttons history-number)
610 (widget-insert "----------------\n")
613 (widget-insert (add-string-property
614 "Widget object browser"
615 'face 'widget-browse-h1))
616 (widget-insert "\n\n")
618 (let ((b (marker-buffer location))
619 (p (marker-position location)))
620 (widget-insert (add-string-property "Location: "
622 (widget-create 'push-button
623 :tag (format "position %s in buffer %s" p b)
625 :action '(lambda (widget &optional event)
626 (let ((value (widget-get widget :value)))
627 (let ((pos (car value))
629 (switch-to-buffer-other-window buf)
631 (widget-insert "\n\n")))
632 (widget-insert (add-string-property "Class: "
634 (widget-insert (add-string-property "Widget class browser"
635 'face 'widget-browse-h1))
636 (widget-insert ".\n\n")
637 (widget-insert (add-string-property "Class: " 'face 'italic))
638 (widget-insert (add-string-property (format "%s\n" widget)
640 (widget-insert (format "%s" (get widget 'widget-documentation)))
641 (unless (eq (preceding-char) ?\n) (widget-insert "\n"))
642 (widget-insert (add-string-property "\nSuper: " 'face 'italic))
643 (setq widget (get widget 'widget-type))
646 ;(widget-insert (format "%s\n" widget))
648 ;; Now show the attributes.
649 (let ((name (car widget))
653 (widget-insert "none\n")
654 (let ((ancestors (list name))
661 (setq a (intern-soft name))
664 (setq a (get a 'widget-type))
666 (when (intern-soft name)
667 (push name ancestors)))
669 ;;(widget-insert (format "ancestors=%s\n" ancestors))
671 (widget-insert (make-string (if (= i i1) 0 i) ? ))
672 (widget-create 'widget-browse
679 (setq key (nth 0 items)
681 printer (or (get key 'widget-keyword-printer)
683 items (cdr (cdr items)))
685 (add-string-property (symbol-name key)
687 (when (widget-browse-explained key)
699 :action '(lambda (widget &optional event)
700 (widget-browse-explain
701 ;;(widget-get widget :value)
702 (widget-value widget)
706 (widget-insert "\n\t")
707 (funcall printer widget key value)
708 (widget-insert "\n")))
710 (widget-insert "\n-----------\n")
711 (widget-insert-fb-buttons history-number)
714 (goto-char (point-min))
715 ;; (when wid-to-history
716 ;; (setq widget-browse-fb-history
717 ;; (reverse (cons (list 'widget-browse wid-to-history location)
718 ;; (reverse widget-browse-fb-history)))))
721 (defun widget-browse-at (pos)
722 "Browse the widget under point."
725 (b (if (markerp pos) (marker-buffer pos)
727 (if (not (buffer-live-p b))
728 (message "Sorry the markers buffer is gone")
729 (with-current-buffer b
731 (setq pos (marker-position pos)))
732 (let* ((field (get-char-property pos 'field))
733 (button (get-char-property pos 'button))
734 (doc (get-char-property pos 'widget-doc))
735 (text (cond (field "This is an editable text area.")
736 (button "This is an active area.")
737 (doc "This is documentation text.")
738 (t "This is unidentified text.")))
739 (widget (or field button doc)))
741 (widget-browse widget mp))
744 (defun button-at (pos)
745 "Return the button at marker or position POS, or nil.
746 If not a marker use the current buffer."
747 (with-current-buffer (if (markerp pos) (marker-buffer pos)
750 (setq pos (marker-position pos)))
751 (let ((button (get-char-property pos 'button)))
752 (if (or (overlayp button) (null button))
754 ;; Must be a text-property button; return a marker pointing to it.
755 (copy-marker pos t)))))
757 (defun button-browse-at (pos)
759 (let ((b (if (markerp pos) (marker-buffer pos)
761 (if (not (buffer-live-p b))
762 (message "Sorry the button's buffer is gone")
763 (button-browse (button-at pos)))))
765 (defun button-browse (button)
766 "Create a widget browser for WIDGET."
767 (interactive (list (completing-read "Button: "
770 (or (get symbol 'button-category-symbol)
771 (get symbol 'supertype)))
772 t nil 'button-browse-history)))
773 (let (history-number)
774 (if (integerp button)
776 (setq history-number button)
777 (setq button (nth 1 (nth button widget-browse-fb-history))))
778 (widget-add-fb-history (list 'button-browse button))
779 (setq history-number (1- (length widget-browse-fb-history))))
781 (when (stringp button)
782 (setq button (intern-soft button)))
783 (when (symbolp button)
785 (or (eq button 'default-button)
786 (get button 'supertype)
787 (get button 'button-category-symbol)
789 (string-match "-button$" (symbol-name button)))))
790 (error "Not a button")))
791 ;; Create the buffer.
792 (kill-buffer (get-buffer-create "*Browse Button*"))
793 (switch-to-buffer (get-buffer-create "*Browse Button*"))
796 (make-local-variable 'widget-button-face)
797 (setq widget-button-face 'link)
799 (widget-insert-fb-buttons history-number)
800 (widget-insert "----------------\n")
802 ;; Top text indicating whether it is a class or object browser.
803 (if (or (overlayp button)
806 (widget-insert (add-string-property "Button object browser"
807 'face 'widget-browse-h1))
808 (widget-insert "\n\n")
809 (let ((b (if (markerp button)
810 (marker-buffer button)
811 (overlay-buffer button)))
812 (p (if (markerp button)
813 (marker-position button)
814 (overlay-start button))))
815 (widget-insert (add-string-property "Location: "
817 (widget-create 'push-button
818 :tag (format "position %s in buffer %s" p b)
820 :action '(lambda (widget &optional event)
821 (let ((value (widget-get widget :value)))
822 (let ((pos (car value))
824 (switch-to-buffer-other-window buf)
826 (widget-insert "\n\n")))
827 (widget-insert (add-string-property "Button class browser"
828 'face 'widget-browse-h1))
829 (widget-insert "\n\n")
830 (widget-insert (add-string-property "Type: "
832 (widget-insert (add-string-property (symbol-name button)
834 (widget-insert "\n"))
836 ;; Now show the attributes.
840 (if (get button 'button-category-symbol)
841 (symbol-plist (get button 'button-category-symbol))
842 (symbol-plist button))
844 (let ((pos (marker-position button))
845 (buf (marker-buffer button)))
846 (text-properties-at pos buf))
847 (overlay-properties button))))
851 ;;(insert (format "\n%s\n\n" items))
852 (let ((copied-items (copy-seq items)))
854 (setq key (nth 0 copied-items)
855 value (nth 1 copied-items)
856 copied-items (cdr (cdr copied-items)))
857 (if (eq key 'category)
859 (if (eq key 'supertype)
860 (setq name (make-symbol (concat (symbol-name value) "-button")))
861 (push value rest-items)
862 (push key rest-items)))))
863 ;;(insert "\nname=" (symbol-name value) "\n\n")
865 (widget-insert (add-string-property
867 (if (get button 'supertype)
878 (setq a (or (get name 'supertype)
879 (get name :supertype)))
880 ;;(message "name=%s, a=%s\n name plist=%s" name a (symbol-plist name));(sit-for 4)
882 (eq a 'default-button))
884 (setq name (make-symbol (concat (symbol-name a) "-button")))
885 (setq ancestors (cons name ancestors))))
886 ;;(message "ancestors=%s" ancestors)(sit-for 2)
888 (widget-insert (make-string (if (= i i1) 0 i) ? ))
889 (widget-create 'button-browse
896 (setq key (nth 0 rest-items)
897 value (nth 1 rest-items)
898 printer (or (get key 'widget-keyword-printer)
900 rest-items (cdr (cdr rest-items)))
902 (add-string-property (symbol-name key)
904 (when (widget-browse-explained key)
906 (widget-create 'push-button
909 :action '(lambda (widget &optional event)
910 (widget-browse-explain
911 (widget-get widget :value))))
913 (widget-insert "\n\t")
914 (funcall printer button key value)
915 (widget-insert "\n")))
917 (goto-char (point-min))
919 ;; (when button-to-history
920 ;; (setq widget-browse-fb-history
921 ;; (reverse (cons (list 'button-browse button-to-history)
922 ;; (reverse widget-browse-fb-history)))))
928 "Customization group for whelp."
931 (defface widget-browse-h1
932 '((t (:weight bold :height 1.5)))
933 "Face for top header in widget/button browse buffers."
936 (defun add-string-property (str prop val)
937 (let ((s (copy-seq str)))
938 (put-text-property 0 (length s)
943 ;;; The `button-browse' Widget.
945 (define-widget 'button-browse 'push-button
946 "Widget button for creating a button browser.
947 The :value of the widget shuld be the button to be browsed."
949 :value-create 'widget-browse-button-value-create
950 :action 'widget-browse-button-action)
952 (defun widget-browse-button-action (widget &optional event)
953 ;; Create widget browser for WIDGET's :value.
954 (button-browse (widget-get widget :value)))
956 (defun widget-browse-button-value-create (widget)
958 (let ((value (widget-get widget :value)))
959 (cond ((symbolp value)
960 (insert (symbol-name value)))
962 (insert (symbol-name (widget-type value))))
964 (insert "strange")))))
967 (defun widget-browse-explained (property)
973 (defun widget-browse-explain (property)
974 (with-output-to-temp-buffer (help-buffer)
975 (help-setup-xref (list #'widget-browse-explain property) (interactive-p))
976 (with-current-buffer (help-buffer)
977 (let ((inhibit-read-only t))
979 ( (eq property :created-in-function)
980 (princ "Property :created-in-function tells where a field object or class is created.")
983 (princ (format "No explanation found for %s" property))
986 (with-no-warnings (print-help-return-message))))))