+Tue Sep 17 03:15:26 1996 Lars Magne Ingebrigtsen <larsi@ylfing.ifi.uio.no>
+
+ * custom.el: 0.9 included.
+
+ * gnus-art.el (browse-url): Required.
+
+ * gnus.el: Red Gnus v0.36 is released.
+
Tue Sep 17 02:37:26 1996 Lars Magne Ingebrigtsen <larsi@ylfing.ifi.uio.no>
* gnus-edit.el: Removed.
--- /dev/null
+;;; custom-edit.el --- Tools for customization Emacs.
+;;
+;; Copyright (C) 1996 Free Software Foundation, Inc.
+;;
+;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
+;; Keywords: help, faces
+;; Version: 0.9
+;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
+
+;;; Commentary:
+;;
+;; See `custom.el'.
+
+;;; Code:
+
+(require 'custom)
+(require 'widget-edit)
+
+(let ((keywords '(:custom-show
+ :custom-documentation-show
+ :custom-documentation-property
+ :custom-level
+ :custom-status)))
+ (while keywords
+ (or (boundp (car keywords))
+ (set (car keywords) (car keywords)))
+ (setq keywords (cdr keywords))))
+
+;;; Utilities.
+
+(defun custom-quote (sexp)
+ "Quote SEXP iff it is not self quoting."
+ (if (or (memq sexp '(t nil))
+ (and (symbolp sexp)
+ (eq (aref (symbol-name sexp) 0) ?:))
+ (and (listp sexp)
+ (memq (car sexp) '(lambda)))
+ (stringp sexp)
+ (numberp sexp))
+ sexp
+ (list 'quote sexp)))
+
+;;; The `custom-level' Widget.
+
+(define-widget 'custom-level 'item
+ "The custom level buttons."
+ :format "%[%t%]"
+ :help-echo "Push me to expand or collapse this item."
+ :action 'custom-level-action)
+
+(defun custom-level-action (widget &optional event)
+ "Toggle visibility for parent to WIDGET."
+ (let* ((parent (widget-get widget :parent))
+ (show (widget-get parent :custom-show)))
+ (widget-apply parent :validate)
+ (widget-put parent :custom-show (not show))
+ (custom-reset parent)))
+
+;;; The `custom-help' Widget.
+
+(define-widget 'custom-help 'push
+ "The custom documentation button."
+ :help-echo "Push me to toggle the documentation."
+ :action 'custom-help-action)
+
+(defun custom-help-action (widget &optional event)
+ "Toggle documentation visibility for parent to WIDGET."
+ (let* ((parent (widget-get widget :parent))
+ (symbol (widget-get parent :value))
+ (property (widget-get parent :custom-documentation-property))
+ (text (or (widget-get parent :doc)
+ (documentation-property symbol property)))
+ (newline (string-match "\n." text))
+ (old (widget-get parent :custom-documentation-show))
+ (new (cond ((eq old t)
+ nil)
+ ((null old)
+ (if newline
+ 'first-line
+ t))
+ (t
+ (if newline
+ t
+ nil)))))
+ (widget-apply parent :validate)
+ (widget-put parent :custom-documentation-show new)
+ (custom-reset parent)))
+
+;;; The `custom' Widget.
+
+(define-widget 'custom 'default
+ "Customize a user option."
+ :convert-widget 'widget-item-convert-widget
+ :format "%l%h%[%t%]: %v%x"
+ :format-handler 'custom-format-handler
+ :custom-level 1
+ :custom-show nil
+ :custom-documentation-show 'first-line
+ :custom-documentation-property 'widget-subclass-responsibility
+ :value-create 'widget-subclass-responsibility
+ :value-delete 'widget-radio-value-delete
+ :value-get 'widget-item-value-get
+ :validate 'widget-repeat-validate
+ :match (lambda (widget value) (symbolp value)))
+
+(defun custom-format-handler (widget escape)
+ ;; We recognize extra escape sequences.
+ (let* (child
+ (symbol (widget-get widget :value))
+ (level (widget-get widget :custom-level))
+ (doc-property (widget-get widget :custom-documentation-property))
+ (doc-try (or (widget-get widget :doc)
+ (documentation-property symbol doc-property)))
+ (doc-text (and (stringp doc-try)
+ (> (length doc-try) 1)
+ doc-try))
+ (doc-show (widget-get widget :custom-documentation-show)))
+ (cond ((eq escape ?l)
+ (when level
+ (setq child
+ (widget-create 'custom-level
+ :parent widget
+ (make-string level ?*)))
+ (widget-insert " ")))
+ ((eq escape ?h)
+ (when doc-text
+ (setq child (widget-create 'custom-help
+ :parent widget
+ "?"))
+ (widget-insert " ")))
+ ((eq escape ?x)
+ (and doc-text doc-show
+ (let ((start (point)))
+ ;; The first "*" in a doc string means interactively
+ ;; user editable. Since we are providing a facility
+ ;; for the user to interactively edit the variable,
+ ;; that information is redundant. Remove it.
+ (cond ((eq doc-show t)
+ (if (eq (aref doc-text 0) ?*)
+ (widget-insert (substring doc-text 1))
+ (widget-insert doc-text)))
+ ((eq (aref doc-text 0) ?*)
+ (string-match "\\`.\\(.*\\)" doc-text)
+ (widget-insert (match-string 1 doc-text)))
+ (t
+ (string-match "\\`.*" doc-text)
+ (widget-insert (match-string 0 doc-text))))
+ (unless (eq (preceding-char) ?\n)
+ (widget-insert "\n"))
+ (widget-specify-doc widget start (point)))))
+ (t
+ (widget-default-format-handler widget escape)))
+ (when child
+ (widget-put widget
+ :buttons (cons child (widget-get widget :buttons))))))
+
+(defun custom-unimplemented (&rest ignore)
+ "Apologize for my laziness."
+ (error "Sorry, not implemented"))
+
+(defun custom-reset (widget)
+ "Redraw WIDGET with current settings."
+ (widget-value-set widget (widget-value widget))
+ (widget-setup))
+
+;;; The `custom-variable' Widget.
+
+(define-widget 'custom-variable 'custom
+ "Customize variable."
+ :help-echo "Push me to set or reset this variable."
+ :custom-documentation-property 'variable-documentation
+ :custom-show 'child
+ :custom-status 'edit
+ :value-create 'custom-variable-value-create
+ :action 'custom-variable-action)
+
+(widget-put (get 'default 'widget-type) :custom-show t)
+
+(defun custom-variable-value-create (widget)
+ "Here is where you edit the variables value."
+ (let* ((status (widget-get widget :custom-status))
+ (child-show (widget-get widget :custom-show))
+ (symbol (widget-get widget :value))
+ (child-type (or (get symbol 'custom-type) 'sexp))
+ (type (if (listp child-type) child-type (list child-type)))
+ (show (if (eq child-show 'child)
+ (widget-get type :custom-show)
+ child-show))
+ (dummy (widget-put widget :custom-show show))
+ (child (cond ((not show)
+ (widget-create 'custom-level
+ "[show]"))
+ ((eq status 'lisp)
+ (let ((value (cond ((get symbol 'saved-value)
+ (car (get symbol 'saved-value)))
+ ((get symbol 'factory-value)
+ (car (get symbol 'factory-value)))
+ ((boundp symbol)
+ (custom-quote
+ (symbol-value symbol)))
+ (t
+ (custom-quote
+ (widget-get type :value))))))
+ (widget-create 'sexp :value value)))
+ (t
+ (let ((value (if (boundp symbol)
+ (symbol-value symbol)
+ (widget-get type :value))))
+ (widget-create type :value value))))))
+ (unless (eq (preceding-char) ?\n)
+ (widget-insert "\n"))
+ (widget-put child :parent widget)
+ (widget-put widget :children (list child))))
+
+(defvar custom-variable-menu
+ '(("Edit" . custom-variable-edit)
+ ("Edit Lisp" . custom-variable-edit-lisp)
+ ("Apply" . custom-variable-apply)
+ ("Set Default" . custom-variable-set-default)
+ ("Reset" . custom-reset)
+ ("Reset to Default" . custom-variable-default)
+ ("Reset to Factory Settings" . custom-variable-factory))
+ "Alist of actions for the `custom-variable' widget.
+The key is a string containing the name of the action, the value is a
+lisp function taking the widget as an element which will be called
+when the action is chosen.")
+
+(defun custom-variable-action (widget &optional event)
+ "Show the menu for `custom-variable' WIDGET.
+Optional EVENT is the location for the menu."
+ (let* ((completion-ignore-case t)
+ (answer (widget-choose (symbol-name (widget-get widget :value))
+ custom-variable-menu
+ event)))
+ (if answer
+ (funcall answer widget))))
+
+(defun custom-variable-edit (widget)
+ "Edit value of WIDGET."
+ (custom-variable-apply widget)
+ (widget-put widget :custom-show t)
+ (widget-put widget :custom-status 'edit)
+ (custom-reset widget))
+
+(defun custom-variable-edit-lisp (widget)
+ "Edit the lisp representation of the value of WIDGET."
+ (custom-variable-apply widget)
+ (widget-put widget :custom-show t)
+ (widget-put widget :custom-status 'lisp)
+ (custom-reset widget))
+
+(defun custom-variable-apply (widget)
+ "Set the current value for the variable being edited by WIDGET."
+ (let ((status (widget-get widget :custom-status))
+ (show (widget-get widget :custom-show))
+ (child (car (widget-get widget :children)))
+ (symbol (widget-value widget)))
+ (unless show
+ (error "You can only apply visible options"))
+ (widget-apply child :validate)
+ (if (eq status 'lisp)
+ (set symbol (eval (widget-value child)))
+ (set symbol (widget-value child)))))
+
+(defun custom-variable-set-default (widget)
+ "Set the default value for the variable being edited by WIDGET."
+ (let ((status (widget-get widget :custom-status))
+ (show (widget-get widget :custom-show))
+ (child (car (widget-get widget :children)))
+ (symbol (widget-value widget)))
+ (unless show
+ (error "Can't apply hidden value."))
+ (widget-apply child :validate)
+ (if (eq status 'lisp)
+ (put symbol 'saved-value (list (widget-value child)))
+ (put symbol 'saved-value (list (custom-quote (widget-value child)))))))
+
+(defun custom-variable-default (widget)
+ "Restore the default value for the variable being edited by WIDGET."
+ (let ((symbol (widget-value widget)))
+ (cond ((get symbol 'saved-value)
+ (set symbol (car (get symbol 'saved-value))))
+ ((get symbol 'factory-value)
+ (set symbol (car (get symbol 'factory-value))))
+ (t
+ (error "No default value for %s" symbol))))
+ (custom-reset widget))
+
+(defun custom-variable-factory (widget)
+ "Restore the factory setting for the variable being edited by WIDGET."
+ (let ((symbol (widget-value widget)))
+ (if (get symbol 'factory-value)
+ (set symbol (car (get symbol 'factory-value)))
+ (error "No factory default for %S" symbol)))
+ (custom-reset widget))
+
+;;; The `custom-face-edit' Widget.
+
+(defvar custom-face-edit-args
+ (mapcar (lambda (att)
+ (list 'group
+ :inline t
+ (list 'const :format "" :value (nth 0 att))
+ (nth 1 att)))
+ custom-face-attributes))
+
+(define-widget 'custom-face-edit 'checklist
+ "Edit face attributes."
+ :format "%t:\n%v"
+ :tag "Attributes"
+ :args (mapcar (lambda (att)
+ (list 'group
+ :inline t
+ (list 'const :format "" :value (nth 0 att))
+ (nth 1 att)))
+ custom-face-attributes))
+
+;;; The `custom-display' Widget.
+
+(define-widget 'custom-display 'choice
+ "Select a display type."
+ :tag "Display"
+ :value t
+ :args '((const :tag "all" t)
+ (checklist :entry-format "\n%b %v"
+ :args ((list (const :format "Type: " type)
+ (checklist :inline t
+ (const :format "X "
+ x)
+ (const :format "TTY"
+ tty)))
+ (list (const :format "Class: " class)
+ (checklist :inline t
+ (const :format "Color "
+ color)
+ (const :format
+ "Grayscale "
+ grayscale)
+ (const :format "Monochrome"
+ mono)))
+ (list (const :format "Background: " background)
+ (checklist :inline t
+ (const :format "Light "
+ light)
+ (const :format "Dark\n"
+ dark)))))))
+
+;;; The `custom-face' Widget.
+
+(define-widget 'custom-face 'custom
+ "Customize face."
+ :format "%l%h%[%t%]: %s%x%v"
+ :format-handler 'custom-face-format-handler
+ :help-echo "Push me to set or reset this face."
+ :custom-documentation-property 'face-documentation
+ :value-create 'custom-face-value-create
+ :action 'custom-face-action)
+
+(defun custom-face-format-handler (widget escape)
+ ;; We recognize extra escape sequences.
+ (let* (child
+ (symbol (widget-get widget :value)))
+ (cond ((eq escape ?s)
+ (setq child (widget-create 'choice-item
+ :parent widget
+ :format "(%[sample%])\n"
+ :button-face symbol)))
+ (t
+ (custom-format-handler widget escape)))
+ (when child
+ (widget-put widget
+ :buttons (cons child (widget-get widget :buttons))))))
+
+(defun custom-face-value-create (widget)
+ ;; Create a list of the display specifications.
+ (when (widget-get widget :custom-show)
+ (let* ((symbol (widget-value widget))
+ (edit (widget-create 'repeat
+ :entry-format "%i %d %v"
+ :parent widget
+ :value (or (get symbol 'saved-face)
+ (get symbol 'factory-face))
+ '(list custom-display custom-face-edit))))
+ (widget-put widget :children (list edit)))))
+
+(defvar custom-face-menu
+ '(("Apply" . custom-face-apply)
+ ("Set Default" . custom-face-set-default)
+ ("Default" . custom-face-default)
+ ("Factory" . custom-face-factory))
+ "Alist of actions for the `custom-face' widget.
+The key is a string containing the name of the action, the value is a
+lisp function taking the widget as an element which will be called
+when the action is chosen.")
+
+(defun custom-face-action (widget &optional event)
+ "Show the menu for `custom-face' WIDGET.
+Optional EVENT is the location for the menu."
+ (let* ((completion-ignore-case t)
+ (answer (widget-choose (symbol-name (widget-get widget :value))
+ custom-face-menu
+ event)))
+ (if answer
+ (funcall answer widget))))
+
+(defun custom-face-apply (widget)
+ "Make the face attributes in WIDGET take effect."
+ (unless (widget-get widget :custom-show)
+ (error "You cannot apply hidden face"))
+ (let* ((symbol (widget-value widget))
+ (child (car (widget-get widget :children)))
+ (value (widget-value child)))
+ (custom-face-display-set symbol value)))
+
+(defun custom-face-set-default (widget)
+ "Make the face attributes in WIDGET default."
+ (unless (widget-get widget :custom-show)
+ (error "You cannot set default for hidden face"))
+ (let* ((symbol (widget-value widget))
+ (child (car (widget-get widget :children)))
+ (value (widget-value child)))
+ (put symbol 'saved-face value)))
+
+(defun custom-face-default (widget)
+ "Restore WIDGET to the face's default attributes."
+ (unless (widget-get widget :custom-show)
+ (error "You cannot reset to default for hidden face"))
+ (let* ((symbol (widget-value widget))
+ (child (car (widget-get widget :children))))
+ (widget-value-set child (or (get symbol 'saved-face)
+ (get symbol 'factory-face)))
+ (widget-setup)))
+
+(defun custom-face-factory (widget)
+ "Restore WIDGET to the face's factory settings."
+ (unless (widget-get widget :custom-show)
+ (error "You cannot reset to factory setting for hidden face"))
+ (let* ((symbol (widget-value widget))
+ (child (car (widget-get widget :children))))
+ (widget-value-set child (or (get symbol 'factory-face)
+ (get symbol 'saved-face)))
+ (widget-setup)))
+
+;;; The `face' Widget.
+
+(define-widget 'face 'default
+ "Select and customize a face."
+ :convert-widget 'widget-item-convert-widget
+ :custom-show nil
+ :format "%[%t%]\n%v"
+ :value-create 'widget-face-value-create
+ :value-delete 'widget-radio-value-delete
+ :value-get 'widget-item-value-get
+ :validate 'widget-repeat-validate
+ :action 'widget-face-action
+ :match '(lambda (widget value) (symbolp value)))
+
+(defun widget-face-value-create (widget)
+ ;; Create a `custom-face' child.
+ (let* ((symbol (widget-value widget))
+ (child (widget-create 'custom-face
+ :custom-level nil
+ :custom-show t
+ :tag "Face"
+ :value symbol)))
+ (widget-put widget :children (list child))))
+
+(defvar face-history nil
+ "History of entered face names.")
+
+(defun widget-face-action (widget &optional event)
+ "Prompt for a face."
+ (let ((answer (completing-read "Face: "
+ (mapcar (lambda (face)
+ (list (symbol-name face)))
+ (face-list))
+ nil nil nil
+ 'face-history)))
+ (unless (zerop (length answer))
+ (widget-value-set widget (intern answer))
+ (widget-setup))))
+
+;;; The `custom-group' Widget.
+
+(define-widget 'custom-group 'custom
+ "Customize group."
+ :format "%l%h%[%t%]:\n%x%v"
+ :custom-documentation-property 'group-documentation
+ :help-echo "Push me to set or reset all members of this group."
+ :value-create 'custom-group-value-create
+ :action 'custom-group-action)
+
+(defun custom-group-value-create (widget)
+ (let* ((show (widget-get widget :custom-show))
+ (level (widget-get widget :custom-level))
+ (symbol (widget-value widget))
+ (members (get symbol 'custom-group)))
+ (when show
+ (widget-put widget
+ :children (mapcar (lambda (entry)
+ (widget-insert "\n")
+ (prog1
+ (widget-create (nth 1 entry)
+ :parent widget
+ :custom-level
+ (1+ level)
+ :value (nth 0 entry))
+ (unless (eq (preceding-char) ?\n)
+ (widget-insert "\n"))))
+ members)))))
+
+(defvar custom-group-menu
+ '(("Apply" . custom-unimplemented)
+ ("Set Default" . custom-unimplemented)
+ ("Reset" . custom-reset)
+ ("Reset to Default" . custom-unimplemented)
+ ("Reset to Factory Settings" . custom-unimplemented))
+ "Alist of actions for the `custom-group' widget.
+The key is a string containing the name of the action, the value is a
+lisp function taking the widget as an element which will be called
+when the action is chosen.")
+
+(defun custom-group-action (widget &optional event)
+ "Show the menu for `custom-group' WIDGET.
+Optional EVENT is the location for the menu."
+ (let* ((completion-ignore-case t)
+ (answer (widget-choose (symbol-name (widget-get widget :value))
+ custom-group-menu
+ event)))
+ (if answer
+ (funcall answer widget))))
+
+;;; The `custom-save' Command.
+
+(defcustom custom-file "~/.emacs"
+ :type 'file
+ :group 'customize
+ "File used for storing customization information.")
+
+(defun custom-save-delete (symbol)
+ "Delete the call to SYMBOL form `custom-file'.
+Leave point at the location of the call, or after the last expression."
+ (set-buffer (find-file-noselect custom-file))
+ (goto-char (point-min))
+ (catch 'found
+ (while t
+ (let ((sexp (condition-case nil
+ (read (current-buffer))
+ (end-of-file (throw 'found nil)))))
+ (when (and (listp sexp)
+ (eq (car sexp) symbol))
+ (delete-region (save-excursion
+ (backward-sexp)
+ (point))
+ (point))
+ (throw 'found nil))))))
+
+(defun custom-save-variables ()
+ "Save all customized variables in `custom-file'."
+ (save-excursion
+ (custom-save-delete 'custom-set-variables)
+ (let ((standard-output (current-buffer)))
+ (unless (bolp)
+ (princ "\n"))
+ (princ "(custom-set-variables")
+ (mapatoms (lambda (symbol)
+ (let ((value (get symbol 'saved-value)))
+ (when value
+ (princ "\n '")
+ (princ symbol)
+ (princ " '")
+ (prin1 (car value))))))
+ (princ ")")
+ (unless (eolp)
+ (princ "\n")))))
+
+(defun custom-save-faces ()
+ "Save all customized faces in `custom-file'."
+ (save-excursion
+ (custom-save-delete 'custom-set-faces)
+ (let ((standard-output (current-buffer)))
+ (unless (bolp)
+ (princ "\n"))
+ (princ "(custom-set-faces")
+ (mapatoms (lambda (symbol)
+ (let ((value (get symbol 'saved-face)))
+ (when value
+ (princ "\n '")
+ (princ symbol)
+ (princ " '")
+ (prin1 value)))))
+ (princ ")")
+ (unless (eolp)
+ (princ "\n")))))
+
+(defun custom-save ()
+ "Save all customizations in `custom-file'."
+ (interactive)
+ (custom-save-variables)
+ (custom-save-faces)
+ (save-excursion
+ (set-buffer (find-file-noselect custom-file))
+ (save-buffer)))
+
+;;; The Custom Mode.
+
+(defvar custom-options nil
+ "Customization widgets in the current buffer.")
+
+(defvar custom-mode-map nil
+ "Keymap for `custom-mode'.")
+
+(unless custom-mode-map
+ (setq custom-mode-map (make-sparse-keymap))
+ (set-keymap-parent custom-mode-map widget-keymap))
+
+(defun custom-mode ()
+ "Major mode for editing customization buffers.
+
+Read the non-existing manual for information about how to use it.
+
+\\{custom-mode-map}"
+ (kill-all-local-variables)
+ (setq major-mode 'custom-mode
+ mode-name "Custom")
+ (use-local-map custom-mode-map)
+ (make-local-variable 'custom-options))
+
+;;; The Customize Commands
+
+;;;###autoload
+(defun customize (symbol)
+ "Customize SYMBOL, which must be a customization group."
+ (interactive (list (completing-read "Customize group: (default emacs) "
+ obarray
+ (lambda (symbol)
+ (get symbol 'custom-group))
+ t)))
+
+ (when (stringp symbol)
+ (if (string-equal "" symbol)
+ (setq symbol 'emacs)
+ (setq symbol (intern symbol))))
+ (custom-buffer-create (list (list symbol 'custom-group))))
+
+;;;###autoload
+(defun customize-variable (symbol)
+ "Customize SYMBOL, which must be a variable."
+ (interactive
+ ;; Code stolen from `help.el'.
+ (let ((v (variable-at-point))
+ (enable-recursive-minibuffers t)
+ val)
+ (setq val (completing-read
+ (if v
+ (format "Customize variable (default %s): " v)
+ "Customize variable: ")
+ obarray 'boundp t))
+ (list (if (equal val "")
+ v (intern val)))))
+ (custom-buffer-create (list (list symbol 'custom-variable))))
+
+;;;###autoload
+(defun customize-face (symbol)
+ "Customize FACE."
+ (interactive (list (completing-read "Customize face: " obarray 'facep)))
+ (unless (symbolp symbol)
+ (error "Should be a symbol %S" symbol))
+ (custom-buffer-create (list (list symbol 'custom-face))))
+
+;;;###autoload
+(defun customize-apropos (regexp)
+ "Customize all user options matching REGEXP"
+ (interactive "sCustomize regexp: ")
+ (let ((found nil))
+ (mapatoms (lambda (symbol)
+ (when (string-match regexp (symbol-name symbol))
+ (when (get symbol 'custom-group)
+ (setq found (cons (list symbol 'custom-group) found)))
+ (when (facep symbol)
+ (setq found (cons (list symbol 'custom-face) found)))
+ (when (and (boundp symbol)
+ (or (get symbol 'default-value)
+ (get symbol 'factory-value)
+ (get symbol 'variable-documentation)))
+ (setq found
+ (cons (list symbol 'custom-variable) found))))))
+ (if found
+ (custom-buffer-create found)
+ (error "No matches"))))
+
+(defun custom-buffer-create (options)
+ "Create a buffer containing OPTIONS.
+OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where
+SYMBOL is a customization option, and WIDGET is a widget for editing
+that option."
+ (kill-buffer (get-buffer-create "*Customization*"))
+ (switch-to-buffer-other-window (get-buffer-create "*Customization*"))
+ (custom-mode)
+ (widget-insert "This is a customization buffer.
+Press `C-h m' for to get help.
+
+")
+ (setq custom-options
+ (mapcar (lambda (entry)
+ (widget-create (nth 1 entry)
+ :value (nth 0 entry))
+ (unless (eq (preceding-char) ?\n)
+ (widget-insert "\n"))
+ (widget-insert "\n"))
+ options))
+ (widget-create 'push
+ :tag "Save"
+ :help-echo "Push me to store the new defaults permanently."
+ :action (lambda (widget &optional event) (custom-save)))
+ (widget-setup))
+
+;;; The End.
+
+(provide 'custom-edit)
+
+;; custom-edit.el ends here
+;;; custom.el -- Tools for declaring and initializing options.
+;;
+;; Copyright (C) 1996 Free Software Foundation, Inc.
+;;
+;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
+;; Keywords: help, faces
+;; Version: 0.9
+;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
+
+;;; Commentary:
+;;
+;; If you want to use this code, please visit the URL above.
+;;
+;; This file only contain the code needed to declare and initialize
+;; user options. The code to customize options is autoloaded from
+;; `custom-edit.el'.
+
+;;; Code:
+
+(require 'widget)
+
+(let ((keywords '(:type :group)))
+ (while keywords
+ (or (boundp (car keywords))
+ (set (car keywords) (car keywords)))
+ (setq keywords (cdr keywords))))
+
+;; These autoloads should be deleted when the file is added to Emacs
+(autoload 'customize "custom-edit" nil t)
+(autoload 'customize-variable "custom-edit" nil t)
+(autoload 'customize-face "custom-edit" nil t)
+(autoload 'customize-apropos "custom-edit" nil t)
+
+;;; Face Utilities.
+
+(make-face 'custom-face-empty)
+
+(defun custom-face-display-set (face spec &optional frame)
+ "Set FACE to the attributes to the first matching entry in SPEC.
+Iff optional FRAME is non-nil, set it for that frame only.
+See `defface' for information about SPEC."
+ (make-face face)
+ (copy-face 'custom-face-empty face)
+ (while spec
+ (let* ((entry (car spec))
+ (display (nth 0 entry))
+ (atts (nth 1 entry)))
+ (setq spec (cdr spec))
+ (when (custom-display-match-frame display frame)
+ (apply 'custom-face-attribites-set face frame atts)
+ (setq spec nil)))))
+
+(defun custom-display-match-frame (display frame)
+ "Non-nil iff DISPLAY matches FRAME.
+If FRAME is nil, the current FRAME is used."
+ (unless frame
+ (setq frame (selected-frame)))
+ (if (eq display t)
+ t
+ (let ((match t)
+ (pars (frame-parameters frame)))
+ (while (and display match)
+ (let* ((entry (car display))
+ (req (car entry))
+ (options (cdr entry)))
+ (setq display (cdr display))
+ (cond ((eq req 'type)
+ (setq match (memq window-system options)))
+ ((eq req 'class)
+ (let ((class (cdr (assq 'display-type pars))))
+ (setq match (memq class options))))
+ ((eq req 'background)
+ (let ((background (cdr (assq 'background-mode pars))))
+ (setq match (memq background options))))
+ (t
+ (error "Unknown req `%S' with options `%S'" req options)))))
+ match)))
+
+(defvar custom-face-attributes
+ '((:bold (toggle :format "Bold: %v") custom-set-face-bold)
+ (:italic (toggle :format "Italic: %v") custom-set-face-italic)
+ (:underline
+ (toggle :format "Underline: %v") set-face-underline-p)
+ (:foreground (color :tag "Foreground") set-face-foreground)
+ (:background (color :tag "Background") set-face-background)
+ (:stipple (field :format "Stipple: %v") set-face-stipple))
+ "Alist of face attributes.
+
+The elements are of the form (KEY TYPE SET) where KEY is a symbol
+identifying the attribute, TYPE is a widget type for editing the
+attibute, SET is a function for setting the attribute value.
+
+The SET function should take three arguments, the face to modify, the
+value of the attribute, and optionally the frame where the face should
+be changed.")
+
+(defun custom-face-attribites-set (face frame &rest atts)
+ "For FACE on FRAME set the attributes [KEYWORD VALUE]....
+Each keyword should be listed in `custom-face-attributes'.
+
+If FRAME is nil, set the default face."
+ (while atts
+ (let* ((name (nth 0 atts))
+ (value (nth 1 atts))
+ (fun (nth 2 (assq name custom-face-attributes))))
+ (setq atts (cdr (cdr atts)))
+ (funcall fun face value))))
+
+(defun custom-set-face-bold (face value &optional frame)
+ "Set the bold property of FACE to VALUE."
+ (condition-case nil
+ (if value
+ (make-face-bold face frame)
+ (make-face-unbold face frame))
+ (error nil)))
+
+(defun custom-set-face-italic (face value &optional frame)
+ "Set the italic property of FACE to VALUE."
+ (condition-case nil
+ (if value
+ (make-face-italic face frame)
+ (make-face-unitalic face frame))
+ (error nil)))
+
+;;;###autoload
+(defun custom-initialize-faces (&optional frame)
+ "Initialize all custom faces for FRAME.
+If FRAME is nil or omitted, initialize them for all frames."
+ (mapatoms (lambda (symbol)
+ (let ((spec (or (get symbol 'saved-face)
+ (get symbol 'factory-face))))
+ (when spec
+ (custom-face-display-set symbol spec frame))))))
+
+;;; The `defcustom' Macro.
+
+;;;###autoload
+(defun custom-declare-variable (symbol value &rest args)
+ "Like `defcustom', but SYMBOL and VALUE are evaluated as notmal arguments."
+ (unless (default-boundp symbol)
+ (set-default symbol (eval value)))
+ (put symbol 'factory-value (list value))
+ (while args
+ (let ((arg (car args)))
+ (setq args (cdr args))
+ (cond ((symbolp arg)
+ (let ((keyword arg)
+ (value (car args)))
+ (unless args
+ (error "Keyword %s is missing an argument" keyword))
+ (setq args (cdr args))
+ (cond ((eq keyword :type)
+ (put symbol 'custom-type value))
+ ((eq keyword :group)
+ (custom-add-to-group value symbol 'custom-variable))
+ (t
+ (error "Unknown keyword %s" symbol)))))
+ ((stringp arg)
+ (put symbol 'variable-documentation arg)
+ (when args
+ (error "Junk at end of args %s" args)))
+ (t
+ (error "Junk in args %S"))))))
+
+;;;###autoload
+(defmacro defcustom (symbol value &rest args)
+ "Declare SYMBOL as a customizable variable that defaults to VALUE.
+Neither SYMBOL nor VALUE needs to be quoted.
+If SYMBOL is not already bound, initialize it to VALUE.
+The remaining arguments should have the form
+
+ [KEYWORD VALUE]... DOC
+
+where DOC is the variable documentation.
+
+The following KEYWORD's are defined:
+
+:type VALUE should be a sexp widget.
+:group VALUE should be a customization group.
+ Add SYMBOL to that group.
+
+Read the section about customization in the emacs lisp manual for more
+information."
+ `(custom-declare-variable (quote ,symbol) (quote ,value) ,@args))
+
+;;; The `defface' Macro.
+
+;;;###autoload
+(defun custom-declare-face (face spec &rest args)
+ "Like `defface', but FACE is evaluated as a normal argument."
+ (put face 'factory-face spec)
+ (let ((value (or (get face 'saved-face) spec)))
+ (custom-face-display-set face value))
+ (while args
+ (let ((arg (car args)))
+ (setq args (cdr args))
+ (cond ((symbolp arg)
+ (let ((keyword arg)
+ (value (car args)))
+ (unless args
+ (error "Keyword %s is missing an argument" :type))
+ (setq args (cdr args))
+ (cond ((eq keyword :group)
+ (custom-add-to-group value face 'custom-face))
+ (t
+ (error "Unknown keyword %s" face)))))
+ ((stringp arg)
+ (put face 'face-documentation arg)
+ (when args
+ (error "Junk at end of args %s" args)))
+ (t
+ (error "Junk in args %S"))))))
+
+;;;###autoload
+(defmacro defface (face spec &rest args)
+ "Declare FACE as a customizable face that defaults to SPEC.
+FACE does not need to be quoted.
+
+If FACE has been set with `custom-set-face', set the face attributes
+as specified by that function, otherwise set the face attributes
+according to SPEC.
+
+The remaining arguments should have the form
+
+ [KEYWORD VALUE]... DOC
+
+where DOC is the face documentation.
+
+The following KEYWORD's are defined:
+
+:group VALUE should be a customization group.
+ Add FACE to that group.
+
+SPEC should be an alist of the form ((DISPLAY ATTS)...).
+
+ATTS is a list of face attributes and their values. The possible
+attributes are defined in the variable `custom-face-attributes'.
+Alternatively, ATTS can be a face in which case the attributes of that
+face is used.
+
+The ATTS of the first entry in SPEC where the DISPLAY matches the
+frame should take effect in that frame. DISPLAY can either be the
+symbol `t', which will match all frames, or an alist of the form
+\((REQ ITEM...)...)
+
+For the DISPLAY to match a FRAME, the REQ property of the frame must
+match one of the ITEM. The following REQ are defined:
+
+`type' (the value of (window-system))
+ Should be one of `x' or `tty'.
+
+`class' (the frame's color support)
+ Should be one of `color', `grayscale', or `mono'.
+
+`background' (what color is used for the background text)
+ Should be one of `light' or `dark'.
+
+Read the section about customization in the emacs lisp manual for more
+information."
+ `(custom-declare-face (quote ,face) ,spec ,@args))
+
+;;; The `defgroup' Macro.
+
+;;;###autoload
+(defun custom-declare-group (symbol members &rest args)
+ "Like `defgroup', but SYMBOL is evaluated as a normal argument."
+ (put symbol 'custom-group (nconc members (get symbol 'custom-group)))
+ (while args
+ (let ((arg (car args)))
+ (setq args (cdr args))
+ (cond ((symbolp arg)
+ (let ((keyword arg)
+ (value (car args)))
+ (unless args
+ (error "Keyword %s is missing an argument" :type))
+ (setq args (cdr args))
+ (cond ((eq keyword :group)
+ (custom-add-to-group value symbol 'custom-group))
+ (t
+ (error "Unknown keyword %s" symbol)))))
+ ((stringp arg)
+ (put symbol 'group-documentation arg)
+ (when args
+ (error "Junk at end of args %s" args)))
+ (t
+ (error "Junk in args %S"))))))
+
+;;;###autoload
+(defmacro defgroup (symbol members &rest args)
+ "Declare SYMBOL as a customization group containing MEMBERS.
+SYMBOL does not need to be quoted.
+
+MEMBERS should be an alist of the form ((NAME WIDGET)...) where
+NAME is a symbol and WIDGET is a widget is a widget for editing that
+symbol. Useful widgets are `custom-variable' for editing variables,
+`custom-face' for edit faces, and `custom-group' for editing groups.
+
+The remaining arguments should have the form
+
+ [KEYWORD VALUE]... DOC
+
+where DOC is the group documentation.
+
+The following KEYWORD's are defined:
+
+:group VALUE should be a customization group.
+ Add SYMBOL to that group.
+
+Read the section about customization in the emacs lisp manual for more
+information."
+ `(custom-declare-group (quote ,symbol) ,members ,@args))
+
+;;;###autoload
+(defun custom-add-to-group (group option widget)
+ "To existing GROUP add a new OPTION of type WIDGET,
+If there already is an entry for that option, overwrite it."
+ (let* ((members (get group 'custom-group))
+ (old (assq option members)))
+ (if old
+ (setcar (cdr old) widget)
+ (put group 'custom-group (nconc members (list (list option widget)))))))
+
+;;; Initializing.
+
+;;;###autoload
+(defun custom-set-variables (&rest args)
+ "Initialize variables according to user preferences.
+The arguments should have the form [SYMBOL VALUE]...
+For each symbol, VALUE is evaluated and bound as the default value for
+the symbol. The unevaluated VALUE is also stored as the saved value
+for that symbol."
+ (while args
+ (let ((symbol (nth 0 args))
+ (value (nth 1 args)))
+ (set-default symbol (eval value))
+ (put symbol 'saved-value (list value)))
+ (setq args (cdr (cdr args)))))
+
+;;;###autoload
+(defun custom-set-faces (&rest args)
+ "Initialize faces according to user preferences.
+The arguments should have the form [SYMBOL SPEC]...
+For each symbol, a face with that name is created according to SPEC.
+See `defface' for the format of SPEC."
+ (while args
+ (let ((face (nth 0 args))
+ (spec (nth 1 args)))
+ (put face 'saved-face spec)
+ (custom-face-display-set face spec))
+ (setq args (cdr (cdr args)))))
+
+;;; Meta Customization
+
+(defgroup emacs nil
+ "Customization of the One True Editor.")
+
+(defgroup customize nil
+ :group 'emacs
+ "Customization of the Customization support.")
+
+;;; The End.
+
+(provide 'custom)
+
+;; custom.el ends here
(require 'article)
(require 'gnus-spec)
(require 'gnus-int)
+(require 'browse-url)
(defvar gnus-article-save-directory gnus-directory
"*Name of the directory articles will be saved in (default \"~/News\").")
(eval '(run-hooks 'gnus-load-hook))
-(defconst gnus-version-number "0.36"
+(defconst gnus-version-number "0.37"
"Version number for this version of Gnus.")
(defconst gnus-version (format "Red Gnus v%s" gnus-version-number)
--- /dev/null
+;;; widget-edit.el --- Functions for creating and using widgets.
+;;
+;; Copyright (C) 1996 Free Software Foundation, Inc.
+;;
+;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
+;; Keywords: extensions
+;; Version: 0.9
+;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
+
+;;; Commentary:
+;;
+;; See `widget.el'.
+
+;;; Code:
+
+(require 'widget)
+(require 'custom)
+(require 'cl)
+
+;;; Compatibility.
+
+(or (fboundp 'event-point)
+ ;; XEmacs function missing in Emacs.
+ (defun event-point (event)
+ "Return the character position of the given mouse-motion, button-press,
+or button-release event. If the event did not occur over a window, or did
+not occur over text, then this returns nil. Otherwise, it returns an index
+into the buffer visible in the event's window."
+ (posn-point (event-start event))))
+
+;;; Customization.
+
+(defgroup widgets nil
+ :group 'emacs
+ "Customization support for the Widget Library.")
+
+(defface widget-button-face
+ '((t (:bold t)))
+ :group 'widgets
+ "Face used for widget buttons.")
+
+(defcustom widget-mouse-face 'highlight
+ :type 'face
+ :group 'widgets
+ "Face used for widget buttons when the mouse is above them.")
+
+(defface widget-field-face
+ '((((type x)
+ (class grayscale color)
+ (background light))
+ (:background "light gray"))
+ (((type x)
+ (class grayscale color)
+ (background dark))
+ (:background "dark gray"))
+ (t
+ (:italic t)))
+ :group 'widgets
+ "Face used for editable fields.")
+
+(defcustom widget-menu-max-size 40
+ :type 'integer
+ "Largest number of items allowed in a popup-menu.
+Larger menus are read through the minibuffer.")
+
+;;; Utility functions.
+;;
+;; These are not really widget specific.
+
+(defun widget-plist-member (plist prop)
+ ;; Return non-nil if PLIST has the property PROP.
+ ;; PLIST is a property list, which is a list of the form
+ ;; (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
+ ;; Unlike `plist-get', this allows you to distinguish between a missing
+ ;; property and a property with the value nil.
+ ;; The value is actually the tail of PLIST whose car is PROP.
+ (while (and plist (not (eq (car plist) prop)))
+ (setq plist (cdr (cdr plist))))
+ plist)
+
+(defun widget-princ-to-string (object)
+ ;; Return string representation of OBJECT, any Lisp object.
+ ;; No quoting characters are used; no delimiters are printed around
+ ;; the contents of strings.
+ (save-excursion
+ (set-buffer (get-buffer-create " *widget-tmp*"))
+ (erase-buffer)
+ (let ((standard-output (current-buffer)))
+ (princ object))
+ (buffer-string)))
+
+(defun widget-clear-undo ()
+ "Clear all undo information."
+ (buffer-disable-undo (current-buffer))
+ (buffer-enable-undo))
+
+(defun widget-choose (title items &optional event)
+ "Choose an item from a list.
+
+First argument TITLE is the name of the list.
+Second argument ITEMS is an alist (NAME . VALUE).
+Optional third argument EVENT is an input event.
+
+The user is asked to choose between each NAME from the items alist,
+and the VALUE of the chosen element will be returned. If EVENT is a
+mouse event, and the number of elements in items is less than
+`widget-menu-max-size', a popup menu will be used, otherwise the
+minibuffer."
+ (cond ((and (< (length items) widget-menu-max-size)
+ event (fboundp 'x-popup-menu) window-system)
+ ;; We are in Emacs-19, pressed by the mouse
+ (x-popup-menu event
+ (list title (cons "" items))))
+ ((and (< (length items) widget-menu-max-size)
+ event (fboundp 'popup-menu) window-system)
+ ;; We are in XEmacs, pressed by the mouse
+ (let ((val (get-popup-menu-response
+ (cons ""
+ (mapcar
+ (function
+ (lambda (x)
+ (vector (car x) (list (car x)) t)))
+ items)))))
+ (setq val (and val
+ (listp (event-object val))
+ (stringp (car-safe (event-object val)))
+ (car (event-object val))))
+ (cdr (assoc val items))))
+ (t
+ (cdr (assoc (completing-read (concat title ": ")
+ items nil t)
+ items)))))
+
+;;; Widget text specifications.
+;;
+;; These functions are for specifying text properties.
+
+(defun widget-specify-none (from to)
+ ;; Clear all text properties between FROM and TO.
+ (set-text-properties from to nil))
+
+(defun widget-specify-text (from to)
+ ;; Default properties.
+ (add-text-properties from to (list 'read-only t
+ 'front-sticky t
+ 'rear-nonsticky nil)))
+
+(defun widget-specify-field (widget from to)
+ ;; Specify editable button for WIDGET between FROM and TO.
+ (widget-specify-field-update widget from to)
+ ;; Make it possible to edit both end of the field.
+ (put-text-property (- from 2) from 'intangible t)
+ (add-text-properties (1- from) from (list 'rear-nonsticky t
+ 'end-open t
+ 'invisible t))
+ (add-text-properties to (1+ to) (list 'front-sticky nil
+ 'start-open t)))
+
+(defun widget-specify-field-update (widget from to)
+ ;; Specify editable button for WIDGET between FROM and TO.
+ (let ((map (widget-get widget :keymap))
+ (face (or (widget-get widget :value-face)
+ 'widget-field-face)))
+ (set-text-properties from to (list 'field widget
+ 'read-only nil
+ 'keymap map
+ 'local-map map
+ 'face face))))
+
+(defun widget-specify-button (widget from to)
+ ;; Specify button for WIDGET between FROM and TO.
+ (let ((face (widget-apply widget :button-face-get)))
+ (add-text-properties from to (list 'button widget
+ 'mouse-face widget-mouse-face
+ 'face face))))
+
+(defun widget-specify-doc (widget from to)
+ ;; Specify documentation for WIDGET between FROM and TO.
+ (put-text-property from to 'widget-doc widget))
+
+
+(defmacro widget-specify-insert (&rest form)
+ ;; Execute FORM without inheriting any text properties.
+ `(save-restriction
+ (let ((inhibit-read-only t)
+ result
+ after-change-functions)
+ (insert "<>")
+ (narrow-to-region (- (point) 2) (point))
+ (widget-specify-none (point-min) (point-max))
+ (goto-char (1+ (point-min)))
+ (setq result (progn ,@form))
+ (delete-region (point-min) (1+ (point-min)))
+ (delete-region (1- (point-max)) (point-max))
+ (goto-char (point-max))
+ result)))
+
+;;; Widget Properties.
+
+(defun widget-put (widget property value)
+ "In WIDGET set PROPERTY to VALUE.
+The value can later be retrived with `widget-get'."
+ (setcdr widget (plist-put (cdr widget) property value)))
+
+(defun widget-get (widget property)
+ "In WIDGET, get the value of PROPERTY.
+The value could either be specified when the widget was created, or
+later with `widget-put'."
+ (cond ((widget-plist-member (cdr widget) property)
+ (plist-get (cdr widget) property))
+ ((car widget)
+ (widget-get (get (car widget) 'widget-type) property))
+ (t nil)))
+
+(defun widget-member (widget property)
+ "Non-nil iff there is a definition in WIDGET for PROPERTY."
+ (cond ((widget-plist-member (cdr widget) property)
+ t)
+ ((car widget)
+ (widget-member (get (car widget) 'widget-type) property))
+ (t nil)))
+
+(defun widget-apply (widget property &rest args)
+ "Apply the value of WIDGET's PROPERTY to the widget itself.
+ARGS are passed as extra argments to the function."
+ (apply (widget-get widget property) widget args))
+
+(defun widget-value (widget)
+ "Extract the current value of WIDGET."
+ (widget-apply widget
+ :value-to-external (widget-apply widget :value-get)))
+
+(defun widget-value-set (widget value)
+ "Set the current value of WIDGET to VALUE."
+ (widget-apply widget
+ :value-set (widget-apply widget
+ :value-to-internal value)))
+
+(defun widget-match-inline (widget vals)
+ ;; In WIDGET, match the start of VALS.
+ (cond ((widget-get widget :inline)
+ (widget-apply widget :match-inline vals))
+ ((and vals
+ (widget-apply widget :match (car vals)))
+ (cons (list (car vals)) (cdr vals)))
+ (t nil)))
+
+;;; Creating Widgets.
+
+;;;###autoload
+(defun widget-create (type &rest args)
+ "Create widget of TYPE.
+The optional ARGS are additional keyword arguments."
+ (let ((widget (apply 'widget-convert type args)))
+ (widget-apply widget :create)
+ widget))
+
+;;;###autoload
+(defun widget-delete (widget)
+ "Delete WIDGET."
+ (widget-apply widget :delete))
+
+(defun widget-convert (type &rest args)
+ "Convert TYPE to a widget without inserting it in the buffer.
+The optional ARGS are additional keyword arguments."
+ ;; Don't touch the type.
+ (let* ((widget (if (symbolp type)
+ (list type)
+ (copy-list type)))
+ (current widget)
+ (keys args))
+ ;; First set the :args keyword.
+ (while (cdr current) ;Look in the type.
+ (let ((next (car (cdr current))))
+ (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
+ (setq current (cdr (cdr current)))
+ (setcdr current (list :args (cdr current)))
+ (setq current nil))))
+ (while args ;Look in the args.
+ (let ((next (nth 0 args)))
+ (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
+ (setq args (nthcdr 2 args))
+ (widget-put widget :args args)
+ (setq args nil))))
+ ;; Then Convert the widget.
+ (setq type widget)
+ (while type
+ (let ((convert-widget (plist-get (cdr type) :convert-widget)))
+ (if convert-widget
+ (setq widget (funcall convert-widget widget))))
+ (setq type (get (car type) 'widget-type)))
+ ;; Finally set the keyword args.
+ (while keys
+ (let ((next (nth 0 keys)))
+ (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
+ (progn
+ (widget-put widget next (nth 1 keys))
+ (setq keys (nthcdr 2 keys)))
+ (setq keys nil))))
+ ;; Convert the :value to internal format.
+ (if (widget-member widget :value)
+ (let ((value (widget-get widget :value)))
+ (widget-put widget
+ :value (widget-apply widget :value-to-internal value))))
+ ;; Return the newly create widget.
+ widget))
+
+(defun widget-insert (&rest args)
+ "Call `insert' with ARGS and make the text read only."
+ (let ((inhibit-read-only t)
+ after-change-functions
+ (from (point)))
+ (apply 'insert args)
+ (widget-specify-text from (point))))
+
+;;; Keymap and Comands.
+
+(defvar widget-keymap nil
+ "Keymap containing useful binding for buffers containing widgets.
+Recommended as a parent keymap for modes using widgets.")
+
+(if widget-keymap
+ ()
+ (setq widget-keymap (make-sparse-keymap))
+ (set-keymap-parent widget-keymap global-map)
+ (define-key widget-keymap "\t" 'widget-forward)
+ (define-key widget-keymap "\M-\t" 'widget-backward)
+ (define-key widget-keymap [(shift tab)] 'widget-backward)
+ (if (string-match "XEmacs" (emacs-version))
+ (define-key widget-keymap [button2] 'widget-button-click)
+ (define-key widget-keymap [menu-bar] 'nil)
+ (define-key widget-keymap [mouse-2] 'widget-button-click))
+ (define-key widget-keymap "\C-m" 'widget-button-press))
+
+(defvar widget-global-map global-map
+ "Keymap used for events the widget does not handle themselves.")
+(make-variable-buffer-local 'widget-global-map)
+
+(defun widget-button-click (event)
+ "Activate button below mouse pointer."
+ (interactive "@e")
+ (widget-button-press (event-point event) event))
+
+(defun widget-button-press (pos &optional event)
+ "Activate button at POS."
+ (interactive "@d")
+ (let* ((button (get-text-property pos 'button)))
+ (if button
+ (widget-apply button :action event)
+ (call-interactively
+ (lookup-key widget-global-map (this-command-keys))))))
+
+(defun widget-forward (arg)
+ "Move point to the next field or button.
+With optional ARG, move across that many fields."
+ (interactive "p")
+ (while (> arg 0)
+ (setq arg (1- arg))
+ (let ((next (cond ((get-text-property (point) 'button)
+ (next-single-property-change (point) 'button))
+ ((get-text-property (point) 'field)
+ (next-single-property-change (point) 'field))
+ (t
+ (point)))))
+ (if (null next) ; Widget extends to end. of buffer
+ (setq next (point-min)))
+ (let ((button (next-single-property-change next 'button))
+ (field (next-single-property-change next 'field)))
+ (cond ((or (get-text-property next 'button)
+ (get-text-property next 'field))
+ (goto-char next))
+ ((and button field)
+ (goto-char (min button field)))
+ (button (goto-char button))
+ (field (goto-char field))
+ (t
+ (let ((button (next-single-property-change (point-min) 'button))
+ (field (next-single-property-change (point-min) 'field)))
+ (cond ((and button field) (goto-char (min button field)))
+ (button (goto-char button))
+ (field (goto-char field))
+ (t
+ (error "No buttons or fields found")))))))))
+ (while (< arg 0)
+ (if (= (point-min) (point))
+ (forward-char 1))
+ (setq arg (1+ arg))
+ (let ((previous (cond ((get-text-property (1- (point)) 'button)
+ (previous-single-property-change (point) 'button))
+ ((get-text-property (1- (point)) 'field)
+ (previous-single-property-change (point) 'field))
+ (t
+ (point)))))
+ (if (null previous) ; Widget extends to beg. of buffer
+ (setq previous (point-max)))
+ (let ((button (previous-single-property-change previous 'button))
+ (field (previous-single-property-change previous 'field)))
+ (cond ((and button field)
+ (goto-char (max button field)))
+ (button (goto-char button))
+ (field (goto-char field))
+ (t
+ (let ((button (previous-single-property-change
+ (point-max) 'button))
+ (field (previous-single-property-change
+ (point-max) 'field)))
+ (cond ((and button field) (goto-char (max button field)))
+ (button (goto-char button))
+ (field (goto-char field))
+ (t
+ (error "No buttons or fields found"))))))))
+ (let ((button (previous-single-property-change (point) 'button))
+ (field (previous-single-property-change (point) 'field)))
+ (cond ((and button field)
+ (goto-char (max button field)))
+ (button (goto-char button))
+ (field (goto-char field)))))
+ (let ((help-echo (or (get-text-property (point) 'button)
+ (get-text-property (point) 'field))))
+ (if (and help-echo (setq help-echo (widget-get help-echo :help-echo)))
+ (message "%s" help-echo))))
+
+(defun widget-backward (arg)
+ "Move point to the previous field or button.
+With optional ARG, move across that many fields."
+ (interactive "p")
+ (widget-forward (- arg)))
+
+;;; Setting up the buffer.
+
+(defvar widget-field-new nil)
+;; List of all newly created editable fields in the buffer.
+(make-variable-buffer-local 'widget-field-new)
+
+(defvar widget-field-list nil)
+;; List of all editable fields in the buffer.
+(make-variable-buffer-local 'widget-field-list)
+
+(defun widget-setup ()
+ "Setup current buffer so editing string widgets works."
+ (let ((inhibit-read-only t)
+ (after-change-functions nil)
+ field)
+ (while widget-field-new
+ (setq field (car widget-field-new)
+ widget-field-new (cdr widget-field-new)
+ widget-field-list (cons field widget-field-list))
+ (let ((from (widget-get field :value-from))
+ (to (widget-get field :value-to)))
+ (widget-specify-field field from to)
+ (move-marker from (1- from))
+ (move-marker to (1+ to)))))
+ (widget-clear-undo)
+ ;; We need to maintain text properties and size of the editing fields.
+ (make-local-variable 'after-change-functions)
+ (if widget-field-list
+ (setq after-change-functions '(widget-after-change))
+ (setq after-change-functions nil)))
+
+(defvar widget-field-last nil)
+;; Last field containing point.
+(make-variable-buffer-local 'widget-field-last)
+
+(defvar widget-field-was nil)
+;; The widget data before the change.
+(make-variable-buffer-local 'widget-field-was)
+
+(defun widget-field-find (pos)
+ ;; Find widget whose editing field is located at POS.
+ ;; Return nil if POS is not inside and editing field.
+ ;;
+ ;; This is only used in `widget-field-modified', since ordinarily
+ ;; you would just test the field property.
+ (let ((fields widget-field-list)
+ field found)
+ (while fields
+ (setq field (car fields)
+ fields (cdr fields))
+ (let ((from (widget-get field :value-from))
+ (to (widget-get field :value-to)))
+ (if (and from to (< from pos) (> to pos))
+ (setq fields nil
+ found field))))
+ found))
+
+(defun widget-after-change (from to old)
+ ;; Adjust field size and text properties.
+ (condition-case nil
+ (let ((field (widget-field-find from))
+ (inhibit-read-only t))
+ (cond ((null field))
+ ((not (eq field (widget-field-find to)))
+ (debug)
+ (message "Error: `widget-after-change' called on two fields"))
+ (t
+ (let ((size (widget-get field :size)))
+ (if size
+ (let ((begin (1+ (widget-get field :value-from)))
+ (end (1- (widget-get field :value-to))))
+ (widget-specify-field-update field begin end)
+ (cond ((< (- end begin) size)
+ ;; Field too small.
+ (save-excursion
+ (goto-char end)
+ (insert-char ?\ (- (+ begin size) end))))
+ ((> (- end begin) size)
+ ;; Field too large and
+ (if (or (< (point) (+ begin size))
+ (> (point) end))
+ ;; Point is outside extra space.
+ (setq begin (+ begin size))
+ ;; Point is within the extra space.
+ (setq begin (point)))
+ (save-excursion
+ (goto-char end)
+ (while (and (eq (preceding-char) ?\ )
+ (> (point) begin))
+ (delete-backward-char 1))))))
+ (widget-specify-field-update field from to)))
+ (widget-apply field :notify field))))
+ (error (debug))))
+
+;;; The `default' Widget.
+
+(define-widget 'default nil
+ "Basic widget other widgets are derived from."
+ :value-to-internal (lambda (widget value) value)
+ :value-to-external (lambda (widget value) value)
+ :create 'widget-default-create
+ :format-handler 'widget-default-format-handler
+ :button-face-get 'widget-default-button-face-get
+ :delete 'widget-default-delete
+ :value-set 'widget-default-value-set
+ :value-inline 'widget-default-value-inline
+ :menu-tag-get 'widget-default-menu-tag-get
+ :validate (lambda (widget) t)
+ :action 'widget-default-action
+ :notify 'widget-default-notify)
+
+(defun widget-default-create (widget)
+ "Create WIDGET at point in the current buffer."
+ (widget-specify-insert
+ (let ((from (point))
+ (tag (widget-get widget :tag))
+ (doc (widget-get widget :doc))
+ button-begin button-end
+ doc-begin doc-end
+ value-pos)
+ (insert (widget-get widget :format))
+ (goto-char from)
+ ;; Parse % escapes in format.
+ (while (re-search-forward "%\\(.\\)" nil t)
+ (let ((escape (aref (match-string 1) 0)))
+ (replace-match "" t t)
+ (cond ((eq escape ?%)
+ (insert "%"))
+ ((eq escape ?\[)
+ (setq button-begin (point)))
+ ((eq escape ?\])
+ (setq button-end (point)))
+ ((eq escape ?t)
+ (if tag
+ (insert tag)
+ (let ((standard-output (current-buffer)))
+ (princ (widget-get widget :value)))))
+ ((eq escape ?d)
+ (when doc
+ (setq doc-begin (point))
+ (insert doc)
+ (while (eq (preceding-char) ?\n)
+ (delete-backward-char 1))
+ (insert "\n")
+ (setq doc-end (point))))
+ ((eq escape ?v)
+ (if (and button-begin (not button-end))
+ (widget-apply widget :value-create)
+ (setq value-pos (point))))
+ (t
+ (widget-apply widget :format-handler escape)))))
+ ;; Specify button and doc, and insert value.
+ (and button-begin button-end
+ (widget-specify-button widget button-begin button-end))
+ (and doc-begin doc-end
+ (widget-specify-doc widget doc-begin doc-end))
+ (when value-pos
+ (goto-char value-pos)
+ (widget-apply widget :value-create)))
+ (let ((from (copy-marker (point-min)))
+ (to (copy-marker (point-max))))
+ (widget-specify-text from to)
+ (set-marker-insertion-type from t)
+ (set-marker-insertion-type to nil)
+ (widget-put widget :from from)
+ (widget-put widget :to to))))
+
+(defun widget-default-format-handler (widget escape)
+ ;; By default unknown escapes are errors.
+ (error "Unknown escape `%c'" escape))
+
+(defun widget-default-button-face-get (widget)
+ ;; Use :button-face or widget-button-face
+ (or (widget-get widget :button-face) 'widget-button-face))
+
+(defun widget-default-delete (widget)
+ ;; Remove widget from the buffer.
+ (let ((from (widget-get widget :from))
+ (to (widget-get widget :to))
+ (inhibit-read-only t)
+ after-change-functions)
+ (widget-apply widget :value-delete)
+ (delete-region from to)
+ (set-marker from nil)
+ (set-marker to nil)))
+
+(defun widget-default-value-set (widget value)
+ ;; Recreate widget with new value.
+ (save-excursion
+ (goto-char (widget-get widget :from))
+ (widget-apply widget :delete)
+ (widget-put widget :value value)
+ (widget-apply widget :create)))
+
+(defun widget-default-value-inline (widget)
+ ;; Wrap value in a list unless it is inline.
+ (if (widget-get widget :inline)
+ (widget-value widget)
+ (list (widget-value widget))))
+
+(defun widget-default-menu-tag-get (widget)
+ ;; Use tag or value for menus.
+ (or (widget-get widget :menu-tag)
+ (widget-get widget :tag)
+ (widget-princ-to-string (widget-get widget :value))))
+
+(defun widget-default-action (widget &optional event)
+ ;; Notify the parent when a widget change
+ (let ((parent (widget-get widget :parent)))
+ (when parent
+ (widget-apply parent :notify widget event))))
+
+(defun widget-default-notify (widget child &optional event)
+ ;; Pass notification to parent.
+ (widget-default-action widget event))
+
+;;; The `item' Widget.
+
+(define-widget 'item 'default
+ "Constant items for inclusion in other widgets."
+ :convert-widget 'widget-item-convert-widget
+ :value-create 'widget-item-value-create
+ :value-delete 'ignore
+ :value-get 'widget-item-value-get
+ :match 'widget-item-match
+ :match-inline 'widget-item-match-inline
+ :action 'widget-item-action
+ :format "%t\n")
+
+(defun widget-item-convert-widget (widget)
+ ;; Initialize :value and :tag from :args in WIDGET.
+ (let ((args (widget-get widget :args)))
+ (when args
+ (widget-put widget :value (widget-apply widget
+ :value-to-internal (car args)))
+ (widget-put widget :args nil)))
+ widget)
+
+(defun widget-item-value-create (widget)
+ ;; Insert the printed representation of the value.
+ (let ((standard-output (current-buffer)))
+ (princ (widget-get widget :value))))
+
+(defun widget-item-match (widget value)
+ ;; Match if the value is the same.
+ (equal (widget-get widget :value) value))
+
+(defun widget-item-match-inline (widget values)
+ ;; Match if the value is the same.
+ (let ((value (widget-get widget :value)))
+ (and (listp value)
+ (<= (length value) (length values))
+ (let ((head (subseq values 0 (length value))))
+ (and (equal head value)
+ (cons head (subseq values (length value))))))))
+
+(defun widget-item-action (widget &optional event)
+ ;; Just notify itself.
+ (widget-apply widget :notify widget event))
+
+(defun widget-item-value-get (widget)
+ ;; Items are simple.
+ (widget-get widget :value))
+
+;;; The `push' Widget.
+
+(define-widget 'push 'item
+ "A pushable button."
+ :format "%[[%t]%]%d")
+
+;;; The `link' Widget.
+
+(define-widget 'link 'item
+ "An embedded link."
+ :format "%[_%t_%]%d")
+
+;;; The `field' Widget.
+
+(define-widget 'field 'default
+ "An editable text field."
+ :convert-widget 'widget-item-convert-widget
+ :format "%v"
+ :value ""
+ :tag "field"
+ :value-create 'widget-field-value-create
+ :value-delete 'widget-field-value-delete
+ :value-get 'widget-field-value-get
+ :match 'widget-field-match)
+
+(defun widget-field-value-create (widget)
+ ;; Create an editable text field.
+ (insert " ")
+ (let ((size (widget-get widget :size))
+ (value (widget-get widget :value))
+ (from (point)))
+ (if (null size)
+ (insert value " ")
+ (insert value)
+ (if (< (length value) size)
+ (insert-char ?\ (- size (length value)))))
+ (unless (memq widget widget-field-list)
+ (setq widget-field-new (cons widget widget-field-new)))
+ (widget-put widget :value-from (copy-marker from))
+ (set-marker-insertion-type (widget-get widget :value-from) t)
+ (widget-put widget :value-to (copy-marker (point)))
+ (set-marker-insertion-type (widget-get widget :value-to) nil)
+ (if (null size)
+ (insert ?\n)
+ (insert ?\ ))))
+
+(defun widget-field-value-delete (widget)
+ ;; Remove the widget from the list of active editing fields.
+ (setq widget-field-list (delq widget widget-field-list))
+ (set-marker (widget-get widget :value-from) nil)
+ (set-marker (widget-get widget :value-to) nil))
+
+(defun widget-field-value-get (widget)
+ ;; Return current text in editing field.
+ (let ((from (widget-get widget :value-from))
+ (to (widget-get widget :value-to))
+ (old (current-buffer)))
+ (if (and from to)
+ (progn
+ (set-buffer (marker-buffer from))
+ (setq from (1+ from)
+ to (1- to))
+ (while (and (> to from)
+ (eq (char-after (1- to)) ?\ ))
+ (setq to (1- to)))
+ (prog1 (buffer-substring-no-properties from to)
+ (set-buffer old)))
+ (widget-get widget :value))))
+
+(defun widget-field-match (widget value)
+ ;; Match any string.
+ (stringp value))
+
+;;; The `text' Widget.
+
+(define-widget 'text 'field
+ "A multiline text area.")
+
+;;; The `choice' Widget.
+
+(define-widget 'choice 'default
+ "A menu of options."
+ :convert-widget 'widget-choice-convert-widget
+ :format "%[%t%]: %v"
+ :tag "choice"
+ :void '(item :format "invalid (%t)\n")
+ :value-create 'widget-choice-value-create
+ :value-delete 'widget-radio-value-delete
+ :value-get 'widget-choice-value-get
+ :value-inline 'widget-choice-value-inline
+ :action 'widget-choice-action
+ :error "Make a choice"
+ :validate 'widget-choice-validate
+ :match 'widget-choice-match
+ :match-inline 'widget-choice-match-inline)
+
+(defun widget-choice-convert-widget (widget)
+ ;; Expand type args into widget objects.
+ (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args)))
+ widget)
+
+(defun widget-choice-value-create (widget)
+ ;; Insert the first choice that matches the value.
+ (let ((value (widget-get widget :value))
+ (args (widget-get widget :args))
+ current)
+ (while args
+ (setq current (car args)
+ args (cdr args))
+ (when (widget-apply current :match value)
+ (widget-put widget :children (list (widget-create current
+ :parent widget
+ :value value)))
+ (widget-put widget :choice current)
+ (setq args nil
+ current nil)))
+ (when current
+ (let ((void (widget-get widget :void)))
+ (widget-put widget :children (list (widget-create void
+ :parent widget
+ :value value)))
+ (widget-put widget :choice void)))))
+
+(defun widget-choice-value-get (widget)
+ ;; Get value of the child widget.
+ (widget-value (car (widget-get widget :children))))
+
+(defun widget-choice-value-inline (widget)
+ ;; Get value of the child widget.
+ (widget-apply (car (widget-get widget :children)) :value-inline))
+
+(defun widget-choice-action (widget &optional event)
+ ;; Make a choice.
+ (let ((args (widget-get widget :args))
+ (old (widget-get widget :choice))
+ (tag (widget-apply widget :menu-tag-get))
+ current choices)
+ ;; Remember old value.
+ (if (and old (widget-apply widget :validate))
+ (let* ((external (widget-value widget))
+ (internal (widget-apply old :value-to-internal external)))
+ (widget-put old :value internal)))
+ ;; Find new choice.
+ (setq current
+ (cond ((= (length args) 0)
+ nil)
+ ((= (length args) 1)
+ (nth 0 args))
+ ((and (= (length args) 2)
+ (memq old args))
+ (if (eq old (nth 0 args))
+ (nth 1 args)
+ (nth 0 args)))
+ (t
+ (while args
+ (setq current (car args)
+ args (cdr args))
+ (setq choices
+ (cons (cons (widget-apply current :menu-tag-get)
+ current)
+ choices)))
+ (widget-choose tag (reverse choices) event))))
+ (when current
+ (widget-value-set widget
+ (widget-apply current :value-to-external
+ (widget-get current :value)))
+ (widget-setup)))
+ ;; Notify parent.
+ (widget-apply widget :notify widget event)
+ (widget-clear-undo))
+
+(defun widget-choice-validate (widget)
+ ;; Valid if we have made a valid choice.
+ (let ((void (widget-get widget :void))
+ (choice (widget-get widget :choice))
+ (child (car (widget-get widget :children))))
+ (if (eq void choice)
+ widget
+ (widget-apply child :validate))))
+
+(defun widget-choice-match (widget value)
+ ;; Matches if one of the choices matches.
+ (let ((args (widget-get widget :args))
+ current found)
+ (while (and args (not found))
+ (setq current (car args)
+ args (cdr args)
+ found (widget-apply current :match value)))
+ found))
+
+(defun widget-choice-match-inline (widget values)
+ ;; Matches if one of the choices matches.
+ (let ((args (widget-get widget :args))
+ current found)
+ (while (and args (null found))
+ (setq current (car args)
+ args (cdr args)
+ found (widget-match-inline current values)))
+ found))
+
+;;; The `toggle' Widget.
+
+(define-widget 'toggle 'choice
+ "Toggle between two states."
+ :convert-widget 'widget-toggle-convert-widget
+ :format "%v"
+ :on "on"
+ :off "off")
+
+(defun widget-toggle-convert-widget (widget)
+ ;; Create the types representing the `on' and `off' states.
+ (let ((on-type (widget-get widget :on-type))
+ (off-type (widget-get widget :off-type)))
+ (unless on-type
+ (setq on-type
+ (list 'choice-item
+ :value t
+ :match (lambda (widget value) value)
+ :tag (widget-get widget :on))))
+ (unless off-type
+ (setq off-type
+ (list 'choice-item :value nil :tag (widget-get widget :off))))
+ (widget-put widget :args (list on-type off-type)))
+ widget)
+
+;;; The `checkbox' Widget.
+
+(define-widget 'checkbox 'toggle
+ "A checkbox toggle."
+ :convert-widget 'widget-item-convert-widget
+ :on-type '(choice-item :format "%[[X]%]" t)
+ :off-type '(choice-item :format "%[[ ]%]" nil))
+
+;;; The `checklist' Widget.
+
+(define-widget 'checklist 'default
+ "A multiple choice widget."
+ :convert-widget 'widget-choice-convert-widget
+ :format "%v"
+ :entry-format "%b %v"
+ :menu-tag "checklist"
+ :greedy nil
+ :value-create 'widget-checklist-value-create
+ :value-delete 'widget-radio-value-delete
+ :value-get 'widget-checklist-value-get
+ :validate 'widget-checklist-validate
+ :match 'widget-checklist-match
+ :match-inline 'widget-checklist-match-inline)
+
+(defun widget-checklist-value-create (widget)
+ ;; Insert all values
+ (let ((alist (widget-checklist-match-find widget (widget-get widget :value)))
+ (args (widget-get widget :args)))
+ (while args
+ (widget-checklist-add-item widget (car args) (assq (car args) alist))
+ (setq args (cdr args)))
+ (widget-put widget :children (nreverse (widget-get widget :children)))))
+
+(defun widget-checklist-add-item (widget type chosen)
+ ;; Create checklist item in WIDGET of type TYPE.
+ ;; If the item is checked, CHOSEN is a cons whose cdr is the value.
+ (widget-specify-insert
+ (let* ((children (widget-get widget :children))
+ (buttons (widget-get widget :buttons))
+ (from (point))
+ child button)
+ (insert (widget-get widget :entry-format))
+ (goto-char from)
+ ;; Parse % escapes in format.
+ (while (re-search-forward "%\\([bv%]\\)" nil t)
+ (let ((escape (aref (match-string 1) 0)))
+ (replace-match "" t t)
+ (cond ((eq escape ?%)
+ (insert "%"))
+ ((eq escape ?b)
+ (setq button (widget-create 'checkbox
+ :parent widget
+ :value (not (null chosen)))))
+ ((eq escape ?v)
+ (setq child
+ (cond ((not chosen)
+ (widget-create type :parent widget))
+ ((widget-get type :inline)
+ (widget-create type
+ :parent widget
+ :value (cdr chosen)))
+ (t
+ (widget-create type
+ :parent widget
+ :value (car (cdr chosen)))))))
+ (t
+ (error "Unknown escape `%c'" escape)))))
+ ;; Update properties.
+ (and button child (widget-put child :button button))
+ (and button (widget-put widget :buttons (cons button buttons)))
+ (and child (widget-put widget :children (cons child children))))))
+
+(defun widget-checklist-match (widget values)
+ ;; All values must match a type in the checklist.
+ (and (listp values)
+ (null (cdr (widget-checklist-match-inline widget values)))))
+
+(defun widget-checklist-match-inline (widget values)
+ ;; Find the values which match a type in the checklist.
+ (let ((greedy (widget-get widget :greedy))
+ (args (copy-list (widget-get widget :args)))
+ found rest)
+ (while values
+ (let ((answer (widget-checklist-match-up args values)))
+ (cond (answer
+ (let ((vals (widget-match-inline answer values)))
+ (setq found (append found (car vals))
+ values (cdr vals)
+ args (delq answer args))))
+ (greedy
+ (setq rest (append rest (list (car values)))
+ values (cdr values)))
+ (t
+ (setq rest (append rest values)
+ values nil)))))
+ (cons found rest)))
+
+(defun widget-checklist-match-find (widget vals)
+ ;; Find the vals which match a type in the checklist.
+ ;; Return an alist of (TYPE MATCH).
+ (let ((greedy (widget-get widget :greedy))
+ (args (copy-list (widget-get widget :args)))
+ found)
+ (while vals
+ (let ((answer (widget-checklist-match-up args vals)))
+ (cond (answer
+ (let ((match (widget-match-inline answer vals)))
+ (setq found (cons (cons answer (car match)) found)
+ vals (cdr match)
+ args (delq answer args))))
+ (greedy
+ (setq vals (cdr vals)))
+ (t
+ (setq vals nil)))))
+ found))
+
+(defun widget-checklist-match-up (args vals)
+ ;; Rerturn the first type from ARGS that matches VALS.
+ (let (current found)
+ (while (and args (null found))
+ (setq current (car args)
+ args (cdr args)
+ found (widget-match-inline current vals)))
+ (and found current)))
+
+(defun widget-checklist-value-get (widget)
+ ;; The values of all selected items.
+ (let ((children (widget-get widget :children))
+ child result)
+ (while children
+ (setq child (car children)
+ children (cdr children))
+ (if (widget-value (widget-get child :button))
+ (setq result (append result (widget-apply child :value-inline)))))
+ result))
+
+(defun widget-checklist-validate (widget)
+ ;; Ticked chilren must be valid.
+ (let ((children (widget-get widget :children))
+ child button found)
+ (while (and children (not found))
+ (setq child (car children)
+ children (cdr children)
+ button (widget-get child :button)
+ found (and (widget-value button)
+ (widget-apply child :validate))))
+ found))
+
+;;; The `option' Widget
+
+(define-widget 'option 'checklist
+ "An widget with an optional item."
+ :inline t)
+
+;;; The `choice-item' Widget.
+
+(define-widget 'choice-item 'item
+ "Button items that delegate action events to their parents."
+ :action 'widget-choice-item-action
+ :format "%[%t%] \n")
+
+(defun widget-choice-item-action (widget &optional event)
+ ;; Tell parent what happened.
+ (widget-apply (widget-get widget :parent) :action event))
+
+;;; The `radio-button' Widget.
+
+(define-widget 'radio-button 'toggle
+ "A radio button for use in the `radio' widget."
+ :notify 'widget-radio-button-notify
+ :on-type '(choice-item :format "%[(*)%]" t)
+ :off-type '(choice-item :format "%[( )%]" nil))
+
+(defun widget-radio-button-notify (widget child &optional event)
+ ;; Notify the parent.
+ (widget-apply (widget-get widget :parent) :action widget event))
+
+;;; The `radio' Widget.
+
+(define-widget 'radio 'default
+ "Select one of multiple options."
+ :convert-widget 'widget-choice-convert-widget
+ :format "%v"
+ :entry-format "%b %v"
+ :menu-tag "radio"
+ :value-create 'widget-radio-value-create
+ :value-delete 'widget-radio-value-delete
+ :value-get 'widget-radio-value-get
+ :value-inline 'widget-radio-value-inline
+ :value-set 'widget-radio-value-set
+ :error "You must push one of the buttons"
+ :validate 'widget-radio-validate
+ :match 'widget-choice-match
+ :match-inline 'widget-choice-match-inline
+ :action 'widget-radio-action)
+
+(defun widget-radio-value-create (widget)
+ ;; Insert all values
+ (let ((args (widget-get widget :args))
+ (indent (widget-get widget :indent))
+ arg)
+ (while args
+ (setq arg (car args)
+ args (cdr args))
+ (widget-radio-add-item widget arg)
+ (and indent args (insert-char ?\ indent)))))
+
+(defun widget-radio-add-item (widget type)
+ "Add to radio widget WIDGET a new radio button item of type TYPE."
+ (setq type (widget-convert type))
+ (widget-specify-insert
+ (let* ((value (widget-get widget :value))
+ (children (widget-get widget :children))
+ (buttons (widget-get widget :buttons))
+ (from (point))
+ (chosen (and (null (widget-get widget :choice))
+ (widget-apply type :match value)))
+ child button)
+ (insert (widget-get widget :entry-format))
+ (goto-char from)
+ ;; Parse % escapes in format.
+ (while (re-search-forward "%\\([bv%]\\)" nil t)
+ (let ((escape (aref (match-string 1) 0)))
+ (replace-match "" t t)
+ (cond ((eq escape ?%)
+ (insert "%"))
+ ((eq escape ?b)
+ (setq button (widget-create 'radio-button
+ :parent widget
+ :value (not (null chosen)))))
+ ((eq escape ?v)
+ (setq child (if chosen
+ (widget-create type
+ :parent widget
+ :value value)
+ (widget-create type :parent widget))))
+ (t
+ (error "Unknown escape `%c'" escape)))))
+ ;; Update properties.
+ (when chosen
+ (widget-put widget :choice type))
+ (when button
+ (widget-put child :button button)
+ (widget-put widget :buttons (nconc buttons (list button))))
+ (when child
+ (widget-put widget :children (nconc children (list child))))
+ child)))
+
+(defun widget-radio-value-delete (widget)
+ ;; Delete the child widgets.
+ (mapcar 'widget-delete (widget-get widget :children))
+ (widget-put widget :children nil)
+ (mapcar 'widget-delete (widget-get widget :buttons))
+ (widget-put widget :buttons nil))
+
+(defun widget-radio-value-get (widget)
+ ;; Get value of the child widget.
+ (let ((chosen (widget-radio-chosen widget)))
+ (and chosen (widget-value chosen))))
+
+(defun widget-radio-chosen (widget)
+ "Return the widget representing the chosen radio button."
+ (let ((children (widget-get widget :children))
+ current found)
+ (while children
+ (setq current (car children)
+ children (cdr children))
+ (let* ((button (widget-get current :button))
+ (value (widget-apply button :value-get)))
+ (when value
+ (setq found current
+ children nil))))
+ found))
+
+(defun widget-radio-value-inline (widget)
+ ;; Get value of the child widget.
+ (let ((children (widget-get widget :children))
+ current found)
+ (while children
+ (setq current (car children)
+ children (cdr children))
+ (let* ((button (widget-get current :button))
+ (value (widget-apply button :value-get)))
+ (when value
+ (setq found (widget-apply current :value-inline)
+ children nil))))
+ found))
+
+(defun widget-radio-value-set (widget value)
+ ;; We can't just delete and recreate a radio widget, since children
+ ;; can be added after the original creation and won't be recreated
+ ;; by `:create'.
+ (let ((children (widget-get widget :children))
+ current found)
+ (while children
+ (setq current (car children)
+ children (cdr children))
+ (let* ((button (widget-get current :button))
+ (match (and (not found)
+ (widget-apply current :match value))))
+ (widget-value-set button match)
+ (if match
+ (widget-value-set current value))
+ (setq found (or found match))))))
+
+(defun widget-radio-validate (widget)
+ ;; Valid if we have made a valid choice.
+ (let ((children (widget-get widget :children))
+ current found button)
+ (while (and children (not found))
+ (setq current (car children)
+ children (cdr children)
+ button (widget-get current :button)
+ found (widget-apply button :value-get)))
+ (if found
+ (widget-apply current :validate)
+ widget)))
+
+(defun widget-radio-action (widget child event)
+ ;; Check if a radio button was pressed.
+ (let ((children (widget-get widget :children))
+ (buttons (widget-get widget :buttons))
+ current)
+ (when (memq child buttons)
+ (while children
+ (setq current (car children)
+ children (cdr children))
+ (let* ((button (widget-get current :button)))
+ (cond ((eq child button)
+ (widget-value-set button t))
+ ((widget-value button)
+ (widget-value-set button nil)))))))
+ ;; Pass notification to parent.
+ (widget-apply widget :notify child event))
+
+;;; The `insert-button' Widget.
+
+(define-widget 'insert-button 'push
+ "An insert button for the `repeat' widget."
+ :tag "INS"
+ :action 'widget-insert-button-action)
+
+(defun widget-insert-button-action (widget &optional event)
+ ;; Ask the parent to insert a new item.
+ (widget-apply (widget-get widget :parent)
+ :insert-before (widget-get widget :widget)))
+
+;;; The `delete-button' Widget.
+
+(define-widget 'delete-button 'push
+ "A delete button for the `repeat' widget."
+ :tag "DEL"
+ :action 'widget-delete-button-action)
+
+(defun widget-delete-button-action (widget &optional event)
+ ;; Ask the parent to insert a new item.
+ (widget-apply (widget-get widget :parent)
+ :delete-at (widget-get widget :widget)))
+
+;;; The `repeat' Widget.
+
+(define-widget 'repeat 'default
+ "A variable list of widgets of the same type."
+ :convert-widget 'widget-choice-convert-widget
+ :format "%v%i\n"
+ :format-handler 'widget-repeat-format-handler
+ :entry-format "%i %d %v"
+ :menu-tag "repeat"
+ :value-create 'widget-repeat-value-create
+ :value-delete 'widget-radio-value-delete
+ :value-get 'widget-repeat-value-get
+ :validate 'widget-repeat-validate
+ :match 'widget-repeat-match
+ :match-inline 'widget-repeat-match-inline
+ :insert-before 'widget-repeat-insert-before
+ :delete-at 'widget-repeat-delete-at)
+
+(defun widget-repeat-format-handler (widget escape)
+ ;; We recognize the insert button.
+ (cond ((eq escape ?i)
+ (insert " ")
+ (backward-char 1)
+ (let* ((from (point))
+ (button (widget-create (list 'insert-button
+ :parent widget))))
+ (widget-specify-button button from (point)))
+ (forward-char 1))
+ (t
+ (widget-default-format-handler widget escape))))
+
+(defun widget-repeat-value-create (widget)
+ ;; Insert all values
+ (let* ((value (widget-get widget :value))
+ (type (nth 0 (widget-get widget :args)))
+ (inlinep (widget-get type :inline))
+ children)
+ (widget-put widget :value-pos (copy-marker (point)))
+ (set-marker-insertion-type (widget-get widget :value-pos) t)
+ (while value
+ (let ((answer (widget-match-inline type value)))
+ (if answer
+ (setq children (cons (widget-repeat-entry-create
+ widget (if inlinep
+ (car answer)
+ (car (car answer))))
+ children)
+ value (cdr answer))
+ (setq value nil))))
+ (widget-put widget :children (nreverse children))))
+
+(defun widget-repeat-value-get (widget)
+ ;; Get value of the child widget.
+ (apply 'append (mapcar (lambda (child) (widget-apply child :value-inline))
+ (widget-get widget :children))))
+
+(defun widget-repeat-validate (widget)
+ ;; All the chilren must be valid.
+ (let ((children (widget-get widget :children))
+ child found)
+ (while (and children (not found))
+ (setq child (car children)
+ children (cdr children)
+ found (widget-apply child :validate)))
+ found))
+
+(defun widget-repeat-match (widget value)
+ ;; Value must be a list and all the members must match the repeat type.
+ (and (listp value)
+ (null (cdr (widget-repeat-match-inline widget value)))))
+
+(defun widget-repeat-match-inline (widget value)
+ (let ((type (nth 0 (widget-get widget :args)))
+ (ok t)
+ found)
+ (while (and value ok)
+ (let ((answer (widget-match-inline type value)))
+ (if answer
+ (setq found (append found (car answer))
+ value (cdr answer))
+ (setq ok nil))))
+ (cons found value)))
+
+(defun widget-repeat-insert-before (widget before)
+ ;; Insert a new child in the list of children.
+ (save-excursion
+ (let ((children (widget-get widget :children))
+ (inhibit-read-only t)
+ after-change-functions)
+ (cond (before
+ (goto-char (widget-get before :entry-from)))
+ (t
+ (goto-char (widget-get widget :value-pos))))
+ (let ((child (widget-repeat-entry-create
+ widget (widget-get (nth 0 (widget-get widget :args))
+ :value))))
+ (widget-specify-text (widget-get child :entry-from)
+ (widget-get child :entry-to))
+ (if (eq (car children) before)
+ (widget-put widget :children (cons child children))
+ (while (not (eq (car (cdr children)) before))
+ (setq children (cdr children)))
+ (setcdr children (cons child (cdr children)))))))
+ (widget-setup)
+ (widget-apply widget :notify widget))
+
+(defun widget-repeat-delete-at (widget child)
+ ;; Delete child from list of children.
+ (save-excursion
+ (let ((buttons (copy-list (widget-get widget :buttons)))
+ button
+ (inhibit-read-only t)
+ after-change-functions)
+ (while buttons
+ (setq button (car buttons)
+ buttons (cdr buttons))
+ (when (eq (widget-get button :widget) child)
+ (widget-put widget
+ :buttons (delq button (widget-get widget :buttons)))
+ (widget-delete button))))
+ (let ((entry-from (widget-get child :entry-from))
+ (entry-to (widget-get child :entry-to))
+ (inhibit-read-only t)
+ after-change-functions)
+ (widget-delete child)
+ (delete-region entry-from entry-to)
+ (set-marker entry-from nil)
+ (set-marker entry-to nil))
+ (widget-put widget :children (delq child (widget-get widget :children))))
+ (widget-setup)
+ (widget-apply widget :notify widget))
+
+(defun widget-repeat-entry-create (widget value)
+ ;; Create a new entry to the list.
+ (let ((type (nth 0 (widget-get widget :args)))
+ (indent (widget-get widget :indent))
+ child delete insert)
+ (widget-specify-insert
+ (save-excursion
+ (insert (widget-get widget :entry-format))
+ (if indent
+ (insert-char ?\ indent)))
+ ;; Parse % escapes in format.
+ (while (re-search-forward "%\\(.\\)" nil t)
+ (let ((escape (aref (match-string 1) 0)))
+ (replace-match "" t t)
+ (cond ((eq escape ?%)
+ (insert "%"))
+ ((eq escape ?i)
+ (setq insert (widget-create 'insert-button
+ :parent widget)))
+ ((eq escape ?d)
+ (setq delete (widget-create 'delete-button
+ :parent widget)))
+ ((eq escape ?v)
+ (setq child (widget-create type
+ :parent widget
+ :value value)))
+ (t
+ (error "Unknown escape `%c'" escape)))))
+ (widget-put widget
+ :buttons (cons delete
+ (cons insert
+ (widget-get widget :buttons))))
+ (let ((entry-from (copy-marker (point-min)))
+ (entry-to (copy-marker (point-max))))
+ (widget-specify-text entry-from entry-to)
+ (set-marker-insertion-type entry-from t)
+ (set-marker-insertion-type entry-to nil)
+ (widget-put child :entry-from entry-from)
+ (widget-put child :entry-to entry-to)))
+ (widget-put insert :widget child)
+ (widget-put delete :widget child)
+ child))
+
+;;; The `group' Widget.
+
+(define-widget 'group 'default
+ "A widget which group other widgets inside."
+ :convert-widget 'widget-choice-convert-widget
+ :format "%v"
+ :value-create 'widget-group-value-create
+ :value-delete 'widget-radio-value-delete
+ :value-get 'widget-repeat-value-get
+ :validate 'widget-repeat-validate
+ :match 'widget-group-match
+ :match-inline 'widget-group-match-inline)
+
+(defun widget-group-value-create (widget)
+ ;; Create each component.
+ (let ((args (widget-get widget :args))
+ (value (widget-get widget :value))
+ (indent (widget-get widget :indent))
+ arg answer children)
+ (while args
+ (setq arg (car args)
+ args (cdr args)
+ answer (widget-match-inline arg value)
+ value (cdr answer)
+ children (cons (cond ((null answer)
+ (widget-create arg :parent widget))
+ ((widget-get arg :inline)
+ (widget-create arg
+ :parent widget
+ :value (car answer)))
+ (t
+ (widget-create arg
+ :parent widget
+ :value (car (car answer)))))
+ children))
+ (and args indent (insert-char ?\ indent)))
+ (widget-put widget :children (nreverse children))))
+
+(defun widget-group-match (widget values)
+ ;; Match if the components match.
+ (and (listp values)
+ (let ((match (widget-group-match-inline widget values)))
+ (and match (null (cdr match))))))
+
+(defun widget-group-match-inline (widget vals)
+ ;; Match if the components match.
+ (let ((args (widget-get widget :args))
+ argument answer found)
+ (while args
+ (setq argument (car args)
+ args (cdr args)
+ answer (widget-match-inline argument vals))
+ (if answer
+ (setq vals (cdr answer)
+ found (append found (car answer)))
+ (setq vals nil
+ args nil)))
+ (if answer
+ (cons found vals)
+ nil)))
+
+;;; The Sexp Widgets.
+
+(define-widget 'const 'item
+ "An immutable sexp."
+ :format "%t\n")
+
+(define-widget 'string 'field
+ "A string")
+
+(define-widget 'file 'string
+ "A file widget.
+It will read a file name from the minibuffer when activated."
+ :format "%[%t%]: %v"
+ :tag "File"
+ :action 'widget-file-action)
+
+(defun widget-file-action (widget &optional event)
+ ;; Read a file name from the minibuffer.
+ (let* ((value (widget-value widget))
+ (dir (file-name-directory value))
+ (file (file-name-nondirectory value))
+ (menu-tag (widget-apply widget :menu-tag-get))
+ (must-match (widget-get widget :must-match))
+ (answer (read-file-name (concat menu-tag ": (defalt `" value "') ")
+ dir nil must-match file)))
+ (widget-value-set widget (abbreviate-file-name answer))
+ (widget-setup)))
+
+(define-widget 'directory 'file
+ "A directory widget.
+It will read a directory name from the minibuffer when activated."
+ :tag "Directory")
+
+(define-widget 'symbol 'string
+ "A lisp symbol."
+ :value nil
+ :match (lambda (widget value) (symbolp value))
+ :value-to-internal (lambda (widget value) (symbol-name value))
+ :value-to-external (lambda (widget value) (intern value)))
+
+(define-widget 'sexp 'string
+ "An arbitrary lisp expression."
+ :value nil
+ :validate 'widget-sexp-validate
+ :match (lambda (widget value) t)
+ :value-to-internal (lambda (widget value) (pp-to-string value))
+ :value-to-external (lambda (widget value) (read value)))
+
+(defun widget-sexp-validate (widget)
+ ;; Valid if we can read the string and there is no junk left after it.
+ (save-excursion
+ (set-buffer (get-buffer-create " *Widget Scratch*"))
+ (erase-buffer)
+ (insert (widget-apply widget :value-get))
+ (goto-char (point-min))
+ (condition-case data
+ (let ((value (read (current-buffer))))
+ (if (eobp)
+ (if (widget-apply widget :match value)
+ t
+ (widget-put widget :error (widget-get widget :type-error))
+ nil)
+ (widget-put widget
+ :error (format "Junk at end of expression: %s"
+ (buffer-substring (point) (point-max))))
+ nil))
+ (error (widget-put widget :error (error-message-string data))
+ nil))))
+
+(define-widget 'integer 'sexp
+ "An integer."
+ :value 0
+ :type-error "This field should contain an integer"
+ :match (lambda (widget value) (integerp value)))
+
+(define-widget 'number 'sexp
+ "A floating point number."
+ :value 0.0
+ :type-error "This field should contain a number"
+ :match (lambda (widget value) (numberp value)))
+
+(define-widget 'list 'group
+ "A lisp list.")
+
+(define-widget 'vector 'group
+ "A lisp vector."
+ :match 'widget-vector-match
+ :value-to-internal (lambda (widget value) (append value nil))
+ :value-to-external (lambda (widget value) (apply 'vector value)))
+
+(defun widget-vector-match (widget value)
+ (and (vectorp value)
+ (widget-group-match widget
+ (widget-apply :value-to-internal widget value))))
+
+(define-widget 'cons 'group
+ "A cons-cell."
+ :match 'widget-cons-match
+ :value-to-internal (lambda (widget value)
+ (list (car value) (cdr value)))
+ :value-to-external (lambda (widget value)
+ (cons (nth 0 value) (nth 1 value))))
+
+(defun widget-cons-match (widget value)
+ (and (consp value)
+ (widget-group-match widget
+ (widget-apply :value-to-internal widget value))))
+
+;;; The `color' Widget.
+
+(define-widget 'color-item 'choice-item
+ "A color name (with sample)."
+ :format "%v (%[sample%])\n"
+ :button-face-get 'widget-color-item-button-face-get)
+
+(defun widget-color-item-button-face-get (widget)
+ ;; We create a face from the value.
+ (require 'facemenu)
+ (condition-case nil
+ (facemenu-get-face (intern (concat "fg:" (widget-value widget))))
+ (error 'default)))
+
+(define-widget 'color 'push
+ "Choose a color name (with sample)."
+ :format "%[%t%]: %v"
+ :value "default"
+ :value-create 'widget-color-value-create
+ :value-delete 'widget-radio-value-delete
+ :value-get 'widget-color-value-get
+ :value-set 'widget-color-value-set
+ :action 'widget-color-action
+ :match 'widget-field-match
+ :tag "Color")
+
+(defvar widget-color-choice-list nil)
+;; Variable holding the possible colors.
+
+(defun widget-color-choice-list ()
+ (unless widget-color-choice-list
+ (setq widget-color-choice-list
+ (mapcar '(lambda (color) (list color))
+ (x-defined-colors))))
+ widget-color-choice-list)
+
+(defun widget-color-value-create (widget)
+ (let ((child (widget-create 'color-item
+ :parent widget
+ (widget-get widget :value))))
+ (widget-put widget :children (list child))))
+
+(defun widget-color-value-get (widget)
+ ;; Pass command to first child.
+ (widget-apply (car (widget-get widget :children)) :value-get))
+
+(defun widget-color-value-set (widget value)
+ ;; Pass command to first child.
+ (widget-apply (car (widget-get widget :children)) :value-set value))
+
+(defvar widget-color-history nil
+ "History of entered colors")
+
+(defun widget-color-action (widget &optional event)
+ ;; Prompt for a color.
+ (let* ((tag (widget-apply widget :menu-tag-get))
+ (prompt (concat tag ": "))
+ (answer (cond ((string-match "XEmacs" emacs-version)
+ (read-color prompt))
+ ((fboundp 'x-defined-colors)
+ (completing-read (concat tag ": ")
+ (widget-color-choice-list)
+ nil nil nil 'widget-color-history))
+ (t
+ (read-string prompt (widget-value widget))))))
+ (unless (zerop (length answer))
+ (widget-value-set widget answer))))
+
+;;; The End:
+
+(provide 'widget-edit)
+
+;; widget-edit.el ends here
--- /dev/null
+;;; widget-example.el -- example of using the widget library
+
+;; Copyright (C) 1996 Free Software Foundation, Inc.
+;;
+;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
+;; Keywords: help, extensions, faces, hypermedia
+;; Version: 0.9
+;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
+
+(require 'widget)
+
+(eval-when-compile
+ (require 'widget-edit))
+
+(defvar widget-example-repeat)
+
+(defun widget-example ()
+ "Create the widgets from the Widget manual."
+ (interactive)
+ (switch-to-buffer "*Widget Example*")
+ (kill-all-local-variables)
+ (make-local-variable 'widget-example-repeat)
+ (let ((inhibit-read-only t))
+ (erase-buffer))
+ (widget-insert "Here is some documentation.\n\nName: ")
+ (widget-create 'field
+ :size 13
+ "My Name")
+ (widget-create 'choice
+ :tag "Choose"
+ :value "This"
+ :help-echo "Choose me, please!"
+ :notify (lambda (widget &rest ignore)
+ (message "%s is a good choice!"
+ (widget-value widget)))
+ '(item :tag "This option" :value "This")
+ '(choice-item "That option")
+ '(field :menu-tag "No option" "Thus option"))
+ (widget-insert "Address: ")
+ (widget-create 'field
+ "Some Place\nIn some City\nSome country.")
+ (widget-insert "\nSee also ")
+ (widget-create 'link
+ :notify (lambda (&rest ignore)
+ (widget-value-set widget-example-repeat
+ '("En" "To" "Tre"))
+ (widget-setup))
+ "other work")
+ (widget-insert " for more information.\n\nNumbers: count to three below\n")
+ (setq widget-example-repeat
+ (widget-create 'repeat
+ :entry-format "%i %d %v"
+ :notify (lambda (widget &rest ignore)
+ (let ((old (widget-get widget
+ ':example-length))
+ (new (length (widget-value widget))))
+ (unless (eq old new)
+ (widget-put widget ':example-length new)
+ (message "You can count to %d." new))))
+ :value '("One" "Eh, two?" "Five!")
+ '(field :value "three")))
+ (widget-insert "\n\nSelect multiple:\n\n")
+ (widget-create 'checkbox t)
+ (widget-insert " This\n")
+ (widget-create 'checkbox nil)
+ (widget-insert " That\n")
+ (widget-create 'checkbox
+ :notify (lambda (&rest ignore) (message "Tickle"))
+ t)
+ (widget-insert " Thus\n\nSelect one:\n\n")
+ (widget-create 'radio
+ :value "One"
+ :notify (lambda (widget &rest ignore)
+ (message "You selected %s"
+ (widget-value widget)))
+ '(item "One") '(item "Anthor One.") '(item "A Final One."))
+ (widget-insert "\n")
+ (widget-create 'push
+ :notify (lambda (&rest ignore)
+ (if (= (length (widget-value widget-example-repeat))
+ 3)
+ (message "Congratulation!")
+ (error "Three was the count!")))
+ "Apply Form")
+ (widget-insert " ")
+ (widget-create 'push
+ :notify (lambda (&rest ignore)
+ (widget-example))
+ "Reset Form")
+ (widget-insert "\n")
+ (use-local-map widget-keymap)
+ (widget-setup))
--- /dev/null
+;;; widget.el --- a library of user interface components.
+;;
+;; Copyright (C) 1996 Free Software Foundation, Inc.
+;;
+;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
+;; Keywords: help, extensions, faces, hypermedia
+;; Version: 0.9
+;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
+
+;;; Commentary:
+;;
+;; If you want to use this code, please visit the URL above.
+;;
+;; This file only contain the code needed to define new widget types.
+;; Everything else is autoloaded from `widget-edit.el'.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(let ((keywords
+ '(:create :convert-widget :format :value-create :tag :doc :from :to
+ :args :value :value-from :value-to :action :value-set
+ :value-delete :match :parent :delete :menu-tag-get
+ :value-get :choice :void :menu-tag :on :off :on-type
+ :off-type :notify :entry-format :button :children
+ :buttons :insert-before :delete-at :format-handler
+ :widget :value-pos :value-to-internal :indent :size
+ :value-to-external :validate :error :directory :must-match
+ :type-error :value-inline :inline :match-inline
+ :greedy :button-face-get :button-face :value-face :keymap
+ :entry-from :entry-to :help-echo)))
+ (while keywords
+ (or (boundp (car keywords))
+ (set (car keywords) (car keywords)))
+ (setq keywords (cdr keywords))))
+
+;; These autoloads should be deleted when the file is added to Emacs.
+(autoload 'widget-create "widget-edit")
+(autoload 'widget-insert "widget-edit")
+
+;;;###autoload
+(defun define-widget (name class doc &rest args)
+ "Define a new widget type named NAME from CLASS.
+
+NAME and CLASS should both be symbols, CLASS should be one of the
+existing widget types, or nil to create the widget from scratch.
+
+After the new widget has been defined, the following two calls will
+create identical widgets:
+
+* (widget-create NAME)
+
+* (apply 'widget-create CLASS ARGS)
+
+The third argument DOC is a documentation string for the widget."
+ (put name 'widget-type (cons class args))
+ (put name 'widget-documentation doc))
+
+;;; The End.
+
+(provide 'widget)
+
+;; widget.el ends here
--- /dev/null
+\input texinfo.tex
+
+@c %**start of header
+@setfilename custom.info
+@settitle The Customization Library
+@iftex
+@afourpaper
+@headings double
+@end iftex
+@c %**end of header
+
+@node Top, Introduction, (dir), (dir)
+@comment node-name, next, previous, up
+@top The Customization Library
+
+Version: 0.9
+
+@menu
+* Introduction::
+* User Commands::
+* The Customization Buffer::
+* Declaring Groups::
+* Declaring Variables::
+* Declaring Faces::
+* The Init File::
+* Wishlist::
+@end menu
+
+@node Introduction, User Commands, Top, Top
+@comment node-name, next, previous, up
+@section Introduction
+
+This library allows customization of @dfn{user options}. Currently two
+types of user options are supported, namely @dfn{variables} and
+@dfn{faces}. Each user option can have four different values
+simultaneously:
+@table @dfn
+@item factory setting
+The value specified by the programmer.
+@item default value
+The value specified by the user as the default for this variable. This
+overwrites the factory setting when starting a new emacs.
+@item current value
+The value used by Emacs. This will not be remembered next time you
+run Emacs.
+@item widget value
+The value entered by the user in a customization buffer, but not yet
+applied.
+@end table
+
+Variables also have a @dfn{type}, which specifies what kind of values
+the variable can hold, and how the value is presented in a customization
+buffer. By default a variable can hold any valid expression, but the
+programmer can specify a more limited type when declaring the variable.
+
+The user options are organized in a number of @dfn{groups}. Each group
+can contain a number user options, as well as other groups. The groups
+allows the user to concentrate on a specific part of emacs.
+
+@node User Commands, The Customization Buffer, Introduction, Top
+@comment node-name, next, previous, up
+@section User Commands
+
+The following commands will create a customization buffer:
+
+@table @code
+@item customize
+Create a customization buffer containing a specific group, by default
+the @code{emacs} group.
+
+@item customize-variable
+Create a customization buffer containing a single variable.
+
+@item customize-face
+Create a customization buffer contaning a single face.
+
+@item customize-apropos
+Create a customization buffer containing all variables, faces, and
+groups that match a user specified regular expression.
+@end table
+
+@node The Customization Buffer, Declaring Groups, User Commands, Top
+@comment node-name, next, previous, up
+@section The Customization Buffer.
+
+Here should be a description of how to use a customization buffer.
+For now, try to press @kbd{C-h m} in the buffer, or read @ref{User
+Interface,,widget,The Widget Library}.
+
+The interface will change, as it currently stinks. Here is some hints
+about how to use it though:
+
+@itemize @bullet
+@item
+Groups and user option start on a new line, and look like this
+@t{@b{name}:}. If you move point above to the @t{@b{name}} and press
+@kbd{@key{RET}}, or move the mouse pointer above it and press
+@kbd{mouse-2}, you will be presented with a menu. I call this the
+@dfn{tag menu} below.
+
+@item
+For groups and faces, you need to activate @samp{Toggle Hide} from the
+tag menu to be able to see the content.
+
+@item
+After editing a variable or face, you must activate @samp{Apply} for the
+setting to take effect, and @samp{Set Default} for marking the widget
+value as the new default value.
+
+@item
+After setting new default values with @samp{Set Default}, you must
+activate the @samp{Save} button in the bottom of the screen to save the
+new defaults. Otherwise the new defaults will be silently forgotten.
+
+@item
+Pushing @samp{Save} is a no-op unless you have activated @samp{Set Default}
+for some user option.
+
+@item
+The @code{face} widget never attempts to display the current value of a
+face. Instead it allows you to specify how the face should be
+initialized. This is done with a list of @dfn{display} and
+@dfn{attributes} pairs, where the first display that matches a frame
+specify the attributes to use for that frame.
+
+A display can either match all frames, or only frames with a given
+@dfn{type}, @dfn{class}, and @dfn{background}. The checkbox before each
+of these display parameters determine whether the parameter will be
+checked. If the checkbox before @samp{Type} is unchecked, the display
+will match all types of frames. If it is checked, it will match the
+type of frames specified on the rest of the line.
+
+The attributes are specified next. Each attribute line begins with a
+checkbox, if that checkbox is unchecked the face will not affect that
+particular attribute on the screen, otherwise the face will force the
+the text to have the value for attribute specified after the attrbute
+name. This means that an attribute like @samp{bold} in effect have
+three states: If the first checkmark is unchecked, the face will not
+affect the boldness of the text. If the first checkmark is checked, but
+the second is unchecked, the text will be forced to be unbold. If both
+checkmarks are checked, the text will be forced to be bold.
+
+Think about this, and mail me a suggestion for how to make the face
+widget more intuitive.
+@end itemize
+
+@node Declaring Groups, Declaring Variables, The Customization Buffer, Top
+@comment node-name, next, previous, up
+@section Declaring Groups
+
+Use @code{defgroup} to declare new customization groups.
+
+@defun defgroup symbol members [keyword value]... doc
+Declare @var{symbol} as a customization group containing @var{members}.
+@var{symbol} does not need to be quoted.
+
+@var{members} should be an alist of the form ((@var{name}
+@var{widget})...) where @var{name} is a symbol and @var{widget} is a
+widget for editing that symbol. Useful widgets are
+@code{custom-variable} for editing variables, @code{custom-face} for
+editing faces, and @code{custom-group} for editing groups.@refill
+
+@var{doc} is the group documentation.
+
+The following @var{keyword}'s are defined:
+
+@table @code
+@item :group
+@var{value} should be a customization group.
+Add @var{symbol} to that group.
+@end table
+@end defun
+
+Internally, custom uses the symbol property @code{custom-group} to keep
+track of the group members, and @code{group-documentation} for the
+documentation string.
+
+@node Declaring Variables, Declaring Faces, Declaring Groups, Top
+@comment node-name, next, previous, up
+@section Declaring Variables
+
+Use @code{defcustom} to declare user editable variables.
+
+@defun defcustom symbol [keyword value]... doc
+Declare @var{symbol} as a customizable variable that defaults to @var{value}.
+Neither @var{symbol} nor @var{value} needs to be quoted.
+If @var{symbol} is not already bound, initialize it to @var{value}.
+
+@var{doc} is the variable documentation.
+
+The following @var{keyword}'s are defined:
+
+@table @code
+@item :type
+@var{value} should be a sexp widget.
+@item :group
+@var{value} should be a customization group.
+Add @var{symbol} to that group.
+@end table
+
+@xref{Sexp Types,,widget,The Widget Library}, for information about
+widgets to use together with the @code{:type} keyword.
+@end defun
+
+Internally, custom uses the symbol property @code{custom-type} to keep
+track of the variables type, @code{factory-value} for the program
+specified default value, @code{default-value} for a user specified
+default value, and @code{variable-documentation} for the documentation
+string.
+
+
+@node Declaring Faces, The Init File, Declaring Variables, Top
+@comment node-name, next, previous, up
+@section Declaring Faces
+
+Faces are declared with @code{defface}.
+
+@defun defface FACE SPEC [KEYWORD VALUE]... DOC
+
+Declare @var{face} as a customizable face that defaults to @var{spec}.
+@var{face} does not need to be quoted.
+
+If @var{face} has been set with `custom-set-face', set the face attributes
+as specified by that function, otherwise set the face attributes
+according to @var{spec}.
+
+@var{doc} is the face documentation.
+
+The following @var{keyword}'s are defined:
+
+@table @code
+@item :group
+@var{value} should be a customization group.
+Add @var{symbol} to that group.
+@end table
+
+@var{spec} should be an alist of the form @samp{((@var{display} @var{atts})...)}.
+
+@var{atts} is a list of face attributes and their values. The possible
+attributes are defined in the variable `custom-face-attributes'.
+Alternatively, @var{atts} can be a face in which case the attributes of
+that face is used.
+
+The @var{atts} of the first entry in @var{spec} where the @var{display}
+matches the frame should take effect in that frame. @var{display} can
+either be the symbol `t', which will match all frames, or an alist of
+the form @samp{((@var{req} @var{item}...)...)}@refill
+
+For the @var{display} to match a FRAME, the @var{req} property of the
+frame must match one of the @var{item}. The following @var{req} are
+defined:@refill
+
+@table @code
+@item type
+(the value of (window-system))@br
+Should be one of @code{x} or @code{tty}.
+
+@item class
+(the frame's color support)@br
+Should be one of @code{color}, @code{grayscale}, or @code{mono}.
+
+@item background
+(what color is used for the background text)@br
+Should be one of @code{light} or @code{dark}.
+@end table
+
+Internally, custom uses the symbol property @code{factory-face} for the
+program specified default face properties, @code{default-face} for a
+user specified default properties, and @code{face-documentation} for the
+documentation string.@refill
+
+@end defun
+
+@node The Init File, Wishlist, Declaring Faces, Top
+@comment node-name, next, previous, up
+@section The Init File
+
+When you save the customizations, call to @code{custom-set-variables},
+@code{custom-set-faces} are inserted into the file specified by
+@code{custom-file}. By default @code{custom-file} is your @file{.emacs}
+file. The two functions will initialize variables and faces as you have
+specified.
+
+@node Wishlist, , The Init File, Top
+@comment node-name, next, previous, up
+@section Wishlist
+
+@itemize @bullet
+@item
+The names of the menu items for the @code{custom-variable},
+@code{custom-face}, and @code{custom-group} tags should be rethought.
+Some of the actions may be better placed as buttons in the buffer.
+
+@item
+The menu items above should be grayed out when the information is
+missing. I.e. if a variable doesn't have a factory setting, the user
+should not be allowed to select the @samp{Factory} menu item.
+
+@item
+We need @strong{much} better support for keyboard operations in the
+customize buffer.
+
+@item
+There should be buttons that will apply, set, reset, etc. all the relevant
+widgets in a customize buffer.
+
+@item
+There should be a menu in the customize buffer.
+
+@item
+The group widget should allow you to apply, set, reset, etc. all the
+relevant members of the group.
+
+@item
+There should be a function to create a customize menu from a group.
+
+@item
+There should be a `Help | Customize' entry in the menu bar with a user
+specified number of levels of submenus.
+
+@item
+It would be nice if one could set simple variables directly from the
+menu.
+
+@item
+Support real specifiers under XEmacs.
+
+@item
+@code{customize-apropos} should only match user options that has either
+been declared with this library, or variables whose documentation start
+with @samp{*}. With an prefix argument, also match all variables that
+has a documentation string.
+
+@item
+If there is only one line of documentation, the @samp{Documentation}
+tag-menu items should go from `first line only' to `none' without going
+over `full'. I.e. it should have two states instead of three.
+
+@item
+@code{custom-face} should display the @code{face-documentation}
+property.
+
+@item
+@code{custom-face}, @code{custom-variable}, and @code{custom-group}
+should be derived from a common @code{custom} widget.
+
+@item
+Integrate with @file{w3} so you can customization buffers with much
+better formatting. I'm thinking about adding a <custom>name</custom>
+tag.
+
+@end itemize
+
+@contents
+@bye
--- /dev/null
+\input texinfo.tex
+
+@c $Id: widget.texi,v 1.1 1996/09/22 12:07:55 steve Exp $
+
+@c %**start of header
+@setfilename widget.info
+@settitle The Emacs Widget Library
+@iftex
+@afourpaper
+@headings double
+@end iftex
+@c %**end of header
+
+@node Top, Introduction, (dir), (dir)
+@comment node-name, next, previous, up
+@top The Emacs Widget Library
+
+Version: 0.9
+
+@menu
+* Introduction::
+* User Interface::
+* Programming Example::
+* Setting Up the Buffer::
+* Basic Types::
+* Sexp Types::
+* Widget Properties::
+* Defining New Widgets::
+* Widget Wishlist.::
+@end menu
+
+@node Introduction, User Interface, Top, Top
+@comment node-name, next, previous, up
+@section Introduction
+
+Most graphical user interface toolkits, such as Motif and XView, provide
+a number of standard user interface controls (sometimes known as
+`widgets' or `gadgets'). Emacs doesn't really support anything like
+this, except for an incredible powerful text ``widget''. On the other
+hand, Emacs does provide the necessary primitives to implement many
+other widgets within a text buffer. The @code{widget} package
+simplifies this task.
+
+The basic widgets are:
+
+@table @code
+@item link
+Areas of text with an associated action. Intended for hypertext links
+embedded in text.
+@item push
+Like link, but intended for stand-alone buttons.
+@item field
+An editable text field. It can be either variable or fixed length.
+@item choice
+Allows the user to choose one of multiple options from a menu, each
+option is itself a widget. Only the selected option will be visible in
+the buffer.
+@item radio
+Allows the user to choose one of multiple options by pushing radio
+buttons. The options are implemented as widgets. All options will be
+visible in the buffer.
+@item item
+A simple constant widget intended to be used in the @code{choice} and
+@code{radio} widgets.
+@item choice-item
+An button item only intended for use in choices. When pushed, the user
+will be asked to select another option from the choice widget.
+@item toggle
+A simple @samp{on}/@samp{off} switch.
+@item checkbox
+A checkbox (@samp{[ ]}/@samp{[X]}).
+@item repeat
+Create an editable list. The user can insert or delete items in the
+list. Each list item is itself a widget.
+@end table
+
+Now of what possible use can support for widgets be in a text editor?
+I'm glad you asked. The answer is that widgets are useful for
+implementing forms. A @dfn{form} in emacs is a buffer where the user is
+supposed to fill out a number of fields, each of which has a specific
+meaning. The user is not supposed to change or delete any of the text
+between the fields. Examples of forms in Emacs are the @file{forms}
+package (of course), the customize buffers, the mail and news compose
+modes, and the @sc{html} form support in the @file{w3} browser.
+
+The advantages for a programmer of using the @code{widget} package to
+implement forms are:
+
+@enumerate
+@item
+More complex field than just editable text are supported.
+@item
+You can give the user immediate feedback if he enters invalid data in a
+text field, and sometimes prevent entering invalid data.
+@item
+You can have fixed sized fields, thus allowing multiple field to be
+lined up in columns.
+@item
+It is simple to query or set the value of a field.
+@item
+Editing happens in buffer, not in the mini-buffer.
+@item
+Packages using the library get a uniform look, making them easier for
+the user to learn.
+@item
+As support for embedded graphics improve, the widget library will
+extended to support it. This means that your code using the widget
+library will also use the new graphic features by automatic.
+@end enumerate
+
+In order to minimize the code that is loaded by users who does not
+create any widgets, the code has been split in two files:
+
+@table @file
+@item widget.el
+This will declare the user variables, define the function
+@code{widget-define}, and autoload the function @code{widget-create}.
+@item widget-edit.el
+Everything else is here, there is no reason to load it explicitly, as
+it will be autoloaded when needed.
+@end table
+
+@node User Interface, Programming Example, Introduction, Top
+@comment node-name, next, previous, up
+@section User Interface
+
+A form consist of read only text for documentation and some fields,
+where each the fields contain two parts, as tag and a value. The tags
+are used to identify the fields, so the documentation can refer to the
+foo field, meaning the field tagged with @samp{Foo}. Here is an example
+form:
+
+@example
+Here is some documentation.
+
+Name: @i{My Name} @strong{Choose}: This option
+Address: @i{Some Place
+In some City
+Some country.}
+
+See also @b{_other work_} for more information.
+
+Numbers: count to three below
+@b{[INS]} @b{[DEL]} @i{One}
+@b{[INS]} @b{[DEL]} @i{Eh, two?}
+@b{[INS]} @b{[DEL]} @i{Five!}
+@b{[INS]}
+
+Select multiple:
+
+@b{[X]} This
+@b{[ ]} That
+@b{[X]} Thus
+
+Select one:
+
+@b{(*)} One
+@b{( )} Another One.
+@b{( )} A Final One.
+
+@b{[Apply Form]} @b{[Reset Form]}
+@end example
+
+The top level widgets in is example are tagged @samp{Name},
+@samp{Choose}, @samp{Address}, @samp{_other work_}, @samp{Numbers},
+@samp{Select multiple}, @samp{Select one}, @samp{[Apply Form]}, and
+@samp{[Reset Form]}. There are basically two thing the user can do within
+a form, namely editing the editable text fields and activating the
+buttons.
+
+@subsection Editable Text Fields
+
+In the example, the value for the @samp{Name} is most likely displayed
+in an editable text field, and so are values for each of the members of
+the @samp{Numbers} list. All the normal Emacs editing operations are
+available for editing these fields. The only restriction is that each
+change you make must be contained within a single editable text field.
+For example, capitalizing all text from the middle of one field to the
+middle of another field is prohibited.
+
+Editing text fields are created by the @code{field} widget.
+
+The editing text fields are highlighted with the
+@code{widget-field-face} face, making them easy to find.
+
+@defopt widget-field-face
+Face used for other editing fields.
+@end defopt
+
+@subsection Buttons
+
+Some portions of the buffer have an associated @dfn{action}, which can
+be @dfn{activated} by a standard key or mouse command. These portions
+are called @dfn{buttons}. The default commands for activating a button
+are:
+
+@table @kbd
+@item @key{RET}
+@deffn Command widget-button-press @var{pos} &optional @var{event}
+Activate the button at @var{pos}, defaulting to point.
+If point is not located on a button, activate the binding in
+@code{widget-global-map} (by default the global map).
+@end deffn
+
+@item mouse-2
+@deffn Command widget-button-click @var{event}
+Activate the button at the location of the mouse pointer. If the mouse
+pointer is located in an editable text field, activate the binding in
+@code{widget-global-map} (by default the global map).
+@end deffn
+@end table
+
+There are several different kind of buttons, all of which are present in
+the example:
+
+@table @emph
+@item The Option Field Tags.
+When you activate one of these buttons, you will be asked to choose
+between a number of different options. This is how you edit an option
+field. Option fields are created by the @code{choice} widget. In
+the example, @samp{@b{Choose}} is an option field tag.
+@item The @samp{@b{[INS]}} and @samp{@b{[DEL]}} buttons.
+Activating these will insert or delete elements from a editable list.
+The list is created by the @code{repeat} widget.
+@item Embedded Buttons.
+The @samp{@b{_other work_}} is an example of an embedded
+button. Embedded buttons are not associated with a fields, but can serve
+any purpose, such as implementing hypertext references. They are
+usually created by the @code{link} widget.
+@item The @samp{@b{[ ]}} and @samp{@b{[X]}} buttons.
+Activating one of these will convert it to the other. This is useful
+for implementing multiple-choice fields. You can create it wit
+@item The @samp{@b{( )}} and @samp{@b{(*)}} buttons.
+Only one radio button in a @code{radio} widget can be selected at any
+time. When you push one of the unselected radio buttons, it will be
+selected and the previous selected radio button will become unselected.
+@item The @samp{@b{[Apply Form]}} @samp{@b{[Reset Form]}} buttons.
+These are explicit buttons made with the @code{push} widget. The main
+difference from the @code{link} widget is that the buttons are intended
+to be displayed more like buttons in a GUI, once Emacs grows powerful
+enough.
+@end table
+
+To make them easier to locate, buttons are emphasized in the buffer.
+
+@defopt widget-button-face
+Face used for buttons.
+@end defopt
+
+@defopt widget-mouse-face
+Face used for buttons when the mouse pointer is above it.
+@end defopt
+
+@subsection Navigation
+
+You can use all the normal Emacs commands to move around in a form
+buffer, plus you will have these additional commands:
+
+@table @kbd
+@item @key{TAB}
+@deffn Command widget-forward &optional count
+Move point @var{count} buttons or editing fields forward.
+@end deffn
+@item @key{M-TAB}
+@deffn Command widget-backward &optional count
+Move point @var{count} buttons or editing fields backward.
+@end deffn
+@end table
+
+@node Programming Example, Setting Up the Buffer, User Interface, Top
+@comment node-name, next, previous, up
+@section Programming Example
+
+Here is the code to implement the user interface example (see @ref{User
+Interface}).
+
+@lisp
+(require 'widget)
+
+(defvar widget-example-repeat)
+
+(defun widget-example ()
+ "Create the widgets from the Widget manual."
+ (interactive)
+ (switch-to-buffer "*Widget Example*")
+ (kill-all-local-variables)
+ (make-local-variable 'widget-example-repeat)
+ (let ((inhibit-read-only t))
+ (erase-buffer))
+ (widget-insert "Here is some documentation.\n\nName: ")
+ (widget-create 'field
+ :size 13
+ "My Name")
+ (widget-create 'choice
+ :tag "Choose"
+ :value "This"
+ :help-echo "Choose me, please!"
+ :notify (lambda (widget &rest ignore)
+ (message "%s is a good choice!"
+ (widget-value widget)))
+ '(item :tag "This option" :value "This")
+ '(choice-item "That option")
+ '(field :menu-tag "No option" "Thus option"))
+ (widget-insert "Address: ")
+ (widget-create 'field
+ "Some Place\nIn some City\nSome country.")
+ (widget-insert "\nSee also ")
+ (widget-create 'link
+ :notify (lambda (&rest ignore)
+ (widget-value-set widget-example-repeat
+ '("En" "To" "Tre"))
+ (widget-setup))
+ "other work")
+ (widget-insert " for more information.\n\nNumbers: count to three below\n")
+ (setq widget-example-repeat
+ (widget-create 'repeat
+ :entry-format "%i %d %v"
+ :notify (lambda (widget &rest ignore)
+ (let ((old (widget-get widget
+ ':example-length))
+ (new (length (widget-value widget))))
+ (unless (eq old new)
+ (widget-put widget ':example-length new)
+ (message "You can count to %d." new))))
+ :value '("One" "Eh, two?" "Five!")
+ '(field :value "three")))
+ (widget-insert "\n\nSelect multiple:\n\n")
+ (widget-create 'checkbox t)
+ (widget-insert " This\n")
+ (widget-create 'checkbox nil)
+ (widget-insert " That\n")
+ (widget-create 'checkbox
+ :notify (lambda (&rest ignore) (message "Tickle"))
+ t)
+ (widget-insert " Thus\n\nSelect one:\n\n")
+ (widget-create 'radio
+ :value "One"
+ :notify (lambda (widget &rest ignore)
+ (message "You selected %s" (widget-value widget)))
+ '(item "One") '(item "Anthor One.") '(item "A Final One."))
+ (widget-insert "\n")
+ (widget-create 'push
+ :notify (lambda (&rest ignore)
+ (if (= (length (widget-value widget-example-repeat))
+ 3)
+ (message "Congratulation!")
+ (error "Three was the count!")))
+ "Apply Form")
+ (widget-insert " ")
+ (widget-create 'push
+ :notify (lambda (&rest ignore)
+ (widget-example))
+ "Reset Form")
+ (widget-insert "\n")
+ (use-local-map widget-keymap)
+ (widget-setup))
+@end lisp
+
+@node Setting Up the Buffer, Basic Types, Programming Example, Top
+@comment node-name, next, previous, up
+@section Setting Up the Buffer
+
+Widgets are created with @code{widget-create}, which returns a
+@dfn{widget} object. This object can be queried and manipulated by
+other widget functions, until it is deleted with @code{widget-delete}.
+After the widgets have been created, @code{widget-setup} must be called
+to enable them.
+
+@defun widget-create type [ keyword argument ]@dots{}
+Create and return a widget of type @var{type}.
+The syntax for the @var{type} argument is described in @ref{Basic Types}.
+
+The keyword arguments can be used to overwrite the keyword arguments
+that are part of @var{type}.
+@end defun
+
+@defun widget-delete widget
+Delete @var{widget} and remove it from the buffer.
+@end defun
+
+@defun widget-setup
+Setup a buffer to support widgets.
+
+This should be called after creating all the widgets and before allowing
+the user to edit them.
+@refill
+@end defun
+
+If you want to insert text outside the widgets in the form, the
+recommended way to do that is with @code{widget-insert}.
+
+@defun widget-insert
+Insert the arguments, either strings or characters, at point.
+The inserted text will be read only.
+@end defun
+
+There is a standard widget keymap which you might find useful.
+
+@defvr Const widget-keymap
+A keymap with the global keymap as its parent.@br
+@key{TAB} and @kbd{C-@key{TAB}} are bound to @code{widget-forward} and
+@code{widget-backward}, respectively. @kbd{@key{RET}} and @kbd{mouse-2}
+are bound to @code{widget-button-press} and
+@code{widget-button-}.@refill
+@end defvr
+
+@defvar widget-global-map
+Keymap used by @code{widget-button-press} and @code{widget-button-click}
+when not on a button. By default this is @code{global-map}.
+@end defvar
+
+@node Basic Types, Sexp Types, Setting Up the Buffer, Top
+@comment node-name, next, previous, up
+@section Basic Types
+
+The syntax of a type specification is given below:
+
+@example
+NAME ::= (NAME [KEYWORD ARGUMENT]... ARGS)
+ | NAME
+@end example
+
+Where, @var{name} is a widget name, @var{keyword} is the name of a
+property, @var{argument} is the value of the property, and @var{args}
+are interpreted in a widget specific way.
+
+There following keyword arguments that apply to all widgets:
+
+@table @code
+@item :value
+The initial value for widgets of this type.
+
+@item :format
+This string will be inserted in the buffer when you create a widget.
+The following @samp{%} escapes are available:
+
+@table @samp
+@item %[
+@itemx %]
+The text inside will be marked as a button.
+
+@item %v
+This will be replaces with the buffer representation of the widgets
+value. What this is depends on the widget type.
+
+@item %d
+Insert the string specified by @code{:doc} here.
+
+@item %t
+Insert the string specified by @code{:tag} here, or the @code{princ}
+representation of the value if there is no tag.
+
+@item %%
+Insert a literal @samp{%}.
+@end table
+
+@item :button-face
+Face used to highlight text inside %[ %] in the format.
+
+@item :doc
+The string inserted by the @samp{%d} escape in the format
+string.
+
+@item :tag
+The string inserted by the @samp{%t} escape in the format
+string.
+
+@item :help-echo
+Message displayed whenever you move to the widget with either
+@code{widget-forward} or @code{widget-backward}.
+
+@item :notify
+A function called each time the widget or a nested widget is changed.
+The function is called with two or three arguments. The first argument
+is the widget itself, the second argument is the widget that was
+changed, and the third argument is the event leading to the change, if
+any.
+
+@item :menu-tag
+Tag used in the menu when the widget is used as an option in a
+@code{choice} widget.
+
+@item :menu-tag-get
+Function used for finding the tag when the widget is used as an option
+in a @code{choice} widget. By default, the tag used will be either the
+@code{:menu-tag} or @code{:tag} property if present, or the @code{princ}
+representation of the @code{:value} property if not.
+
+@item :match
+Should be a function called with two arguments, the widget and a value,
+and returning non-nil if the widget can represent the specified value.
+
+@item :validate
+A function which takes a widget as an argument, and return nil if the
+widgets current value is valid for the widget. Otherwise, it should
+return the widget containing the invalid data, and set that widgets
+@code{:error} property to a string explaining the error.
+
+@item :parent
+The parent of a nested widget (e.g. a @code{choice} item or an element of a
+@code{repeat} widget).
+@end table
+
+@menu
+* link::
+* push::
+* field::
+* text::
+* choice::
+* radio::
+* item::
+* choice-item::
+* toggle::
+* checkbox::
+* checklist::
+* repeat::
+@end menu
+
+@node link, push, Basic Types, Basic Types
+@comment node-name, next, previous, up
+@subsection The @code{link} Widget
+
+Syntax:
+
+@example
+TYPE ::= (link [KEYWORD ARGUMENT]... [ VALUE ])
+@end example
+
+The @var{value}, if present, is used to initialize the @code{:value}
+property. The value should be a string, which will be inserted in the
+buffer.
+
+@node push, field, link, Basic Types
+@comment node-name, next, previous, up
+@subsection The @code{push} Widget
+
+Syntax:
+
+@example
+TYPE ::= (push [KEYWORD ARGUMENT]... [ VALUE ])
+@end example
+
+The @var{value}, if present, is used to initialize the @code{:value}
+property. The value should be a string, which will be inserted in the
+buffer.
+
+@node field, text, push, Basic Types
+@comment node-name, next, previous, up
+@subsection The @code{field} Widget
+
+Syntax:
+
+@example
+TYPE ::= (field [KEYWORD ARGUMENT]... [ VALUE ])
+@end example
+
+The @var{value}, if present, is used to initialize the @code{:value}
+property. The value should be a string, which will be inserted in
+field. This widget will match all string values.
+
+The following extra properties are recognized.
+
+@table @code
+@item :size
+The width of the editable field.@br
+By default the field will reach to the end of the line.
+
+@item :value-face
+Face used for highlighting the editable field. Default is
+@code{widget-field-face}.
+
+@item :keymap
+Keymap used in the editable field. @code{widget-keymap} will allow you
+to use normal editing commands, even if these has been supressed in the
+current buffer.
+
+@end table
+
+@node text, choice, field, Basic Types
+@comment node-name, next, previous, up
+@subsection The @code{text} Widget
+
+This is just like @code{field}, but intended for multiline text
+fields.
+
+@node choice, radio, text, Basic Types
+@comment node-name, next, previous, up
+@subsection The @code{choice} Widget
+
+Syntax:
+
+@example
+TYPE ::= (choice [KEYWORD ARGUMENT]... TYPE ... )
+@end example
+
+The @var{type} arguments represents each possible choice. The widgets
+value of will be the value of the chosen @var{type} argument. This
+widget will match any value that matches at least one of the specified
+@var{type} arguments.
+
+@table @code
+@item :void
+Widget type used as a fallback when the value does not match any of the
+specified @var{type} arguments.
+
+@item :children
+A list whose car is the widget representing the currently chosen type in
+the buffer.
+
+@item :choice
+The current chosen type
+
+@item :args
+The list of types.
+@end table
+
+@node radio, item, choice, Basic Types
+@comment node-name, next, previous, up
+@subsection The @code{radio} Widget
+
+Syntax:
+
+@example
+TYPE ::= (radio [KEYWORD ARGUMENT]... TYPE ... )
+@end example
+
+The @var{type} arguments represents each possible choice. The widgets
+value of will be the value of the chosen @var{type} argument. This
+widget will match any value that matches at least one of the specified
+@var{type} arguments.
+
+The following extra properties are recognized.
+
+@table @code
+@item :entry-format
+This string will be inserted for each entry in the list.
+The following @samp{%} escapes are available:
+@table @samp
+@item %v
+Replaced with the buffer representation of the @var{type} widget.
+@item %b
+Replace with the radio button.
+@item %%
+Insert a literal @samp{%}.
+@end table
+
+@item :buttons
+The widgets representing the radio buttons.
+
+@item :children
+The widgets representing each type.
+
+@item :choice
+The current chosen type
+
+@item :args
+The list of types.
+@end table
+
+You can add extra radio button items to a radio widget after it has been
+created with the function `widget-radio-add-item'.
+
+@defun widget-radio-add-item widget type
+Add to radio widget @var{widget} a new radio button item of type @var{type}.
+@end defun
+
+Please note that such items added after the radio widget has been
+created will @strong{not} be properly destructed when you call
+@code{widget-delete}.
+
+@node item, choice-item, radio, Basic Types
+@comment node-name, next, previous, up
+@subsection The @code{item} Widget
+
+Syntax:
+
+@example
+ITEM ::= (item [KEYWORD ARGUMENT]... VALUE)
+@end example
+
+The @var{value}, if present, is used to initialize the @code{:value}
+property. The value should be a string, which will be inserted in the
+buffer. This widget will only match the specified value.
+
+@node choice-item, toggle, item, Basic Types
+@comment node-name, next, previous, up
+@subsection The @code{choice-item} Widget
+
+Syntax:
+
+@example
+ITEM ::= (choice-item [KEYWORD ARGUMENT]... VALUE)
+@end example
+
+The @var{value}, if present, is used to initialize the @code{:value}
+property. The value should be a string, which will be inserted in the
+buffer as a button. Activating the button of a @code{choice-item} is
+equivalent to activating the parent widget. This widget will only match
+the specified value.
+
+@node toggle, checkbox, choice-item, Basic Types
+@comment node-name, next, previous, up
+@subsection The @code{toggle} Widget
+
+Syntax:
+
+@example
+TYPE ::= (toggle [KEYWORD ARGUMENT]...)
+@end example
+
+The widget has two possible states, `on' and `off', which corresponds to
+a @code{t} or @code{nil} value.
+
+The following extra properties are recognized.
+
+@table @code
+@item :on
+String representing the `on' state. By default the string @samp{on}.
+@item :off
+String representing the `off' state. By default the string @samp{off}.
+@item :on-type
+Type representing the `on' state. By default an `item' widget displaying
+the string specified with the @code{:on} keyword.
+@item :off-type
+Type representing the `off' state. By default an `item' widget
+displaying the string specified with the @code{:off} keyword.
+@end table
+
+@node checkbox, checklist, toggle, Basic Types
+@comment node-name, next, previous, up
+@subsection The @code{checkbox} Widget
+
+The widget has two possible states, `selected' and `unselected', which
+corresponds to a @code{t} or @code{nil} value.
+
+Syntax:
+
+@example
+TYPE ::= (checkbox [KEYWORD ARGUMENT]...)
+@end example
+
+@node checklist, repeat, checkbox, Basic Types
+@comment node-name, next, previous, up
+@subsection The @code{checklist} Widget
+
+Syntax:
+
+@example
+TYPE ::= (checklist [KEYWORD ARGUMENT]... TYPE ... )
+@end example
+
+The @var{type} arguments represents each checklist item. The widgets
+value of will be a list containing the value of each ticked @var{type}
+argument. The checklist widget will match a list whose elements all
+matches at least one of the specified @var{type} arguments.
+
+The following extra properties are recognized.
+
+@table @code
+@item :entry-format
+This string will be inserted for each entry in the list.
+The following @samp{%} escapes are available:
+@table @samp
+@item %v
+Replaced with the buffer representation of the @var{type} widget.
+@item %b
+Replace with the checkbox.
+@item %%
+Insert a literal @samp{%}.
+@end table
+
+@item :buttons
+The widgets representing the checkboxes.
+
+@item :children
+The widgets representing each type.
+
+@item :args
+The list of types.
+@end table
+
+@node repeat, , checklist, Basic Types
+@comment node-name, next, previous, up
+@subsection The @code{repeat} Widget
+
+Syntax:
+
+@example
+TYPE ::= ([KEYWORD ARGUMENT]... TYPE)
+@end example
+
+The value is a list, where each member represent one widget of type
+@var{type}.
+
+The following extra properties are recognized.
+
+@table @code
+@item :indent
+Number of spaces inserted before each member of the list, except for the
+first.
+
+@item :entry-format
+This string will be inserted for each entry in the list.
+The following @samp{%} escapes are available:
+@table @samp
+@item %v
+This will be replaced with the buffer representation of the @var{type}
+widget.
+@item %i
+Insert the @b{[INS]} button.
+@item %d
+Insert the @b{[DEL]} button.
+@item %%
+Insert a literal @samp{%}.
+@end table
+
+@item :buttons
+The widgets representing the insert and delete buttons.
+
+@item :children
+The widgets representing the elements of the list.
+
+@item :args
+List whose car is the type of the list elements.
+
+@end table
+
+@node Sexp Types, Widget Properties, Basic Types, Top
+@comment
+@section Sexp Types
+
+A number of widgets for editing s-expressions (lisp types) are also
+available. These basically fall in three categories: @dfn{atoms},
+@dfn{composite types}, and @dfn{generic}.
+
+@menu
+* generic::
+* atoms::
+* composite::
+@end menu
+
+@node generic, atoms, Sexp Types, Sexp Types
+@comment node-name, next, previous, up
+@subsection The Generic Widget.
+
+The @code{const} and @code{sexp} widgets can contain any lisp
+expression. In the case of the @code{const} widget the user is
+prohibited from editing edit it, which is mainly useful as a component
+of one of the composite widgets.
+
+The syntax for the generic widgets is
+
+@example
+TYPE ::= (const [KEYWORD ARGUMENT]... [ VALUE ])
+@end example
+
+The @var{value}, if present, is used to initialize the @code{:value}
+property and can be any s-expression.
+
+@deffn Widget const
+This will display any valid s-expression in an immutable part of the
+buffer.
+@end deffn
+
+@deffn Widget sexp
+This will allow you to edit any valid s-expression in an editable buffer
+field.
+
+The @code{sexp} widget takes the same keyword arguments as the
+@code{field} widget.
+@end deffn
+
+@node atoms, composite, generic, Sexp Types
+@comment node-name, next, previous, up
+@subsection Atomic Sexp Widgets.
+
+The atoms are s-expressions that does not consist of other
+s-expressions. A string is an atom, while a list is a composite type.
+You can edit the value of an atom with the following widgets.
+
+The syntax for all the atoms are
+
+@example
+TYPE ::= (NAME [KEYWORD ARGUMENT]... [ VALUE ])
+@end example
+
+The @var{value}, if present, is used to initialize the @code{:value}
+property and must be an expression of the same type as the widget.
+I.e. the string widget can only be initialized with a string.
+
+All the atom widgets take the same keyword arguments as the @code{field}
+widget.
+
+@deffn Widget string
+Allows you to edit a string in an editable field.
+@end deffn
+
+@deffn Widget file
+Allows you to edit a file name in an editable field. You you activate
+the tag button, you can edit the file name in the mini-buffer with
+completion.
+
+Keywords:
+@table @code
+@item :must-match
+If this is set to non-nil, only existing file names will be allowed in
+the minibuffer.
+@end table
+@end deffn
+
+@deffn Widget directory
+Allows you to edit a directory name in an editable field.
+Similar to the @code{file} widget.
+@end deffn
+
+@deffn Widget symbol
+Allows you to edit a lisp symbol in an editable field.
+@end deffn
+
+@deffn Widget integer
+Allows you to edit an integer in an editable field.
+@end deffn
+
+@deffn Widget number
+Allows you to edit a number in an editable field.
+@end deffn
+
+@node composite, , atoms, Sexp Types
+@comment node-name, next, previous, up
+@subsection Composite Sexp Widgets.
+
+The syntax for the composite are
+
+@example
+TYPE ::= (NAME [KEYWORD ARGUMENT]... COMPONENT...)
+@end example
+
+Where each @var{component} must be a widget type. Each component widget
+will be displayed in the buffer, and be editable to the user.
+
+@deffn Widget cons
+The value of a @code{cons} widget is a cons-cell where the car is the
+value of the first component and the cdr is the value of the second
+coponent. There must be exactly two components.
+@end deffn
+
+@deffn Widget lisp
+The value of a @code{cons} widget is a list containing the value of
+each of its component.
+@end deffn
+
+@deffn Widget vector
+The value of a @code{cons} widget is a vector containing the value of
+each of its component.
+@end deffn
+
+The above suffice for specifying fixed size lists and vectors. To get
+variable length lists and vectors, you can use a @code{choice},
+@code{radio}, @code{checklist} or @code{repeat} widget together with the
+@code{:inline} keyword. If any component of a composite widget has the
+@code{:inline} keyword set, its value must be a list which will then be
+spliced into the composite. For example, to specify a list whose first
+element must be a file name, and whose remaining arguments should either
+by the symbol @code{t} or two files, you can use the following widget
+specification:
+
+@example
+(list file
+ (choice (const t)
+ (list :inline t
+ :value ("foo" "bar")
+ string string)))
+@end example
+
+The value of a widget of this type will either have the form
+@samp{(file t)} or @code{(file string string)}.
+
+This concept of inline is probably hard to understand. It was certainly
+hard to implement so instead of confuse you more by trying to explain it
+here, I'll just suggest you meditate over it for a while.
+
+@node Widget Properties, Defining New Widgets, Sexp Types, Top
+@comment node-name, next, previous, up
+@section Properties
+
+You can examine or set this value by using the widget object that was
+returned by @code{widget-create}.
+
+@defun widget-value widget
+Return the current value contained in @var{widget}.
+It is an error to call this function on an uninitialized widget.
+@end defun
+
+@defun widget-value-set widget value
+Set the value contained in @var{widget} to @var{value}.
+It is an error to call this function with an invalid @var{value}.
+@end defun
+
+@strong{Important:} You @emph{must} call @code{widget-setup} after
+modifying the value of a widget before the user is allowed to edit the
+widget again. It is enough to call @code{widget-setup} once if you
+modify multiple widgets. This is currently only necessary if the widget
+contains an editing field, but may be necessary for other widgets in the
+future.
+
+If your application needs to associate some information with the widget
+objects, for example a reference to the item being edited, it can be
+done with @code{widget-put} and @code{widget-get}. The property names
+must begin with a @samp{:}.
+
+@defun widget-put widget property value
+In @var{widget} set @var{property} to @var{value}.
+@var{property} should be a symbol, while @var{value} can be anything.
+@end defun
+
+@defun widget-get widget property
+In @var{widget} return the value for @var{property}.
+@var{property} should be a symbol, the value is what was last set by
+@code{widget-put} for @var{property}.
+@end defun
+
+@defun widget-member widget property
+Non-nil if @var{widget} has a value (even nil) for property @var{property}.
+@end defun
+
+@node Defining New Widgets, Widget Wishlist., Widget Properties, Top
+@comment node-name, next, previous, up
+@section Defining New Widgets
+
+You can define specialized widgets with @code{define-widget}. It allows
+you to create a shorthand for more complex widgets, including specifying
+component widgets and default new default values for the keyword
+arguments.
+
+@defun widget-define name class doc &rest args
+Define a new widget type named @var{name} from @code{class}.
+
+@var{name} and class should both be symbols, @code{class} should be one
+of the existing widget types.
+
+The third argument @var{DOC} is a documentation string for the widget.
+
+After the new widget has been defined, the following two calls will
+create identical widgets:
+
+@itemize @bullet
+@item
+@lisp
+(widget-create @var{name})
+@end lisp
+
+@item
+@lisp
+(apply widget-create @var{class} @var{args})
+@end lisp
+@end itemize
+
+@end defun
+
+Using @code{widget-define} does just store the definition of the widget
+type in the @code{widget-type} property of @var{name}, which is what
+@code{widget-create} uses.
+
+If you just want to specify defaults for keywords with no complex
+conversions, you can use @code{identity} as your conversion function.
+
+The following additional keyword arguments are useful when defining new
+widgets:
+@table @code
+@item :convert-widget
+Function to convert a widget type before creating a widget of that
+type. It takes a widget type as an argument, and returns the converted
+widget type. When a widget is created, this function is called for the
+widget type and all the widgets parent types, most derived first.
+
+@item :value-to-internal
+Function to convert the value to the internal format. The function
+takes two arguments, a widget and an external value, and returns the
+internal value. The function is called on the present @code{:value}
+when the widget is created, and on any value set later with
+@code{widget-value-set}.
+
+@item :value-to-external
+Function to convert the value to the external format. The function
+takes two arguments, a widget and an internal value, and returns the
+internal value. The function is called on the present @code{:value}
+when the widget is created, and on any value set later with
+@code{widget-value-set}.
+
+@item :create
+Function to create a widget from scratch. The function takes one
+argument, a widget type, and create a widget of that type, insert it in
+the buffer, and return a widget object.
+
+@item :delete
+Function to delete a widget. The function takes one argument, a widget,
+and should remove all traces of the widget from the buffer.
+
+@item :value-create
+Function to expand the @samp{%v} escape in the format string. It will
+be called with the widget as its argument. Should
+insert a representation of the widgets value in the buffer.
+
+@item :value-delete
+Should remove the representation of the widgets value from the buffer.
+It will be called with the widget as its argument. It doesn't have to
+remove the text, but it should release markers and delete nested widgets
+if such has been used.
+
+@item :format-handler
+Function to handle unknown @samp{%} escapes in the format string. It
+will be called with the widget and the escape character as arguments.
+You can set this to allow your widget to handle non-standard escapes.
+@end table
+
+If you want to define a new widget from scratch, use the @code{default}
+widget as its base.
+
+@deffn Widget default [ keyword argument ]
+Widget used as a base for other widgets.
+
+It provides most of the functionality that is refered to as ``by
+default'' in this text.
+@end deffn
+
+@node Widget Wishlist., , Defining New Widgets, Top
+@comment node-name, next, previous, up
+@section Wishlist.
+
+@itemize @bullet
+@item
+In general, we need @strong{much} better support for keyboard
+operations.
+
+@itemize -
+@item
+It should be possible to add or remove items from a list with @kbd{C-k}
+and @kbd{C-o} (suggested by @sc{rms}).
+
+@item
+@kbd{C-k} should kill to end of field or end of line, whatever come
+first.
+
+@item
+Commands to move to the beginning/end of a field.
+
+@end itemize
+
+@item
+The @samp{[INS]} and @samp{[DEL]} buttons should be replaced by a single
+dash (@samp{-}). The dash should be a button that, when activated, ask
+whether you want to add or delete an item (@sc{rms} wanted to git rid of
+the ugly buttons, the dash is my idea).
+
+@item
+Use graphical versions of the widgets for emacsen that can do that.
+I.e. real radio buttons and checkmarks instead of their @sc{ascii}
+equivalents.
+
+@item
+There should be a way to probe a widget to see if the user has modified
+it.
+
+@item
+The support for indentation of component widgets should be finished.
+
+@item
+There should be support for browsing the widget documentation.
+
+@item
+There should be a way to specify that @key{RET} in a field will call the
+@code{:activate} function. This should be used by widgets such as
+@code{file} and @code{symbol} prompt with completion. This way, we
+could also get rid of the default tag for the @code{file} widget.
+
+@item
+The @code{choice} tag should be prettier, something like the abbreviated
+menus in Open Look.
+
+@item
+The functions used in many widgets, like
+@code{widget-item-convert-widget}, should not have names that are
+specific to the first widget where I used them.
+
+@item
+Unchecked items in a @code{radio} or @code{checklist} should be grayed
+out, and the subwidgets should somehow become inactive. This could
+perhaps be implemented by binding @code{widget-inactive} to t when inserting
+the grayed out subwidget, and let the widget-specify functions check
+that variable.
+
+@end itemize
+
+@contents
+@bye
projects / gnus / commitdiff