2001-07-16 12:23:00 +00:00
|
|
|
;;; wid-browse.el --- functions for browsing widgets
|
1997-04-07 13:42:59 +00:00
|
|
|
;;
|
2021-01-01 09:13:56 +00:00
|
|
|
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
|
1997-04-07 13:42:59 +00:00
|
|
|
;;
|
|
|
|
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
|
|
|
|
;; Keywords: extensions
|
2010-08-29 16:17:13 +00:00
|
|
|
;; Package: emacs
|
1997-04-07 13:42:59 +00:00
|
|
|
|
1997-05-14 17:31:13 +00:00
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
|
2008-05-06 08:06:51 +00:00
|
|
|
;; GNU Emacs is free software: you can redistribute it and/or modify
|
1997-05-14 17:31:13 +00:00
|
|
|
;; it under the terms of the GNU General Public License as published by
|
2008-05-06 08:06:51 +00:00
|
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
|
|
;; (at your option) any later version.
|
1997-05-14 17:31:13 +00:00
|
|
|
|
|
|
|
;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
;; GNU General Public License for more details.
|
|
|
|
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
2017-09-13 22:52:52 +00:00
|
|
|
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
1997-05-14 17:31:13 +00:00
|
|
|
|
1997-04-07 13:42:59 +00:00
|
|
|
;;; Commentary:
|
|
|
|
;;
|
|
|
|
;; Widget browser. See `widget.el'.
|
|
|
|
|
|
|
|
;;; Code:
|
|
|
|
|
|
|
|
(require 'wid-edit)
|
|
|
|
|
|
|
|
(defgroup widget-browse nil
|
|
|
|
"Customization support for browsing widgets."
|
|
|
|
:group 'widgets)
|
|
|
|
|
|
|
|
;;; The Mode.
|
|
|
|
|
2007-09-10 03:26:58 +00:00
|
|
|
(defvar widget-browse-mode-map
|
|
|
|
(let ((map (make-sparse-keymap)))
|
|
|
|
(set-keymap-parent map widget-keymap)
|
|
|
|
(define-key map "q" 'bury-buffer)
|
|
|
|
map)
|
1997-04-07 13:42:59 +00:00
|
|
|
"Keymap for `widget-browse-mode'.")
|
2003-02-04 12:29:42 +00:00
|
|
|
|
|
|
|
(easy-menu-define widget-browse-mode-customize-menu
|
1997-04-12 17:51:31 +00:00
|
|
|
widget-browse-mode-map
|
|
|
|
"Menu used in widget browser buffers."
|
|
|
|
(customize-menu-create 'widgets))
|
1997-04-07 13:42:59 +00:00
|
|
|
|
2003-02-04 12:29:42 +00:00
|
|
|
(easy-menu-define widget-browse-mode-menu
|
1997-04-07 13:42:59 +00:00
|
|
|
widget-browse-mode-map
|
|
|
|
"Menu used in widget browser buffers."
|
|
|
|
'("Widget"
|
|
|
|
["Browse" widget-browse t]
|
|
|
|
["Browse At" widget-browse-at t]))
|
|
|
|
|
|
|
|
(defcustom widget-browse-mode-hook nil
|
2021-02-11 19:21:16 +00:00
|
|
|
"Hook run after entering `widget-browse-mode'."
|
|
|
|
:type 'hook)
|
1997-04-07 13:42:59 +00:00
|
|
|
|
2021-02-11 19:21:16 +00:00
|
|
|
(define-derived-mode widget-browse-mode special-mode "Widget Browse"
|
1997-04-07 13:42:59 +00:00
|
|
|
"Major mode for widget browser buffers.
|
|
|
|
|
|
|
|
The following commands are available:
|
|
|
|
|
|
|
|
\\[widget-forward] Move to next button or editable field.
|
|
|
|
\\[widget-backward] Move to previous button or editable field.
|
|
|
|
\\[widget-button-click] Activate button under the mouse pointer.
|
2021-02-11 19:21:16 +00:00
|
|
|
\\[widget-button-press] Activate button under point.")
|
1997-04-07 13:42:59 +00:00
|
|
|
|
2000-10-26 09:39:10 +00:00
|
|
|
(put 'widget-browse-mode 'mode-class 'special)
|
|
|
|
|
1997-04-07 13:42:59 +00:00
|
|
|
;;; Commands.
|
|
|
|
|
|
|
|
;;;###autoload
|
|
|
|
(defun widget-browse-at (pos)
|
|
|
|
"Browse the widget under point."
|
|
|
|
(interactive "d")
|
2019-09-15 13:21:08 +00:00
|
|
|
(let* ((field (or
|
|
|
|
;; See comments in `widget-specify-field' to know why we
|
|
|
|
;; need this.
|
|
|
|
(get-char-property pos 'real-field)
|
|
|
|
(get-char-property pos 'field)))
|
1997-06-01 18:03:25 +00:00
|
|
|
(button (get-char-property pos 'button))
|
|
|
|
(doc (get-char-property pos 'widget-doc))
|
1997-04-07 13:42:59 +00:00
|
|
|
(text (cond (field "This is an editable text area.")
|
|
|
|
(button "This is an active area.")
|
|
|
|
(doc "This is documentation text.")
|
|
|
|
(t "This is unidentified text.")))
|
|
|
|
(widget (or field button doc)))
|
|
|
|
(when widget
|
|
|
|
(widget-browse widget))
|
|
|
|
(message text)))
|
|
|
|
|
|
|
|
(defvar widget-browse-history nil)
|
|
|
|
|
1997-04-12 17:51:31 +00:00
|
|
|
;;;###autoload
|
1997-04-07 13:42:59 +00:00
|
|
|
(defun widget-browse (widget)
|
|
|
|
"Create a widget browser for WIDGET."
|
2003-02-04 12:29:42 +00:00
|
|
|
(interactive (list (completing-read "Widget: "
|
1997-04-07 13:42:59 +00:00
|
|
|
obarray
|
|
|
|
(lambda (symbol)
|
|
|
|
(get symbol 'widget-type))
|
|
|
|
t nil 'widget-browse-history)))
|
|
|
|
(if (stringp widget)
|
|
|
|
(setq widget (intern widget)))
|
|
|
|
(unless (if (symbolp widget)
|
|
|
|
(get widget 'widget-type)
|
|
|
|
(and (consp widget)
|
|
|
|
(get (widget-type widget) 'widget-type)))
|
2001-07-16 12:23:00 +00:00
|
|
|
(error "Not a widget"))
|
1997-04-07 13:42:59 +00:00
|
|
|
;; Create the buffer.
|
|
|
|
(if (symbolp widget)
|
|
|
|
(let ((buffer (format "*Browse %s Widget*" widget)))
|
|
|
|
(kill-buffer (get-buffer-create buffer))
|
|
|
|
(switch-to-buffer (get-buffer-create buffer)))
|
|
|
|
(kill-buffer (get-buffer-create "*Browse Widget*"))
|
|
|
|
(switch-to-buffer (get-buffer-create "*Browse Widget*")))
|
|
|
|
(widget-browse-mode)
|
2003-02-04 12:29:42 +00:00
|
|
|
|
1997-04-07 13:42:59 +00:00
|
|
|
;; Quick way to get out.
|
1997-04-12 17:51:31 +00:00
|
|
|
;; (widget-create 'push-button
|
|
|
|
;; :action (lambda (widget &optional event)
|
|
|
|
;; (bury-buffer))
|
|
|
|
;; "Quit")
|
|
|
|
;; (widget-insert "\n")
|
1997-04-07 13:42:59 +00:00
|
|
|
|
|
|
|
;; Top text indicating whether it is a class or object browser.
|
|
|
|
(if (listp widget)
|
|
|
|
(widget-insert "Widget object browser.\n\nClass: ")
|
|
|
|
(widget-insert "Widget class browser.\n\n")
|
|
|
|
(widget-create 'widget-browse
|
|
|
|
:format "%[%v%]\n%d"
|
|
|
|
:doc (get widget 'widget-documentation)
|
|
|
|
widget)
|
|
|
|
(unless (eq (preceding-char) ?\n)
|
|
|
|
(widget-insert "\n"))
|
|
|
|
(widget-insert "\nSuper: ")
|
|
|
|
(setq widget (get widget 'widget-type)))
|
|
|
|
|
|
|
|
;; Now show the attributes.
|
|
|
|
(let ((name (car widget))
|
|
|
|
(items (cdr widget))
|
|
|
|
key value printer)
|
|
|
|
(widget-create 'widget-browse
|
|
|
|
:format "%[%v%]"
|
|
|
|
name)
|
|
|
|
(widget-insert "\n")
|
|
|
|
(while items
|
|
|
|
(setq key (nth 0 items)
|
|
|
|
value (nth 1 items)
|
|
|
|
printer (or (get key 'widget-keyword-printer)
|
|
|
|
'widget-browse-sexp)
|
|
|
|
items (cdr (cdr items)))
|
|
|
|
(widget-insert "\n" (symbol-name key) "\n\t")
|
|
|
|
(funcall printer widget key value)
|
|
|
|
(widget-insert "\n")))
|
|
|
|
(widget-setup)
|
|
|
|
(goto-char (point-min)))
|
|
|
|
|
1997-04-12 17:51:31 +00:00
|
|
|
;;;###autoload
|
|
|
|
(defun widget-browse-other-window (&optional widget)
|
|
|
|
"Show widget browser for WIDGET in other window."
|
|
|
|
(interactive)
|
|
|
|
(let ((window (selected-window)))
|
|
|
|
(switch-to-buffer-other-window "*Browse Widget*")
|
|
|
|
(if widget
|
|
|
|
(widget-browse widget)
|
|
|
|
(call-interactively 'widget-browse))
|
|
|
|
(select-window window)))
|
|
|
|
|
|
|
|
|
1997-04-07 13:42:59 +00:00
|
|
|
;;; The `widget-browse' Widget.
|
|
|
|
|
|
|
|
(define-widget 'widget-browse 'push-button
|
|
|
|
"Button for creating a widget browser.
|
2020-09-21 11:29:10 +00:00
|
|
|
The :value of the widget should be the widget to be browsed."
|
1997-04-07 13:42:59 +00:00
|
|
|
:format "%[[%v]%]"
|
|
|
|
:value-create 'widget-browse-value-create
|
|
|
|
:action 'widget-browse-action)
|
|
|
|
|
2011-04-19 13:44:55 +00:00
|
|
|
(defun widget-browse-action (widget &optional _event)
|
2021-02-11 19:21:16 +00:00
|
|
|
"Create widget browser for :value of WIDGET."
|
1997-04-07 13:42:59 +00:00
|
|
|
(widget-browse (widget-get widget :value)))
|
|
|
|
|
|
|
|
(defun widget-browse-value-create (widget)
|
2021-02-11 19:21:16 +00:00
|
|
|
"Insert type name for WIDGET."
|
1997-04-07 13:42:59 +00:00
|
|
|
(let ((value (widget-get widget :value)))
|
|
|
|
(cond ((symbolp value)
|
|
|
|
(insert (symbol-name value)))
|
|
|
|
((consp value)
|
|
|
|
(insert (symbol-name (widget-type value))))
|
|
|
|
(t
|
|
|
|
(insert "strange")))))
|
|
|
|
|
|
|
|
;;; Keyword Printer Functions.
|
|
|
|
|
2011-04-19 13:44:55 +00:00
|
|
|
(defun widget-browse-widget (_widget _key value)
|
1997-04-07 13:42:59 +00:00
|
|
|
"Insert description of WIDGET's KEY VALUE.
|
|
|
|
VALUE is assumed to be a widget."
|
|
|
|
(widget-create 'widget-browse value))
|
|
|
|
|
2011-04-19 13:44:55 +00:00
|
|
|
(defun widget-browse-widgets (_widget _key value)
|
1997-04-07 13:42:59 +00:00
|
|
|
"Insert description of WIDGET's KEY VALUE.
|
|
|
|
VALUE is assumed to be a list of widgets."
|
|
|
|
(while value
|
|
|
|
(widget-create 'widget-browse
|
|
|
|
(car value))
|
|
|
|
(setq value (cdr value))
|
|
|
|
(when value
|
|
|
|
(widget-insert " "))))
|
|
|
|
|
2011-04-19 13:44:55 +00:00
|
|
|
(defun widget-browse-sexp (_widget _key value)
|
1997-04-07 13:42:59 +00:00
|
|
|
"Insert description of WIDGET's KEY VALUE.
|
|
|
|
Nothing is assumed about value."
|
|
|
|
(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"
|
2011-04-19 13:44:55 +00:00
|
|
|
:action (lambda (widget &optional _event)
|
1997-04-07 13:42:59 +00:00
|
|
|
(with-output-to-temp-buffer
|
|
|
|
"*Pp Eval Output*"
|
|
|
|
(princ (widget-get widget :value))))
|
|
|
|
pp))))
|
|
|
|
|
|
|
|
(defun widget-browse-sexps (widget key value)
|
|
|
|
"Insert description of WIDGET's KEY VALUE.
|
|
|
|
VALUE is assumed to be a list of widgets."
|
|
|
|
(let ((target (current-column)))
|
|
|
|
(while value
|
|
|
|
(widget-browse-sexp widget key (car value))
|
|
|
|
(setq value (cdr value))
|
|
|
|
(when value
|
|
|
|
(widget-insert "\n" (make-string target ?\ ))))))
|
|
|
|
|
|
|
|
;;; Keyword Printers.
|
|
|
|
|
|
|
|
(put :parent 'widget-keyword-printer 'widget-browse-widget)
|
|
|
|
(put :children 'widget-keyword-printer 'widget-browse-widgets)
|
|
|
|
(put :buttons 'widget-keyword-printer 'widget-browse-widgets)
|
|
|
|
(put :button 'widget-keyword-printer 'widget-browse-widget)
|
|
|
|
(put :args 'widget-keyword-printer 'widget-browse-sexps)
|
|
|
|
|
1997-04-24 16:53:55 +00:00
|
|
|
;;; Widget Minor Mode.
|
|
|
|
|
2007-09-10 03:26:58 +00:00
|
|
|
(defvar widget-minor-mode-map
|
|
|
|
(let ((map (make-sparse-keymap)))
|
|
|
|
(set-keymap-parent map widget-keymap)
|
|
|
|
map)
|
1997-04-24 16:53:55 +00:00
|
|
|
"Keymap used in Widget Minor Mode.")
|
|
|
|
|
|
|
|
;;;###autoload
|
2007-09-10 03:26:58 +00:00
|
|
|
(define-minor-mode widget-minor-mode
|
2018-07-02 03:34:53 +00:00
|
|
|
"Minor mode for traversing widgets."
|
2007-09-10 03:26:58 +00:00
|
|
|
:lighter " Widget")
|
1997-04-24 16:53:55 +00:00
|
|
|
|
1997-04-07 13:42:59 +00:00
|
|
|
(provide 'wid-browse)
|
|
|
|
|
2001-07-16 12:23:00 +00:00
|
|
|
;;; wid-browse.el ends here
|