Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

*** empty log message ***

  • Loading branch information...
commit b5ae5a6852fcb2ccf585099c07c10eb536866497 1 parent fe1c0b5
@larsmagne larsmagne authored
View
8 lisp/ChangeLog
@@ -1,3 +1,11 @@
+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.
View
722 lisp/custom-edit.el
@@ -0,0 +1,722 @@
+;;; 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
View
365 lisp/custom.el
@@ -0,0 +1,365 @@
+;;; 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
View
1  lisp/gnus-art.el
@@ -30,6 +30,7 @@
(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\").")
View
0  lisp/gnus-cus.el
No changes.
View
0  lisp/gnus-edit.el
No changes.
View
2  lisp/gnus.el
@@ -28,7 +28,7 @@
(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)
View
1,693 lisp/widget-edit.el
@@ -0,0 +1,1693 @@
+;;; 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
+