** Gnus changes.
+*** The Gnus alpha distribution no longer bundles Custom and Widget.
+If your Emacs doesn't come with these libraries, fetch them from
+<URL:http://www.dina.kvl.dk/~abraham/custom/>. You also then need to
+add the following to the lisp/dgnushack.el file:
+
+ (push "~/lisp/custom" load-path)
+
+Modify to suit your needs.
+
*** New functionality for using Gnus as an offline newsreader has been
added. A plethora of new commands and modes have been added. See the
Gnus manual for the full story.
+Sat Sep 20 23:23:49 1997 Lars Magne Ingebrigtsen <larsi@menja.ifi.uio.no>
+
+ * gnus.el: Quassia Gnus v0.8 is released.
+
+Sat Sep 20 20:41:16 1997 Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+
+ * gnus-start.el (gnus-setup-news-hook): New hook.
+
+ * gnus-agent.el (gnus-agentize): Really set up queue group.
+ (gnus-open-agent): Setup queue here.
+
+Sat Sep 20 20:23:07 1997 Matt Simmons <simmonmt@acm.org>
+
+ * message.el (message-set-auto-save-file-name): Make things work
+ without drafts.
+
+Sat Sep 20 18:32:02 1997 Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+
+ * nnmh.el (nnmh-request-list-1): Check for links to ".".
+
+ * nndraft.el (nndraft-possibly-change-group): New function.
+
+ * gnus-agent.el (gnus-agent-queue-setup): New function.
+
Thu Sep 18 04:54:59 1997 Lars Magne Ingebrigtsen <larsi@menja.ifi.uio.no>
* gnus.el: Quassia Gnus v0.7 is released.
+++ /dev/null
-;;; cus-edit.el --- Tools for customization Emacs.
-;;
-;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
-;;
-;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
-;; Keywords: help, faces
-;; Version: 1.82
-;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
-
-;;; Commentary:
-;;
-;; See `custom.el'.
-
-;;; Code:
-
-(require 'cus-face)
-(require 'wid-edit)
-(require 'easymenu)
-
-(define-widget-keywords :custom-prefixes :custom-menu :custom-show
- :custom-magic :custom-state :custom-level :custom-form
- :custom-set :custom-save :custom-reset-current :custom-reset-saved
- :custom-reset-factory)
-
-(put 'custom-define-hook 'custom-type 'hook)
-(put 'custom-define-hook 'factory-value '(nil))
-(custom-add-to-group 'customize 'custom-define-hook 'custom-variable)
-
-;;; Customization Groups.
-
-(defgroup emacs nil
- "Customization of the One True Editor."
- :link '(custom-manual "(emacs)Top"))
-
-;; Most of these groups are stolen from `finder.el',
-(defgroup editing nil
- "Basic text editing facilities."
- :group 'emacs)
-
-(defgroup abbrev nil
- "Abbreviation handling, typing shortcuts, macros."
- :tag "Abbreviations"
- :group 'editing)
-
-(defgroup matching nil
- "Various sorts of searching and matching."
- :group 'editing)
-
-(defgroup emulations nil
- "Emulations of other editors."
- :group 'editing)
-
-(defgroup mouse nil
- "Mouse support."
- :group 'editing)
-
-(defgroup outlines nil
- "Support for hierarchical outlining."
- :group 'editing)
-
-(defgroup external nil
- "Interfacing to external utilities."
- :group 'emacs)
-
-(defgroup bib nil
- "Code related to the `bib' bibliography processor."
- :tag "Bibliography"
- :group 'external)
-
-(defgroup processes nil
- "Process, subshell, compilation, and job control support."
- :group 'external
- :group 'development)
-
-(defgroup programming nil
- "Support for programming in other languages."
- :group 'emacs)
-
-(defgroup languages nil
- "Specialized modes for editing programming languages."
- :group 'programming)
-
-(defgroup lisp nil
- "Lisp support, including Emacs Lisp."
- :group 'languages
- :group 'development)
-
-(defgroup c nil
- "Support for the C language and related languages."
- :group 'languages)
-
-(defgroup tools nil
- "Programming tools."
- :group 'programming)
-
-(defgroup oop nil
- "Support for object-oriented programming."
- :group 'programming)
-
-(defgroup applications nil
- "Applications written in Emacs."
- :group 'emacs)
-
-(defgroup calendar nil
- "Calendar and time management support."
- :group 'applications)
-
-(defgroup mail nil
- "Modes for electronic-mail handling."
- :group 'applications)
-
-(defgroup news nil
- "Support for netnews reading and posting."
- :group 'applications)
-
-(defgroup games nil
- "Games, jokes and amusements."
- :group 'applications)
-
-(defgroup development nil
- "Support for further development of Emacs."
- :group 'emacs)
-
-(defgroup docs nil
- "Support for Emacs documentation."
- :group 'development)
-
-(defgroup extensions nil
- "Emacs Lisp language extensions."
- :group 'development)
-
-(defgroup internal nil
- "Code for Emacs internals, build process, defaults."
- :group 'development)
-
-(defgroup maint nil
- "Maintenance aids for the Emacs development group."
- :tag "Maintenance"
- :group 'development)
-
-(defgroup environment nil
- "Fitting Emacs with its environment."
- :group 'emacs)
-
-(defgroup comm nil
- "Communications, networking, remote access to files."
- :tag "Communication"
- :group 'environment)
-
-(defgroup hardware nil
- "Support for interfacing with exotic hardware."
- :group 'environment)
-
-(defgroup terminals nil
- "Support for terminal types."
- :group 'environment)
-
-(defgroup unix nil
- "Front-ends/assistants for, or emulators of, UNIX features."
- :group 'environment)
-
-(defgroup vms nil
- "Support code for vms."
- :group 'environment)
-
-(defgroup i18n nil
- "Internationalization and alternate character-set support."
- :group 'environment
- :group 'editing)
-
-(defgroup frames nil
- "Support for Emacs frames and window systems."
- :group 'environment)
-
-(defgroup data nil
- "Support editing files of data."
- :group 'emacs)
-
-(defgroup wp nil
- "Word processing."
- :group 'emacs)
-
-(defgroup tex nil
- "Code related to the TeX formatter."
- :group 'wp)
-
-(defgroup faces nil
- "Support for multiple fonts."
- :group 'emacs)
-
-(defgroup hypermedia nil
- "Support for links between text or other media types."
- :group 'emacs)
-
-(defgroup help nil
- "Support for on-line help systems."
- :group 'emacs)
-
-(defgroup local nil
- "Code local to your site."
- :group 'emacs)
-
-(defgroup customize '((widgets custom-group))
- "Customization of the Customization support."
- :link '(custom-manual "(custom)Top")
- :link '(url-link :tag "Development Page"
- "http://www.dina.kvl.dk/~abraham/custom/")
- :prefix "custom-"
- :group 'help)
-
-(defgroup custom-faces nil
- "Faces used by customize."
- :group 'customize
- :group 'faces)
-
-;;; 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)
- (and (fboundp 'characterp)
- (characterp sexp)))
- sexp
- (list 'quote sexp)))
-
-(defun custom-split-regexp-maybe (regexp)
- "If REGEXP is a string, split it to a list at `\\|'.
-You can get the original back with from the result with:
- (mapconcat 'identity result \"\\|\")
-
-IF REGEXP is not a string, return it unchanged."
- (if (stringp regexp)
- (let ((start 0)
- all)
- (while (string-match "\\\\|" regexp start)
- (setq all (cons (substring regexp start (match-beginning 0)) all)
- start (match-end 0)))
- (nreverse (cons (substring regexp start) all)))
- regexp))
-
-(defun custom-variable-prompt ()
- ;; Code stolen from `help.el'.
- "Prompt for a variable, defaulting to the variable at point.
-Return a list suitable for use in `interactive'."
- (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)))))
-
-;;; Unlispify.
-
-(defvar custom-prefix-list nil
- "List of prefixes that should be ignored by `custom-unlispify'")
-
-(defcustom custom-unlispify-menu-entries t
- "Display menu entries as words instead of symbols if non nil."
- :group 'customize
- :type 'boolean)
-
-(defun custom-unlispify-menu-entry (symbol &optional no-suffix)
- "Convert symbol into a menu entry."
- (cond ((not custom-unlispify-menu-entries)
- (symbol-name symbol))
- ((get symbol 'custom-tag)
- (if no-suffix
- (get symbol 'custom-tag)
- (concat (get symbol 'custom-tag) "...")))
- (t
- (save-excursion
- (set-buffer (get-buffer-create " *Custom-Work*"))
- (erase-buffer)
- (princ symbol (current-buffer))
- (goto-char (point-min))
- (when (and (eq (get symbol 'custom-type) 'boolean)
- (re-search-forward "-p\\'" nil t))
- (replace-match "" t t)
- (goto-char (point-min)))
- (let ((prefixes custom-prefix-list)
- prefix)
- (while prefixes
- (setq prefix (car prefixes))
- (if (search-forward prefix (+ (point) (length prefix)) t)
- (progn
- (setq prefixes nil)
- (delete-region (point-min) (point)))
- (setq prefixes (cdr prefixes)))))
- (subst-char-in-region (point-min) (point-max) ?- ?\ t)
- (capitalize-region (point-min) (point-max))
- (unless no-suffix
- (goto-char (point-max))
- (insert "..."))
- (buffer-string)))))
-
-(defcustom custom-unlispify-tag-names t
- "Display tag names as words instead of symbols if non nil."
- :group 'customize
- :type 'boolean)
-
-(defun custom-unlispify-tag-name (symbol)
- "Convert symbol into a menu entry."
- (let ((custom-unlispify-menu-entries custom-unlispify-tag-names))
- (custom-unlispify-menu-entry symbol t)))
-
-(defun custom-prefix-add (symbol prefixes)
- ;; Addd SYMBOL to list of ignored PREFIXES.
- (cons (or (get symbol 'custom-prefix)
- (concat (symbol-name symbol) "-"))
- prefixes))
-
-;;; Guess.
-
-(defcustom custom-guess-name-alist
- '(("-p\\'" boolean)
- ("-hook\\'" hook)
- ("-face\\'" face)
- ("-file\\'" file)
- ("-function\\'" function)
- ("-functions\\'" (repeat function))
- ("-list\\'" (repeat sexp))
- ("-alist\\'" (repeat (cons sexp sexp))))
- "Alist of (MATCH TYPE).
-
-MATCH should be a regexp matching the name of a symbol, and TYPE should
-be a widget suitable for editing the value of that symbol. The TYPE
-of the first entry where MATCH matches the name of the symbol will be
-used.
-
-This is used for guessing the type of variables not declared with
-customize."
- :type '(repeat (group (regexp :tag "Match") (sexp :tag "Type")))
- :group 'customize)
-
-(defcustom custom-guess-doc-alist
- '(("\\`\\*?Non-nil " boolean))
- "Alist of (MATCH TYPE).
-
-MATCH should be a regexp matching a documentation string, and TYPE
-should be a widget suitable for editing the value of a variable with
-that documentation string. The TYPE of the first entry where MATCH
-matches the name of the symbol will be used.
-
-This is used for guessing the type of variables not declared with
-customize."
- :type '(repeat (group (regexp :tag "Match") (sexp :tag "Type")))
- :group 'customize)
-
-(defun custom-guess-type (symbol)
- "Guess a widget suitable for editing the value of SYMBOL.
-This is done by matching SYMBOL with `custom-guess-name-alist' and
-if that fails, the doc string with `custom-guess-doc-alist'."
- (let ((name (symbol-name symbol))
- (names custom-guess-name-alist)
- current found)
- (while names
- (setq current (car names)
- names (cdr names))
- (when (string-match (nth 0 current) name)
- (setq found (nth 1 current)
- names nil)))
- (unless found
- (let ((doc (documentation-property symbol 'variable-documentation))
- (docs custom-guess-doc-alist))
- (when doc
- (while docs
- (setq current (car docs)
- docs (cdr docs))
- (when (string-match (nth 0 current) doc)
- (setq found (nth 1 current)
- docs nil))))))
- found))
-
-;;; Custom Mode Commands.
-
-(defvar custom-options nil
- "Customization widgets in the current buffer.")
-
-(defun custom-set ()
- "Set changes in all modified options."
- (interactive)
- (let ((children custom-options))
- (mapcar (lambda (child)
- (when (eq (widget-get child :custom-state) 'modified)
- (widget-apply child :custom-set)))
- children)))
-
-(defun custom-save ()
- "Set all modified group members and save them."
- (interactive)
- (let ((children custom-options))
- (mapcar (lambda (child)
- (when (memq (widget-get child :custom-state) '(modified set))
- (widget-apply child :custom-save)))
- children))
- (custom-save-all))
-
-(defvar custom-reset-menu
- '(("Current" . custom-reset-current)
- ("Saved" . custom-reset-saved)
- ("Factory Settings" . custom-reset-factory))
- "Alist of actions for the `Reset' button.
-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-reset (event)
- "Select item from reset menu."
- (let* ((completion-ignore-case t)
- (answer (widget-choose "Reset to"
- custom-reset-menu
- event)))
- (if answer
- (funcall answer))))
-
-(defun custom-reset-current ()
- "Reset all modified group members to their current value."
- (interactive)
- (let ((children custom-options))
- (mapcar (lambda (child)
- (when (eq (widget-get child :custom-state) 'modified)
- (widget-apply child :custom-reset-current)))
- children)))
-
-(defun custom-reset-saved ()
- "Reset all modified or set group members to their saved value."
- (interactive)
- (let ((children custom-options))
- (mapcar (lambda (child)
- (when (eq (widget-get child :custom-state) 'modified)
- (widget-apply child :custom-reset-current)))
- children)))
-
-(defun custom-reset-factory ()
- "Reset all modified, set, or saved group members to their factory settings."
- (interactive)
- (let ((children custom-options))
- (mapcar (lambda (child)
- (when (eq (widget-get child :custom-state) 'modified)
- (widget-apply child :custom-reset-current)))
- children)))
-
-;;; 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 (custom-variable-prompt))
- (custom-buffer-create (list (list symbol 'custom-variable))))
-
-;;;###autoload
-(defun customize-variable-other-window (symbol)
- "Customize SYMBOL, which must be a variable.
-Show the buffer in another window, but don't select it."
- (interactive (custom-variable-prompt))
- (custom-buffer-create-other-window (list (list symbol 'custom-variable))))
-
-;;;###autoload
-(defun customize-face (&optional symbol)
- "Customize SYMBOL, which should be a face name or nil.
-If SYMBOL is nil, customize all faces."
- (interactive (list (completing-read "Customize face: (default all) "
- obarray 'custom-facep)))
- (if (or (null symbol) (and (stringp symbol) (zerop (length symbol))))
- (let ((found nil))
- (message "Looking for faces...")
- (mapcar (lambda (symbol)
- (setq found (cons (list symbol 'custom-face) found)))
- (nreverse (mapcar 'intern
- (sort (mapcar 'symbol-name (face-list))
- 'string<))))
-
- (custom-buffer-create found))
- (if (stringp symbol)
- (setq symbol (intern symbol)))
- (unless (symbolp symbol)
- (error "Should be a symbol %S" symbol))
- (custom-buffer-create (list (list symbol 'custom-face)))))
-
-;;;###autoload
-(defun customize-face-other-window (&optional symbol)
- "Show customization buffer for FACE in other window."
- (interactive (list (completing-read "Customize face: "
- obarray 'custom-facep)))
- (if (or (null symbol) (and (stringp symbol) (zerop (length symbol))))
- ()
- (if (stringp symbol)
- (setq symbol (intern symbol)))
- (unless (symbolp symbol)
- (error "Should be a symbol %S" symbol))
- (custom-buffer-create-other-window (list (list symbol 'custom-face)))))
-
-;;;###autoload
-(defun customize-customized ()
- "Customize all already customized user options."
- (interactive)
- (let ((found nil))
- (mapatoms (lambda (symbol)
- (and (get symbol 'saved-face)
- (custom-facep symbol)
- (setq found (cons (list symbol 'custom-face) found)))
- (and (get symbol 'saved-value)
- (boundp symbol)
- (setq found
- (cons (list symbol 'custom-variable) found)))))
- (if found
- (custom-buffer-create found)
- (error "No customized user options"))))
-
-;;;###autoload
-(defun customize-apropos (regexp &optional all)
- "Customize all user options matching REGEXP.
-If ALL (e.g., started with a prefix key), include options which are not
-user-settable."
- (interactive "sCustomize regexp: \nP")
- (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 (custom-facep symbol)
- (setq found (cons (list symbol 'custom-face) found)))
- (when (and (boundp symbol)
- (or (get symbol 'saved-value)
- (get symbol 'factory-value)
- (if all
- (get symbol 'variable-documentation)
- (user-variable-p symbol))))
- (setq found
- (cons (list symbol 'custom-variable) found))))))
- (if found
- (custom-buffer-create found)
- (error "No matches"))))
-
-;;;###autoload
-(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 (get-buffer-create "*Customization*"))
- (custom-buffer-create-internal options))
-
-(defun custom-buffer-create-other-window (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*"))
- (let ((window (selected-window)))
- (switch-to-buffer-other-window (get-buffer-create "*Customization*"))
- (custom-buffer-create-internal options)
- (select-window window)))
-
-
-(defun custom-buffer-create-internal (options)
- (message "Creating customization buffer...")
- (custom-mode)
- (widget-insert "This is a customization buffer.
-Push RET or click mouse-2 on the word ")
- ;; (put-text-property 1 2 'start-open nil)
- (widget-create 'info-link
- :tag "help"
- :help-echo "Read the online help."
- "(custom)The Customization Buffer")
- (widget-insert " for more information.\n\n")
- (setq custom-options
- (if (= (length options) 1)
- (mapcar (lambda (entry)
- (widget-create (nth 1 entry)
- :custom-state 'unknown
- :tag (custom-unlispify-tag-name
- (nth 0 entry))
- :value (nth 0 entry)))
- options)
- (let ((count 0)
- (length (length options)))
- (mapcar (lambda (entry)
- (prog2
- (message "Creating customization items %2d%%..."
- (/ (* 100.0 count) length))
- (widget-create (nth 1 entry)
- :tag (custom-unlispify-tag-name
- (nth 0 entry))
- :value (nth 0 entry))
- (setq count (1+ count))
- (unless (eq (preceding-char) ?\n)
- (widget-insert "\n"))
- (widget-insert "\n")))
- options))))
- (unless (eq (preceding-char) ?\n)
- (widget-insert "\n"))
- (widget-insert "\n")
- (message "Creating customization magic...")
- (mapcar 'custom-magic-reset custom-options)
- (message "Creating customization buttons...")
- (widget-create 'push-button
- :tag "Set"
- :help-echo "Set all modifications for this session."
- :action (lambda (widget &optional event)
- (custom-set)))
- (widget-insert " ")
- (widget-create 'push-button
- :tag "Save"
- :help-echo "\
-Make the modifications default for future sessions."
- :action (lambda (widget &optional event)
- (custom-save)))
- (widget-insert " ")
- (widget-create 'push-button
- :tag "Reset"
- :help-echo "Undo all modifications."
- :action (lambda (widget &optional event)
- (custom-reset event)))
- (widget-insert " ")
- (widget-create 'push-button
- :tag "Done"
- :help-echo "Bury the buffer."
- :action (lambda (widget &optional event)
- (bury-buffer)
- ;; Steal button release event.
- (if (and (fboundp 'button-press-event-p)
- (fboundp 'next-command-event))
- ;; XEmacs
- (and event
- (button-press-event-p event)
- (next-command-event))
- ;; Emacs
- (when (memq 'down (event-modifiers event))
- (read-event)))))
- (widget-insert "\n")
- (message "Creating customization setup...")
- (widget-setup)
- (goto-char (point-min))
- (forward-char) ;Kludge: bob is writable in XEmacs.
- (message "Creating customization buffer...done"))
-
-;;; Modification of Basic Widgets.
-;;
-;; We add extra properties to the basic widgets needed here. This is
-;; fine, as long as we are careful to stay within out own namespace.
-;;
-;; We want simple widgets to be displayed by default, but complex
-;; widgets to be hidden.
-
-(widget-put (get 'item 'widget-type) :custom-show t)
-(widget-put (get 'editable-field 'widget-type)
- :custom-show (lambda (widget value)
- (let ((pp (pp-to-string value)))
- (cond ((string-match "\n" pp)
- nil)
- ((> (length pp) 40)
- nil)
- (t t)))))
-(widget-put (get 'menu-choice 'widget-type) :custom-show t)
-
-;;; The `custom-manual' Widget.
-
-(define-widget 'custom-manual 'info-link
- "Link to the manual entry for this customization option."
- :help-echo "Read the manual entry for this option."
- :tag "Manual")
-
-;;; The `custom-magic' Widget.
-
-(defface custom-invalid-face '((((class color))
- (:foreground "yellow" :background "red"))
- (t
- (:bold t :italic t :underline t)))
- "Face used when the customize item is invalid.")
-
-(defface custom-rogue-face '((((class color))
- (:foreground "pink" :background "black"))
- (t
- (:underline t)))
- "Face used when the customize item is not defined for customization.")
-
-(defface custom-modified-face '((((class color))
- (:foreground "white" :background "blue"))
- (t
- (:italic t :bold)))
- "Face used when the customize item has been modified.")
-
-(defface custom-set-face '((((class color))
- (:foreground "blue" :background "white"))
- (t
- (:italic t)))
- "Face used when the customize item has been set.")
-
-(defface custom-changed-face '((((class color))
- (:foreground "white" :background "blue"))
- (t
- (:italic t)))
- "Face used when the customize item has been changed.")
-
-(defface custom-saved-face '((t (:underline t)))
- "Face used when the customize item has been saved.")
-
-(defcustom custom-magic-alist '((nil "#" underline "\
-uninitialized, you should not see this.")
- (unknown "?" italic "\
-unknown, you should not see this.")
- (hidden "-" default "\
-hidden, press the state button to show.")
- (invalid "x" custom-invalid-face "\
-the value displayed for this item is invalid and cannot be set.")
- (modified "*" custom-modified-face "\
-you have edited the item, and can now set it.")
- (set "+" custom-set-face "\
-you have set this item, but not saved it.")
- (changed ":" custom-changed-face "\
-this item has been changed outside customize.")
- (saved "!" custom-saved-face "\
-this item has been saved.")
- (rogue "@" custom-rogue-face "\
-this item is not prepared for customization.")
- (factory " " nil "\
-this item is unchanged from its factory setting."))
- "Alist of customize option states.
-Each entry is of the form (STATE MAGIC FACE DESCRIPTION), where
-
-STATE is one of the following symbols:
-
-`nil'
- For internal use, should never occur.
-`unknown'
- For internal use, should never occur.
-`hidden'
- This item is not being displayed.
-`invalid'
- This item is modified, but has an invalid form.
-`modified'
- This item is modified, and has a valid form.
-`set'
- This item has been set but not saved.
-`changed'
- The current value of this item has been changed temporarily.
-`saved'
- This item is marked for saving.
-`rogue'
- This item has no customization information.
-`factory'
- This item is unchanged from the factory default.
-
-MAGIC is a string used to present that state.
-
-FACE is a face used to present the state.
-
-DESCRIPTION is a string describing the state.
-
-The list should be sorted most significant first."
- :type '(list (checklist :inline t
- (group (const nil)
- (string :tag "Magic")
- face
- (string :tag "Description"))
- (group (const unknown)
- (string :tag "Magic")
- face
- (string :tag "Description"))
- (group (const hidden)
- (string :tag "Magic")
- face
- (string :tag "Description"))
- (group (const invalid)
- (string :tag "Magic")
- face
- (string :tag "Description"))
- (group (const modified)
- (string :tag "Magic")
- face
- (string :tag "Description"))
- (group (const set)
- (string :tag "Magic")
- face
- (string :tag "Description"))
- (group (const changed)
- (string :tag "Magic")
- face
- (string :tag "Description"))
- (group (const saved)
- (string :tag "Magic")
- face
- (string :tag "Description"))
- (group (const rogue)
- (string :tag "Magic")
- face
- (string :tag "Description"))
- (group (const factory)
- (string :tag "Magic")
- face
- (string :tag "Description")))
- (editable-list :inline t
- (group symbol
- (string :tag "Magic")
- face
- (string :tag "Description"))))
- :group 'customize
- :group 'custom-faces)
-
-(defcustom custom-magic-show 'long
- "Show long description of the state of each customization option."
- :type '(choice (const :tag "no" nil)
- (const short)
- (const long))
- :group 'customize)
-
-(defcustom custom-magic-show-button t
- "Show a magic button indicating the state of each customization option."
- :type 'boolean
- :group 'customize)
-
-(define-widget 'custom-magic 'default
- "Show and manipulate state for a customization option."
- :format "%v"
- :action 'widget-choice-item-action
- :value-get 'ignore
- :value-create 'custom-magic-value-create
- :value-delete 'widget-children-value-delete)
-
-(defun custom-magic-value-create (widget)
- ;; Create compact status report for WIDGET.
- (let* ((parent (widget-get widget :parent))
- (state (widget-get parent :custom-state))
- (entry (assq state custom-magic-alist))
- (magic (nth 1 entry))
- (face (nth 2 entry))
- (text (nth 3 entry))
- (lisp (eq (widget-get parent :custom-form) 'lisp))
- children)
- (when custom-magic-show
- (push (widget-create-child-and-convert widget 'choice-item
- :help-echo "\
-Change the state of this item."
- :format "%[%t%]"
- :tag "State")
- children)
- (insert ": ")
- (if (eq custom-magic-show 'long)
- (insert text)
- (insert (symbol-name state)))
- (when lisp
- (insert " (lisp)"))
- (insert "\n"))
- (when custom-magic-show-button
- (when custom-magic-show
- (let ((indent (widget-get parent :indent)))
- (when indent
- (insert-char ? indent))))
- (push (widget-create-child-and-convert widget 'choice-item
- :button-face face
- :help-echo "Change the state."
- :format "%[%t%]"
- :tag (if lisp
- (concat "(" magic ")")
- (concat "[" magic "]")))
- children)
- (insert " "))
- (widget-put widget :children children)))
-
-(defun custom-magic-reset (widget)
- "Redraw the :custom-magic property of WIDGET."
- (let ((magic (widget-get widget :custom-magic)))
- (widget-value-set magic (widget-value magic))))
-
-;;; The `custom-level' Widget.
-
-(define-widget 'custom-level 'item
- "The custom level buttons."
- :format "%[%t%]"
- :help-echo "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))
- (state (widget-get parent :custom-state)))
- (cond ((memq state '(invalid modified))
- (error "There are unset changes"))
- ((eq state 'hidden)
- (widget-put parent :custom-state 'unknown))
- (t
- (widget-put parent :custom-state 'hidden)))
- (custom-redraw parent)))
-
-;;; The `custom' Widget.
-
-(define-widget 'custom 'default
- "Customize a user option."
- :convert-widget 'custom-convert-widget
- :format "%l%[%t%]: %v%m%h%a"
- :format-handler 'custom-format-handler
- :notify 'custom-notify
- :custom-level 1
- :custom-state 'hidden
- :documentation-property 'widget-subclass-responsibility
- :value-create 'widget-subclass-responsibility
- :value-delete 'widget-children-value-delete
- :value-get 'widget-item-value-get
- :validate 'widget-editable-list-validate
- :match (lambda (widget value) (symbolp value)))
-
-(defun custom-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 :tag (custom-unlispify-tag-name (car args)))
- (widget-put widget :args nil)))
- widget)
-
-(defun custom-format-handler (widget escape)
- ;; We recognize extra escape sequences.
- (let* ((buttons (widget-get widget :buttons))
- (state (widget-get widget :custom-state))
- (level (widget-get widget :custom-level)))
- (cond ((eq escape ?l)
- (when level
- (push (widget-create-child-and-convert
- widget 'custom-level (make-string level ?*))
- buttons)
- (widget-insert " ")
- (widget-put widget :buttons buttons)))
- ((eq escape ?L)
- (when (eq state 'hidden)
- (widget-insert " ...")))
- ((eq escape ?m)
- (and (eq (preceding-char) ?\n)
- (widget-get widget :indent)
- (insert-char ? (widget-get widget :indent)))
- (let ((magic (widget-create-child-and-convert
- widget 'custom-magic nil)))
- (widget-put widget :custom-magic magic)
- (push magic buttons)
- (widget-put widget :buttons buttons)))
- ((eq escape ?a)
- (let* ((symbol (widget-get widget :value))
- (links (get symbol 'custom-links))
- (many (> (length links) 2)))
- (when links
- (and (eq (preceding-char) ?\n)
- (widget-get widget :indent)
- (insert-char ? (widget-get widget :indent)))
- (insert "See also ")
- (while links
- (push (widget-create-child-and-convert widget (car links))
- buttons)
- (setq links (cdr links))
- (cond ((null links)
- (insert ".\n"))
- ((null (cdr links))
- (if many
- (insert ", and ")
- (insert " and ")))
- (t
- (insert ", "))))
- (widget-put widget :buttons buttons))))
- (t
- (widget-default-format-handler widget escape)))))
-
-(defun custom-notify (widget &rest args)
- "Keep track of changes."
- (unless (memq (widget-get widget :custom-state) '(nil unknown hidden))
- (widget-put widget :custom-state 'modified))
- (let ((buffer-undo-list t))
- (custom-magic-reset widget))
- (apply 'widget-default-notify widget args))
-
-(defun custom-redraw (widget)
- "Redraw WIDGET with current settings."
- (let ((pos (point))
- (from (marker-position (widget-get widget :from)))
- (to (marker-position (widget-get widget :to))))
- (save-excursion
- (widget-value-set widget (widget-value widget))
- (custom-redraw-magic widget))
- (when (and (>= pos from) (<= pos to))
- (goto-char pos))))
-
-(defun custom-redraw-magic (widget)
- "Redraw WIDGET state with current settings."
- (while widget
- (let ((magic (widget-get widget :custom-magic)))
- (unless magic
- (debug))
- (widget-value-set magic (widget-value magic))
- (when (setq widget (widget-get widget :group))
- (custom-group-state-update widget))))
- (widget-setup))
-
-(defun custom-show (widget value)
- "Non-nil if WIDGET should be shown with VALUE by default."
- (let ((show (widget-get widget :custom-show)))
- (cond ((null show)
- nil)
- ((eq t show)
- t)
- (t
- (funcall show widget value)))))
-
-(defvar custom-load-recursion nil
- "Hack to avoid recursive dependencies.")
-
-(defun custom-load-symbol (symbol)
- "Load all dependencies for SYMBOL."
- (unless custom-load-recursion
- (let ((custom-load-recursion t)
- (loads (get symbol 'custom-loads))
- load)
- (while loads
- (setq load (car loads)
- loads (cdr loads))
- (cond ((symbolp load)
- (condition-case nil
- (require load)
- (error nil)))
- ((assoc load load-history))
- (t
- (condition-case nil
- (load-library load)
- (error nil))))))))
-
-(defun custom-load-widget (widget)
- "Load all dependencies for WIDGET."
- (custom-load-symbol (widget-value widget)))
-
-;;; The `custom-variable' Widget.
-
-(defface custom-variable-sample-face '((t (:underline t)))
- "Face used for unpushable variable tags."
- :group 'custom-faces)
-
-(defface custom-variable-button-face '((t (:underline t :bold t)))
- "Face used for pushable variable tags."
- :group 'custom-faces)
-
-(define-widget 'custom-variable 'custom
- "Customize variable."
- :format "%l%v%m%h%a"
- :help-echo "Set or reset this variable."
- :documentation-property 'variable-documentation
- :custom-state nil
- :custom-menu 'custom-variable-menu-create
- :custom-form 'edit
- :value-create 'custom-variable-value-create
- :action 'custom-variable-action
- :custom-set 'custom-variable-set
- :custom-save 'custom-variable-save
- :custom-reset-current 'custom-redraw
- :custom-reset-saved 'custom-variable-reset-saved
- :custom-reset-factory 'custom-variable-reset-factory)
-
-(defun custom-variable-type (symbol)
- "Return a widget suitable for editing the value of SYMBOL.
-If SYMBOL has a `custom-type' property, use that.
-Otherwise, look up symbol in `custom-guess-type-alist'."
- (let* ((type (or (get symbol 'custom-type)
- (and (not (get symbol 'factory-value))
- (custom-guess-type symbol))
- 'sexp))
- (options (get symbol 'custom-options))
- (tmp (if (listp type)
- (copy-list type)
- (list type))))
- (when options
- (widget-put tmp :options options))
- tmp))
-
-(defun custom-variable-value-create (widget)
- "Here is where you edit the variables value."
- (custom-load-widget widget)
- (let* ((buttons (widget-get widget :buttons))
- (children (widget-get widget :children))
- (form (widget-get widget :custom-form))
- (state (widget-get widget :custom-state))
- (symbol (widget-get widget :value))
- (tag (widget-get widget :tag))
- (type (custom-variable-type symbol))
- (conv (widget-convert type))
- (value (if (default-boundp symbol)
- (default-value symbol)
- (widget-get conv :value))))
- ;; If the widget is new, the child determine whether it is hidden.
- (cond (state)
- ((custom-show type value)
- (setq state 'unknown))
- (t
- (setq state 'hidden)))
- ;; If we don't know the state, see if we need to edit it in lisp form.
- (when (eq state 'unknown)
- (unless (widget-apply conv :match value)
- ;; (widget-apply (widget-convert type) :match value)
- (setq form 'lisp)))
- ;; Now we can create the child widget.
- (cond ((eq state 'hidden)
- ;; Indicate hidden value.
- (push (widget-create-child-and-convert
- widget 'item
- :format "%{%t%}: ..."
- :sample-face 'custom-variable-sample-face
- :tag tag
- :parent widget)
- children))
- ((eq form 'lisp)
- ;; In lisp mode edit the saved value when possible.
- (let* ((value (cond ((get symbol 'saved-value)
- (car (get symbol 'saved-value)))
- ((get symbol 'factory-value)
- (car (get symbol 'factory-value)))
- ((default-boundp symbol)
- (custom-quote (default-value symbol)))
- (t
- (custom-quote (widget-get conv :value))))))
- (push (widget-create-child-and-convert
- widget 'sexp
- :button-face 'custom-variable-button-face
- :tag (symbol-name symbol)
- :parent widget
- :value value)
- children)))
- (t
- ;; Edit mode.
- (push (widget-create-child-and-convert
- widget type
- :tag tag
- :button-face 'custom-variable-button-face
- :sample-face 'custom-variable-sample-face
- :value value)
- children)))
- ;; Now update the state.
- (unless (eq (preceding-char) ?\n)
- (widget-insert "\n"))
- (if (eq state 'hidden)
- (widget-put widget :custom-state state)
- (custom-variable-state-set widget))
- (widget-put widget :custom-form form)
- (widget-put widget :buttons buttons)
- (widget-put widget :children children)))
-
-(defun custom-variable-state-set (widget)
- "Set the state of WIDGET."
- (let* ((symbol (widget-value widget))
- (value (if (default-boundp symbol)
- (default-value symbol)
- (widget-get widget :value)))
- tmp
- (state (cond ((setq tmp (get symbol 'customized-value))
- (if (condition-case nil
- (equal value (eval (car tmp)))
- (error nil))
- 'set
- 'changed))
- ((setq tmp (get symbol 'saved-value))
- (if (condition-case nil
- (equal value (eval (car tmp)))
- (error nil))
- 'saved
- 'changed))
- ((setq tmp (get symbol 'factory-value))
- (if (condition-case nil
- (equal value (eval (car tmp)))
- (error nil))
- 'factory
- 'changed))
- (t 'rogue))))
- (widget-put widget :custom-state state)))
-
-(defvar custom-variable-menu
- '(("Edit" . custom-variable-edit)
- ("Edit Lisp" . custom-variable-edit-lisp)
- ("Set" . custom-variable-set)
- ("Save" . custom-variable-save)
- ("Reset to Current" . custom-redraw)
- ("Reset to Saved" . custom-variable-reset-saved)
- ("Reset to Factory Settings" . custom-variable-reset-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."
- (if (eq (widget-get widget :custom-state) 'hidden)
- (progn
- (widget-put widget :custom-state 'unknown)
- (custom-redraw widget))
- (let* ((completion-ignore-case t)
- (answer (widget-choose (custom-unlispify-tag-name
- (widget-get widget :value))
- custom-variable-menu
- event)))
- (if answer
- (funcall answer widget)))))
-
-(defun custom-variable-edit (widget)
- "Edit value of WIDGET."
- (widget-put widget :custom-state 'unknown)
- (widget-put widget :custom-form 'edit)
- (custom-redraw widget))
-
-(defun custom-variable-edit-lisp (widget)
- "Edit the lisp representation of the value of WIDGET."
- (widget-put widget :custom-state 'unknown)
- (widget-put widget :custom-form 'lisp)
- (custom-redraw widget))
-
-(defun custom-variable-set (widget)
- "Set the current value for the variable being edited by WIDGET."
- (let ((form (widget-get widget :custom-form))
- (state (widget-get widget :custom-state))
- (child (car (widget-get widget :children)))
- (symbol (widget-value widget))
- val)
- (cond ((eq state 'hidden)
- (error "Cannot set hidden variable."))
- ((setq val (widget-apply child :validate))
- (goto-char (widget-get val :from))
- (error "%s" (widget-get val :error)))
- ((eq form 'lisp)
- (set-default symbol (eval (setq val (widget-value child))))
- (put symbol 'customized-value (list val)))
- (t
- (set-default symbol (setq val (widget-value child)))
- (put symbol 'customized-value (list (custom-quote val)))))
- (custom-variable-state-set widget)
- (custom-redraw-magic widget)))
-
-(defun custom-variable-save (widget)
- "Set the default value for the variable being edited by WIDGET."
- (let ((form (widget-get widget :custom-form))
- (state (widget-get widget :custom-state))
- (child (car (widget-get widget :children)))
- (symbol (widget-value widget))
- val)
- (cond ((eq state 'hidden)
- (error "Cannot set hidden variable."))
- ((setq val (widget-apply child :validate))
- (goto-char (widget-get val :from))
- (error "%s" (widget-get val :error)))
- ((eq form 'lisp)
- (put symbol 'saved-value (list (widget-value child)))
- (set-default symbol (eval (widget-value child))))
- (t
- (put symbol
- 'saved-value (list (custom-quote (widget-value
- child))))
- (set-default symbol (widget-value child))))
- (put symbol 'customized-value nil)
- (custom-save-all)
- (custom-variable-state-set widget)
- (custom-redraw-magic widget)))
-
-(defun custom-variable-reset-saved (widget)
- "Restore the saved value for the variable being edited by WIDGET."
- (let ((symbol (widget-value widget)))
- (if (get symbol 'saved-value)
- (condition-case nil
- (set-default symbol (eval (car (get symbol 'saved-value))))
- (error nil))
- (error "No saved value for %s" symbol))
- (put symbol 'customized-value nil)
- (widget-put widget :custom-state 'unknown)
- (custom-redraw widget)))
-
-(defun custom-variable-reset-factory (widget)
- "Restore the factory setting for the variable being edited by WIDGET."
- (let ((symbol (widget-value widget)))
- (if (get symbol 'factory-value)
- (set-default symbol (eval (car (get symbol 'factory-value))))
- (error "No factory default for %S" symbol))
- (put symbol 'customized-value nil)
- (when (get symbol 'saved-value)
- (put symbol 'saved-value nil)
- (custom-save-all))
- (widget-put widget :custom-state 'unknown)
- (custom-redraw widget)))
-
-;;; The `custom-face-edit' Widget.
-
-(define-widget 'custom-face-edit 'checklist
- "Edit face attributes."
- :format "%t: %v"
- :tag "Attributes"
- :extra-offset 12
- :button-args '(:help-echo "Control whether this attribute have any effect.")
- :args (mapcar (lambda (att)
- (list 'group
- :inline t
- :sibling-args (widget-get (nth 1 att) :sibling-args)
- (list 'const :format "" :value (nth 0 att))
- (nth 1 att)))
- custom-face-attributes))
-
-;;; The `custom-display' Widget.
-
-(define-widget 'custom-display 'menu-choice
- "Select a display type."
- :tag "Display"
- :value t
- :help-echo "Specify frames where the face attributes should be used."
- :args '((const :tag "all" t)
- (checklist
- :offset 0
- :extra-offset 9
- :args ((group :sibling-args (:help-echo "\
-Only match the specified window systems.")
- (const :format "Type: "
- type)
- (checklist :inline t
- :offset 0
- (const :format "X "
- :sibling-args (:help-echo "\
-The X11 Window System.")
- x)
- (const :format "PM "
- :sibling-args (:help-echo "\
-OS/2 Presentation Manager.")
- pm)
- (const :format "Win32 "
- :sibling-args (:help-echo "\
-Windows NT/95/97.")
- win32)
- (const :format "DOS "
- :sibling-args (:help-echo "\
-Plain MS-DOS.")
- pc)
- (const :format "TTY%n"
- :sibling-args (:help-echo "\
-Plain text terminals.")
- tty)))
- (group :sibling-args (:help-echo "\
-Only match the frames with the specified color support.")
- (const :format "Class: "
- class)
- (checklist :inline t
- :offset 0
- (const :format "Color "
- :sibling-args (:help-echo "\
-Match color frames.")
- color)
- (const :format "Grayscale "
- :sibling-args (:help-echo "\
-Match grayscale frames.")
- grayscale)
- (const :format "Monochrome%n"
- :sibling-args (:help-echo "\
-Match frames with no color support.")
- mono)))
- (group :sibling-args (:help-echo "\
-Only match frames with the specified intensity.")
- (const :format "\
-Background brightness: "
- background)
- (checklist :inline t
- :offset 0
- (const :format "Light "
- :sibling-args (:help-echo "\
-Match frames with light backgrounds.")
- light)
- (const :format "Dark\n"
- :sibling-args (:help-echo "\
-Match frames with dark backgrounds.")
- dark)))))))
-
-;;; The `custom-face' Widget.
-
-(defface custom-face-tag-face '((t (:underline t)))
- "Face used for face tags."
- :group 'custom-faces)
-
-(define-widget 'custom-face 'custom
- "Customize face."
- :format "%l%{%t%}: %s%m%h%a%v"
- :format-handler 'custom-face-format-handler
- :sample-face 'custom-face-tag-face
- :help-echo "Set or reset this face."
- :documentation-property '(lambda (face)
- (face-doc-string face))
- :value-create 'custom-face-value-create
- :action 'custom-face-action
- :custom-form 'selected
- :custom-set 'custom-face-set
- :custom-save 'custom-face-save
- :custom-reset-current 'custom-redraw
- :custom-reset-saved 'custom-face-reset-saved
- :custom-reset-factory 'custom-face-reset-factory
- :custom-menu 'custom-face-menu-create)
-
-(defun custom-face-format-handler (widget escape)
- ;; We recognize extra escape sequences.
- (let (child
- (symbol (widget-get widget :value)))
- (cond ((eq escape ?s)
- (and (string-match "XEmacs" emacs-version)
- ;; XEmacs cannot display initialized faces.
- (not (custom-facep symbol))
- (copy-face 'custom-face-empty symbol))
- (setq child (widget-create-child-and-convert
- widget 'item
- :format "(%{%t%})\n"
- :sample-face symbol
- :tag "sample")))
- (t
- (custom-format-handler widget escape)))
- (when child
- (widget-put widget
- :buttons (cons child (widget-get widget :buttons))))))
-
-(define-widget 'custom-face-all 'editable-list
- "An editable list of display specifications and attributes."
- :entry-format "%i %d %v"
- :insert-button-args '(:help-echo "Insert new display specification here.")
- :append-button-args '(:help-echo "Append new display specification here.")
- :delete-button-args '(:help-echo "Delete this display specification.")
- :args '((group :format "%v" custom-display custom-face-edit)))
-
-(defconst custom-face-all (widget-convert 'custom-face-all)
- "Converted version of the `custom-face-all' widget.")
-
-(define-widget 'custom-display-unselected 'item
- "A display specification that doesn't match the selected display."
- :match 'custom-display-unselected-match)
-
-(defun custom-display-unselected-match (widget value)
- "Non-nil if VALUE is an unselected display specification."
- (and (listp value)
- (eq (length value) 2)
- (not (custom-display-match-frame value (selected-frame)))))
-
-(define-widget 'custom-face-selected 'group
- "Edit the attributes of the selected display in a face specification."
- :args '((repeat :format ""
- :inline t
- (group custom-display-unselected sexp))
- (group (sexp :format "") custom-face-edit)
- (repeat :format ""
- :inline t
- sexp)))
-
-(defconst custom-face-selected (widget-convert 'custom-face-selected)
- "Converted version of the `custom-face-selected' widget.")
-
-(defun custom-face-value-create (widget)
- ;; Create a list of the display specifications.
- (unless (eq (preceding-char) ?\n)
- (insert "\n"))
- (when (not (eq (widget-get widget :custom-state) 'hidden))
- (message "Creating face editor...")
- (custom-load-widget widget)
- (let* ((symbol (widget-value widget))
- (spec (or (get symbol 'saved-face)
- (get symbol 'factory-face)
- ;; Attempt to construct it.
- (list (list t (custom-face-attributes-get
- symbol (selected-frame))))))
- (form (widget-get widget :custom-form))
- (indent (widget-get widget :indent))
- (edit (widget-create-child-and-convert
- widget
- (cond ((and (eq form 'selected)
- (widget-apply custom-face-selected :match spec))
- (when indent (insert-char ?\ indent))
- 'custom-face-selected)
- ((and (not (eq form 'lisp))
- (widget-apply custom-face-all :match spec))
- 'custom-face-all)
- (t
- (when indent (insert-char ?\ indent))
- 'sexp))
- :value spec)))
- (custom-face-state-set widget)
- (widget-put widget :children (list edit)))
- (message "Creating face editor...done")))
-
-(defvar custom-face-menu
- '(("Edit Selected" . custom-face-edit-selected)
- ("Edit All" . custom-face-edit-all)
- ("Edit Lisp" . custom-face-edit-lisp)
- ("Set" . custom-face-set)
- ("Save" . custom-face-save)
- ("Reset to Saved" . custom-face-reset-saved)
- ("Reset to Factory Setting" . custom-face-reset-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-edit-selected (widget)
- "Edit selected attributes of the value of WIDGET."
- (widget-put widget :custom-state 'unknown)
- (widget-put widget :custom-form 'selected)
- (custom-redraw widget))
-
-(defun custom-face-edit-all (widget)
- "Edit all attributes of the value of WIDGET."
- (widget-put widget :custom-state 'unknown)
- (widget-put widget :custom-form 'all)
- (custom-redraw widget))
-
-(defun custom-face-edit-lisp (widget)
- "Edit the lisp representation of the value of WIDGET."
- (widget-put widget :custom-state 'unknown)
- (widget-put widget :custom-form 'lisp)
- (custom-redraw widget))
-
-(defun custom-face-state-set (widget)
- "Set the state of WIDGET."
- (let ((symbol (widget-value widget)))
- (widget-put widget :custom-state (cond ((get symbol 'customized-face)
- 'set)
- ((get symbol 'saved-face)
- 'saved)
- ((get symbol 'factory-face)
- 'factory)
- (t
- 'rogue)))))
-
-(defun custom-face-action (widget &optional event)
- "Show the menu for `custom-face' WIDGET.
-Optional EVENT is the location for the menu."
- (if (eq (widget-get widget :custom-state) 'hidden)
- (progn
- (widget-put widget :custom-state 'unknown)
- (custom-redraw widget))
- (let* ((completion-ignore-case t)
- (symbol (widget-get widget :value))
- (answer (widget-choose (custom-unlispify-tag-name symbol)
- custom-face-menu event)))
- (if answer
- (funcall answer widget)))))
-
-(defun custom-face-set (widget)
- "Make the face attributes in WIDGET take effect."
- (let* ((symbol (widget-value widget))
- (child (car (widget-get widget :children)))
- (value (widget-value child)))
- (put symbol 'customized-face value)
- (when (fboundp 'copy-face)
- (copy-face 'custom-face-empty symbol))
- (custom-face-display-set symbol value)
- (custom-face-state-set widget)
- (custom-redraw-magic widget)))
-
-(defun custom-face-save (widget)
- "Make the face attributes in WIDGET default."
- (let* ((symbol (widget-value widget))
- (child (car (widget-get widget :children)))
- (value (widget-value child)))
- (when (fboundp 'copy-face)
- (copy-face 'custom-face-empty symbol))
- (custom-face-display-set symbol value)
- (put symbol 'saved-face value)
- (put symbol 'customized-face nil)
- (custom-face-state-set widget)
- (custom-redraw-magic widget)))
-
-(defun custom-face-reset-saved (widget)
- "Restore WIDGET to the face's default attributes."
- (let* ((symbol (widget-value widget))
- (child (car (widget-get widget :children)))
- (value (get symbol 'saved-face)))
- (unless value
- (error "No saved value for this face"))
- (put symbol 'customized-face nil)
- (when (fboundp 'copy-face)
- (copy-face 'custom-face-empty symbol))
- (custom-face-display-set symbol value)
- (widget-value-set child value)
- (custom-face-state-set widget)
- (custom-redraw-magic widget)))
-
-(defun custom-face-reset-factory (widget)
- "Restore WIDGET to the face's factory settings."
- (let* ((symbol (widget-value widget))
- (child (car (widget-get widget :children)))
- (value (get symbol 'factory-face)))
- (unless value
- (error "No factory default for this face"))
- (put symbol 'customized-face nil)
- (when (get symbol 'saved-face)
- (put symbol 'saved-face nil)
- (custom-save-all))
- (when (fboundp 'copy-face)
- (copy-face 'custom-face-empty symbol))
- (custom-face-display-set symbol value)
- (widget-value-set child value)
- (custom-face-state-set widget)
- (custom-redraw-magic widget)))
-
-;;; The `face' Widget.
-
-(define-widget 'face 'default
- "Select and customize a face."
- :convert-widget 'widget-item-convert-widget
- :format "%[%t%]: %v"
- :tag "Face"
- :value 'default
- :value-create 'widget-face-value-create
- :value-delete 'widget-face-value-delete
- :value-get 'widget-item-value-get
- :validate 'widget-editable-list-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-child-and-convert
- widget 'custom-face
- :format "%t %s%m%h%v"
- :custom-level nil
- :value symbol)))
- (custom-magic-reset child)
- (setq custom-options (cons child custom-options))
- (widget-put widget :children (list child))))
-
-(defun widget-face-value-delete (widget)
- ;; Remove the child from the options.
- (let ((child (car (widget-get widget :children))))
- (setq custom-options (delq child custom-options))
- (widget-children-value-delete widget)))
-
-(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-apply widget :notify widget event)
- (widget-setup))))
-
-;;; The `hook' Widget.
-
-(define-widget 'hook 'list
- "A emacs lisp hook"
- :convert-widget 'custom-hook-convert-widget
- :tag "Hook")
-
-(defun custom-hook-convert-widget (widget)
- ;; Handle `:custom-options'.
- (let* ((options (widget-get widget :options))
- (other `(editable-list :inline t
- :entry-format "%i %d%v"
- (function :format " %v")))
- (args (if options
- (list `(checklist :inline t
- ,@(mapcar (lambda (entry)
- `(function-item ,entry))
- options))
- other)
- (list other))))
- (widget-put widget :args args)
- widget))
-
-;;; The `custom-group' Widget.
-
-(defcustom custom-group-tag-faces '(custom-group-tag-face-1)
- ;; In XEmacs, this ought to play games with font size.
- "Face used for group tags.
-The first member is used for level 1 groups, the second for level 2,
-and so forth. The remaining group tags are shown with
-`custom-group-tag-face'."
- :type '(repeat face)
- :group 'custom-faces)
-
-(defface custom-group-tag-face-1 '((((class color)
- (background dark))
- (:foreground "pink" :underline t))
- (((class color)
- (background light))
- (:foreground "red" :underline t))
- (t (:underline t)))
- "Face used for group tags.")
-
-(defface custom-group-tag-face '((((class color)
- (background dark))
- (:foreground "light blue" :underline t))
- (((class color)
- (background light))
- (:foreground "blue" :underline t))
- (t (:underline t)))
- "Face used for low level group tags."
- :group 'custom-faces)
-
-(define-widget 'custom-group 'custom
- "Customize group."
- :format "%l%{%t%}:%L\n%m%h%a%v"
- :sample-face-get 'custom-group-sample-face-get
- :documentation-property 'group-documentation
- :help-echo "Set or reset all members of this group."
- :value-create 'custom-group-value-create
- :action 'custom-group-action
- :custom-set 'custom-group-set
- :custom-save 'custom-group-save
- :custom-reset-current 'custom-group-reset-current
- :custom-reset-saved 'custom-group-reset-saved
- :custom-reset-factory 'custom-group-reset-factory
- :custom-menu 'custom-group-menu-create)
-
-(defun custom-group-sample-face-get (widget)
- ;; Use :sample-face.
- (or (nth (1- (widget-get widget :custom-level)) custom-group-tag-faces)
- 'custom-group-tag-face))
-
-(defun custom-group-value-create (widget)
- (let ((state (widget-get widget :custom-state)))
- (unless (eq state 'hidden)
- (message "Creating group...")
- (custom-load-widget widget)
- (let* ((level (widget-get widget :custom-level))
- (symbol (widget-value widget))
- (members (get symbol 'custom-group))
- (prefixes (widget-get widget :custom-prefixes))
- (custom-prefix-list (custom-prefix-add symbol prefixes))
- (length (length members))
- (count 0)
- (children (mapcar (lambda (entry)
- (widget-insert "\n")
- (message "Creating group members... %2d%%"
- (/ (* 100.0 count) length))
- (setq count (1+ count))
- (prog1
- (widget-create-child-and-convert
- widget (nth 1 entry)
- :group widget
- :tag (custom-unlispify-tag-name
- (nth 0 entry))
- :custom-prefixes custom-prefix-list
- :custom-level (1+ level)
- :value (nth 0 entry))
- (unless (eq (preceding-char) ?\n)
- (widget-insert "\n"))))
- members)))
- (message "Creating group magic...")
- (mapcar 'custom-magic-reset children)
- (message "Creating group state...")
- (widget-put widget :children children)
- (custom-group-state-update widget)
- (message "Creating group... done")))))
-
-(defvar custom-group-menu
- '(("Set" . custom-group-set)
- ("Save" . custom-group-save)
- ("Reset to Current" . custom-group-reset-current)
- ("Reset to Saved" . custom-group-reset-saved)
- ("Reset to Factory" . custom-group-reset-factory))
- "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."
- (if (eq (widget-get widget :custom-state) 'hidden)
- (progn
- (widget-put widget :custom-state 'unknown)
- (custom-redraw widget))
- (let* ((completion-ignore-case t)
- (answer (widget-choose (custom-unlispify-tag-name
- (widget-get widget :value))
- custom-group-menu
- event)))
- (if answer
- (funcall answer widget)))))
-
-(defun custom-group-set (widget)
- "Set changes in all modified group members."
- (let ((children (widget-get widget :children)))
- (mapcar (lambda (child)
- (when (eq (widget-get child :custom-state) 'modified)
- (widget-apply child :custom-set)))
- children )))
-
-(defun custom-group-save (widget)
- "Save all modified group members."
- (let ((children (widget-get widget :children)))
- (mapcar (lambda (child)
- (when (memq (widget-get child :custom-state) '(modified set))
- (widget-apply child :custom-save)))
- children )))
-
-(defun custom-group-reset-current (widget)
- "Reset all modified group members."
- (let ((children (widget-get widget :children)))
- (mapcar (lambda (child)
- (when (eq (widget-get child :custom-state) 'modified)
- (widget-apply child :custom-reset-current)))
- children )))
-
-(defun custom-group-reset-saved (widget)
- "Reset all modified or set group members."
- (let ((children (widget-get widget :children)))
- (mapcar (lambda (child)
- (when (memq (widget-get child :custom-state) '(modified set))
- (widget-apply child :custom-reset-saved)))
- children )))
-
-(defun custom-group-reset-factory (widget)
- "Reset all modified, set, or saved group members."
- (let ((children (widget-get widget :children)))
- (mapcar (lambda (child)
- (when (memq (widget-get child :custom-state)
- '(modified set saved))
- (widget-apply child :custom-reset-factory)))
- children )))
-
-(defun custom-group-state-update (widget)
- "Update magic."
- (unless (eq (widget-get widget :custom-state) 'hidden)
- (let* ((children (widget-get widget :children))
- (states (mapcar (lambda (child)
- (widget-get child :custom-state))
- children))
- (magics custom-magic-alist)
- (found 'factory))
- (while magics
- (let ((magic (car (car magics))))
- (if (and (not (eq magic 'hidden))
- (memq magic states))
- (setq found magic
- magics nil)
- (setq magics (cdr magics)))))
- (widget-put widget :custom-state found)))
- (custom-magic-reset widget))
-
-;;; The `custom-save-all' Function.
-
-(defcustom custom-file "~/.emacs"
- "File used for storing customization information.
-If you change this from the default \"~/.emacs\" you need to
-explicitly load that file for the settings to take effect."
- :type 'file
- :group 'customize)
-
-(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))
- (if (or (get symbol 'factory-value)
- (and (not (boundp symbol))
- (not (get symbol 'force-value))))
- (princ ")")
- (princ " t)"))))))
- (princ ")")
- (unless (looking-at "\n")
- (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")
- (let ((value (get 'default 'saved-face)))
- ;; The default face must be first, since it affects the others.
- (when value
- (princ "\n '(default ")
- (prin1 value)
- (if (or (get 'default 'factory-face)
- (and (not (custom-facep 'default))
- (not (get 'default 'force-face))))
- (princ ")")
- (princ " t)"))))
- (mapatoms (lambda (symbol)
- (let ((value (get symbol 'saved-face)))
- (when (and (not (eq symbol 'default))
- ;; Don't print default face here.
- value)
- (princ "\n '(")
- (princ symbol)
- (princ " ")
- (prin1 value)
- (if (or (get symbol 'factory-face)
- (and (not (custom-facep symbol))
- (not (get symbol 'force-face))))
- (princ ")")
- (princ " t)"))))))
- (princ ")")
- (unless (looking-at "\n")
- (princ "\n")))))
-
-;;;###autoload
-(defun custom-save-all ()
- "Save all customizations in `custom-file'."
- (custom-save-variables)
- (custom-save-faces)
- (save-excursion
- (set-buffer (find-file-noselect custom-file))
- (save-buffer)))
-
-;;; The Customize Menu.
-
-;;; Menu support
-
-(unless (string-match "XEmacs" emacs-version)
- (defconst custom-help-menu '("Customize"
- ["Update menu..." custom-menu-update t]
- ["Group..." customize t]
- ["Variable..." customize-variable t]
- ["Face..." customize-face t]
- ["Saved..." customize-customized t]
- ["Apropos..." customize-apropos t])
- ;; This menu should be identical to the one defined in `menu-bar.el'.
- "Customize menu")
-
- (defun custom-menu-reset ()
- "Reset customize menu."
- (remove-hook 'custom-define-hook 'custom-menu-reset)
- (define-key global-map [menu-bar help-menu customize-menu]
- (cons (car custom-help-menu)
- (easy-menu-create-keymaps (car custom-help-menu)
- (cdr custom-help-menu)))))
-
- (defun custom-menu-update (event)
- "Update customize menu."
- (interactive "e")
- (add-hook 'custom-define-hook 'custom-menu-reset)
- (let* ((emacs (widget-apply '(custom-group) :custom-menu 'emacs))
- (menu `(,(car custom-help-menu)
- ,emacs
- ,@(cdr (cdr custom-help-menu)))))
- (let ((map (easy-menu-create-keymaps (car menu) (cdr menu))))
- (define-key global-map [menu-bar help-menu customize-menu]
- (cons (car menu) map)))))
-
- (defcustom custom-menu-nesting 2
- "Maximum nesting in custom menus."
- :type 'integer
- :group 'customize))
-
-(defun custom-face-menu-create (widget symbol)
- "Ignoring WIDGET, create a menu entry for customization face SYMBOL."
- (vector (custom-unlispify-menu-entry symbol)
- `(custom-buffer-create '((,symbol custom-face)))
- t))
-
-(defun custom-variable-menu-create (widget symbol)
- "Ignoring WIDGET, create a menu entry for customization variable SYMBOL."
- (let ((type (get symbol 'custom-type)))
- (unless (listp type)
- (setq type (list type)))
- (if (and type (widget-get type :custom-menu))
- (widget-apply type :custom-menu symbol)
- (vector (custom-unlispify-menu-entry symbol)
- `(custom-buffer-create '((,symbol custom-variable)))
- t))))
-
-;; Add checkboxes to boolean variable entries.
-(widget-put (get 'boolean 'widget-type)
- :custom-menu (lambda (widget symbol)
- (vector (custom-unlispify-menu-entry symbol)
- `(custom-buffer-create
- '((,symbol custom-variable)))
- ':style 'toggle
- ':selected symbol)))
-
-(if (string-match "XEmacs" emacs-version)
- ;; XEmacs can create menus dynamically.
- (defun custom-group-menu-create (widget symbol)
- "Ignoring WIDGET, create a menu entry for customization group SYMBOL."
- `( ,(custom-unlispify-menu-entry symbol t)
- :filter (lambda (&rest junk)
- (cdr (custom-menu-create ',symbol)))))
- ;; But emacs can't.
- (defun custom-group-menu-create (widget symbol)
- "Ignoring WIDGET, create a menu entry for customization group SYMBOL."
- ;; Limit the nesting.
- (let ((custom-menu-nesting (1- custom-menu-nesting)))
- (custom-menu-create symbol))))
-
-;;;###autoload
-(defun custom-menu-create (symbol &optional name)
- "Create menu for customization group SYMBOL.
-If optional NAME is given, use that as the name of the menu.
-Otherwise make up a name from SYMBOL.
-The menu is in a format applicable to `easy-menu-define'."
- (unless name
- (setq name (custom-unlispify-menu-entry symbol)))
- (let ((item (vector name
- `(custom-buffer-create '((,symbol custom-group)))
- t)))
- (if (and (or (not (boundp 'custom-menu-nesting))
- (>= custom-menu-nesting 0))
- (< (length (get symbol 'custom-group)) widget-menu-max-size))
- (let ((custom-prefix-list (custom-prefix-add symbol
- custom-prefix-list)))
- (custom-load-symbol symbol)
- `(,(custom-unlispify-menu-entry symbol t)
- ,item
- "--"
- ,@(mapcar (lambda (entry)
- (widget-apply (if (listp (nth 1 entry))
- (nth 1 entry)
- (list (nth 1 entry)))
- :custom-menu (nth 0 entry)))
- (get symbol 'custom-group))))
- item)))
-
-;;;###autoload
-(defun customize-menu-create (symbol)
- "Return a customize menu for customization group SYMBOL.
-The format is suitable for use with `easy-menu-define'."
- (if (string-match "XEmacs" emacs-version)
- ;; We can delay it under XEmacs.
- `("Customize"
- :filter (lambda (&rest junk)
- (cdr (custom-menu-create ',symbol))))
- ;; But we must create it now under Emacs.
- (cons "Customize" (cdr (custom-menu-create symbol)))))
-
-;;; The Custom Mode.
-
-(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)
- (define-key custom-mode-map "q" 'bury-buffer))
-
-(easy-menu-define custom-mode-customize-menu
- custom-mode-map
- "Menu used in customization buffers."
- (customize-menu-create 'customize))
-
-(easy-menu-define custom-mode-menu
- custom-mode-map
- "Menu used in customization buffers."
- `("Custom"
- ["Set" custom-set t]
- ["Save" custom-save t]
- ["Reset to Current" custom-reset-current t]
- ["Reset to Saved" custom-reset-saved t]
- ["Reset to Factory Settings" custom-reset-factory t]
- ["Info" (Info-goto-node "(custom)The Customization Buffer") t]))
-
-(defcustom custom-mode-hook nil
- "Hook called when entering custom-mode."
- :type 'hook
- :group 'customize)
-
-(defun custom-mode ()
- "Major mode for editing customization buffers.
-
-The following commands are available:
-
-Move to next button or editable field. \\[widget-forward]
-Move to previous button or editable field. \\[widget-backward]
-Activate button under the mouse pointer. \\[widget-button-click]
-Activate button under point. \\[widget-button-press]
-Set all modifications. \\[custom-set]
-Make all modifications default. \\[custom-save]
-Reset all modified options. \\[custom-reset-current]
-Reset all modified or set options. \\[custom-reset-saved]
-Reset all options. \\[custom-reset-factory]
-
-Entry to this mode calls the value of `custom-mode-hook'
-if that value is non-nil."
- (kill-all-local-variables)
- (setq major-mode 'custom-mode
- mode-name "Custom")
- (use-local-map custom-mode-map)
- (easy-menu-add custom-mode-customize-menu)
- (easy-menu-add custom-mode-menu)
- (make-local-variable 'custom-options)
- (run-hooks 'custom-mode-hook))
-
-;;; The End.
-
-(provide 'cus-edit)
-
-;; cus-edit.el ends here
+++ /dev/null
-;;; cus-face.el -- XEmacs specific custom support.
-;;
-;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
-;;
-;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
-;; Keywords: help, faces
-;; Version: 1.82
-;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
-
-;;; Commentary:
-;;
-;; See `custom.el'.
-
-;;; Code:
-
-(require 'custom)
-
-(eval-and-compile (require 'cl))
-
-;;; Compatibility.
-
-(if (string-match "XEmacs" emacs-version)
- (defun custom-face-background (face &optional frame)
- ;; Specifiers suck!
- "Return the background color name of face FACE, or nil if unspecified."
- (color-instance-name (specifier-instance (face-background face) frame)))
- (defalias 'custom-face-background 'face-background))
-
-(if (string-match "XEmacs" emacs-version)
- (defun custom-face-foreground (face &optional frame)
- ;; Specifiers suck!
- "Return the background color name of face FACE, or nil if unspecified."
- (color-instance-name (specifier-instance (face-foreground face) frame)))
- (defalias 'custom-face-foreground 'face-foreground))
-
-(defalias 'custom-face-font-name (if (string-match "XEmacs" emacs-version)
- 'face-font-name
- 'face-font))
-
-(eval-and-compile
- (unless (fboundp 'frame-property)
- ;; XEmacs function missing in Emacs.
- (defun frame-property (frame property &optional default)
- "Return FRAME's value for property PROPERTY."
- (or (cdr (assq property (frame-parameters frame)))
- default)))
-
- (unless (fboundp 'face-doc-string)
- ;; XEmacs function missing in Emacs.
- (defun face-doc-string (face)
- "Get the documentation string for FACE."
- (get face 'face-documentation)))
-
- (unless (fboundp 'set-face-doc-string)
- ;; XEmacs function missing in Emacs.
- (defun set-face-doc-string (face string)
- "Set the documentation string for FACE to STRING."
- (put face 'face-documentation string))))
-
-(unless (fboundp 'x-color-values)
- ;; Emacs function missing in XEmacs 19.14.
- (defun x-color-values (color &optional frame)
- "Return a description of the color named COLOR on frame FRAME.
-The value is a list of integer RGB values--(RED GREEN BLUE).
-These values appear to range from 0 to 65280 or 65535, depending
-on the system; white is (65280 65280 65280) or (65535 65535 65535).
-If FRAME is omitted or nil, use the selected frame."
- (color-instance-rgb-components (make-color-instance color))))
-
-;; XEmacs and Emacs have different definitions of `facep'.
-;; The Emacs definition is the useful one, so emulate that.
-(cond ((not (fboundp 'facep))
- (defun custom-facep (face)
- "No faces"
- nil))
- ((string-match "XEmacs" emacs-version)
- (defalias 'custom-facep 'find-face))
- (t
- (defalias 'custom-facep 'facep)))
-
-(unless (fboundp 'make-empty-face)
- ;; This should be moved to `faces.el'.
- (if (string-match "XEmacs" emacs-version)
- ;; Give up for old XEmacs pre 19.15/20.1.
- (defalias 'make-empty-face 'make-face)
- ;; Define for Emacs pre 19.35.
- (defun make-empty-face (name)
- "Define a new FACE on all frames, ignoring X resources."
- (interactive "SMake face: ")
- (or (internal-find-face name)
- (let ((face (make-vector 8 nil)))
- (aset face 0 'face)
- (aset face 1 name)
- (let* ((frames (frame-list))
- (inhibit-quit t)
- (id (internal-next-face-id)))
- (make-face-internal id)
- (aset face 2 id)
- (while frames
- (set-frame-face-alist (car frames)
- (cons (cons name (copy-sequence face))
- (frame-face-alist (car frames))))
- (setq frames (cdr frames)))
- (setq global-face-data (cons (cons name face) global-face-data)))
- ;; add to menu
- (if (fboundp 'facemenu-add-new-face)
- (facemenu-add-new-face name))
- face))
- name)))
-
-(defcustom initialize-face-resources t
- "If non nil, allow X resources to initialize face properties.
-This only affects faces declared with `defface', and only NT or X11 frames."
- :group 'customize
- :type 'boolean)
-
-(cond ((fboundp 'initialize-face-resources)
- ;; Already bound, do nothing.
- )
- ((fboundp 'make-face-x-resource-internal)
- ;; Emacs or new XEmacs.
- (defun initialize-face-resources (face &optional frame)
- "Initialize face according to the X11 resources.
-This might overwrite existing face properties.
-Does nothing when the variable initialize-face-resources is nil."
- (when initialize-face-resources
- (make-face-x-resource-internal face frame t))))
- (t
- ;; Too hard to do right on XEmacs.
- (defalias 'initialize-face-resources 'ignore)))
-
-;;(if (string-match "XEmacs" emacs-version)
-;; ;; Xemacs.
-;; (defun custom-invert-face (face &optional frame)
-;; "Swap the foreground and background colors of face FACE.
-;;If the colors are not specified in the face, use the default colors."
-;; (interactive (list (read-face-name "Reverse face: ")))
-;; (let ((fg (color-name (face-foreground face frame) frame))
-;; (bg (color-name (face-background face frame) frame)))
-;; (set-face-foreground face bg frame)
-;; (set-face-background face fg frame)))
-;; ;; Emacs.
-;; (defun custom-invert-face (face &optional frame)
-;; "Swap the foreground and background colors of face FACE.
-;;If the colors are not specified in the face, use the default colors."
-;; (interactive (list (read-face-name "Reverse face: ")))
-;; (let ((fg (or (face-foreground face frame)
-;; (face-foreground 'default frame)
-;; (frame-property (or frame (selected-frame))
-;; 'foreground-color)
-;; "black"))
-;; (bg (or (face-background face frame)
-;; (face-background 'default frame)
-;; (frame-property (or frame (selected-frame))
-;; 'background-color)
-;; "white")))
-;; (set-face-foreground face bg frame)
-;; (set-face-background face fg frame))))
-
-(defcustom custom-background-mode nil
- "The brightness of the background.
-Set this to the symbol dark if your background color is dark, light if
-your background is light, or nil (default) if you want Emacs to
-examine the brightness for you."
- :group 'customize
- :type '(choice (choice-item dark)
- (choice-item light)
- (choice-item :tag "default" nil)))
-
-(defun custom-background-mode (frame)
- "Kludge to detect background mode for FRAME."
- (let* ((bg-resource
- (condition-case ()
- (x-get-resource ".backgroundMode" "BackgroundMode" 'string)
- (error nil)))
- color
- (mode (cond (bg-resource
- (intern (downcase bg-resource)))
- ((and (setq color (condition-case ()
- (or (frame-property
- frame
- 'background-color)
- (custom-face-background
- 'default))
- (error nil)))
- (or (string-match "XEmacs" emacs-version)
- window-system)
- (< (apply '+ (x-color-values color))
- (/ (apply '+ (x-color-values "white"))
- 3)))
- 'dark)
- (t 'light))))
- (modify-frame-parameters frame (list (cons 'background-mode mode)))
- mode))
-
-(eval-and-compile
- (if (string-match "XEmacs" emacs-version)
- ;; XEmacs.
- (defun custom-extract-frame-properties (frame)
- "Return a plist with the frame properties of FRAME used by custom."
- (list 'type (device-type (frame-device frame))
- 'class (device-class (frame-device frame))
- 'background (or custom-background-mode
- (frame-property frame
- 'background-mode)
- (custom-background-mode frame))))
- ;; Emacs.
- (defun custom-extract-frame-properties (frame)
- "Return a plist with the frame properties of FRAME used by custom."
- (list 'type window-system
- 'class (frame-property frame 'display-type)
- 'background (or custom-background-mode
- (frame-property frame 'background-mode)
- (custom-background-mode frame))))))
-
-;;; Declaring a face.
-
-;;;###autoload
-(defun custom-declare-face (face spec doc &rest args)
- "Like `defface', but FACE is evaluated as a normal argument."
- (when (fboundp 'load-gc)
- ;; This should be allowed, somehow.
- (error "Attempt to declare a face during dump"))
- (unless (get face 'factory-face)
- (put face 'factory-face spec)
- (when (fboundp 'facep)
- (unless (custom-facep face)
- ;; If the user has already created the face, respect that.
- (let ((value (or (get face 'saved-face) spec))
- (frames (custom-relevant-frames))
- frame)
- ;; Create global face.
- (make-empty-face face)
- (custom-face-display-set face value)
- ;; Create frame local faces
- (while frames
- (setq frame (car frames)
- frames (cdr frames))
- (custom-face-display-set face value frame))
- (initialize-face-resources face))))
- (when (and doc (null (face-doc-string face)))
- (set-face-doc-string face doc))
- (custom-handle-all-keywords face args 'custom-face)
- (run-hooks 'custom-define-hook))
- face)
-
-;;; Font Attributes.
-
-(defconst custom-face-attributes
- '((:bold (toggle :format "Bold: %[%v%]\n"
- :help-echo "Control whether a bold font should be used.")
- custom-set-face-bold
- custom-face-bold)
- (:italic (toggle :format "Italic: %[%v%]\n"
- :help-echo "\
-Control whether an italic font should be used.")
- custom-set-face-italic
- custom-face-italic)
- (:underline (toggle :format "Underline: %[%v%]\n"
- :help-echo "\
-Control whether the text should be underlined.")
- set-face-underline-p
- face-underline-p)
- (:foreground (color :tag "Foreground"
- :value "black"
- :help-echo "Set foreground color.")
- set-face-foreground
- custom-face-foreground)
- (:background (color :tag "Background"
- :value "white"
- :help-echo "Set background color.")
- set-face-background
- custom-face-background)
- ;; (:invert (const :format "Invert Face\n"
- ;; :sibling-args (:help-echo "
- ;;Reverse the foreground and background color.
- ;;If you haven't specified them for the face, the default colors will be used.")
- ;; t)
- ;; (lambda (face value &optional frame)
- ;; ;; We don't use VALUE.
- ;; (custom-invert-face face frame)))
- (:stipple (editable-field :format "Stipple: %v"
- :help-echo "Name of background bitmap file.")
- set-face-stipple custom-face-stipple))
- "Alist of face attributes.
-
-The elements are of the form (KEY TYPE SET GET) 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, and GET is a function for getiing 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.
-
-The GET function should take two arguments, the face to examine, and
-optonally the frame where the face should be examined.")
-
-(defun custom-face-attributes-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)))
- (condition-case nil
- (funcall fun face value frame)
- (error nil)))))
-
-(defun custom-face-attributes-get (face frame)
- "For FACE on FRAME get the attributes [KEYWORD VALUE]....
-Each keyword should be listed in `custom-face-attributes'.
-
-If FRAME is nil, use the default face."
- (condition-case nil
- ;; Attempt to get `font.el' from w3.
- (require 'font)
- (error nil))
- (let ((atts custom-face-attributes)
- att result get)
- (while atts
- (setq att (car atts)
- atts (cdr atts)
- get (nth 3 att))
- (when get
- (let ((answer (funcall get face frame)))
- (unless (equal answer (funcall get 'default frame))
- (when (widget-apply (nth 1 att) :match answer)
- (setq result (cons (nth 0 att) (cons answer result))))))))
- result))
-
-(defun custom-set-face-bold (face value &optional frame)
- "Set the bold property of FACE to VALUE."
- (if value
- (make-face-bold face frame)
- (make-face-unbold face frame)))
-
-(defun custom-face-bold (face &rest args)
- "Return non-nil if the font of FACE is bold."
- (let* ((font (apply 'custom-face-font-name face args))
- (fontobj (font-create-object font)))
- (font-bold-p fontobj)))
-
-(defun custom-set-face-italic (face value &optional frame)
- "Set the italic property of FACE to VALUE."
- (if value
- (make-face-italic face frame)
- (make-face-unitalic face frame)))
-
-(defun custom-face-italic (face &rest args)
- "Return non-nil if the font of FACE is italic."
- (let* ((font (apply 'custom-face-font-name face args))
- (fontobj (font-create-object font)))
- (font-italic-p fontobj)))
-
-(defun custom-face-stipple (face &rest args)
- "Return the name of the stipple file used for FACE."
- (if (string-match "XEmacs" emacs-version)
- (let ((image (apply 'specifier-instance
- (face-background-pixmap face) args)))
- (when image
- (image-instance-file-name image)))
- (apply 'face-stipple face args)))
-
-(when (string-match "XEmacs" emacs-version)
- ;; Support for special XEmacs font attributes.
- (autoload 'font-create-object "font" nil)
-
- (defun custom-set-face-font-size (face size &rest args)
- "Set the font of FACE to SIZE"
- (let* ((font (apply 'custom-face-font-name face args))
- (fontobj (font-create-object font)))
- (set-font-size fontobj size)
- (apply 'font-set-face-font face fontobj args)))
-
- (defun custom-face-font-size (face &rest args)
- "Return the size of the font of FACE as a string."
- (let* ((font (apply 'custom-face-font-name face args))
- (fontobj (font-create-object font)))
- (format "%d" (font-size fontobj))))
-
- (defun custom-set-face-font-family (face family &rest args)
- "Set the font of FACE to FAMILY."
- (let* ((font (apply 'custom-face-font-name face args))
- (fontobj (font-create-object font)))
- (set-font-family fontobj family)
- (apply 'font-set-face-font face fontobj args)))
-
- (defun custom-face-font-family (face &rest args)
- "Return the name of the font family of FACE."
- (let* ((font (apply 'custom-face-font-name face args))
- (fontobj (font-create-object font)))
- (font-family fontobj)))
-
- (setq custom-face-attributes
- (append '((:family (editable-field :format "Font Family: %v"
- :help-echo "\
-Name of font family to use (e.g. times).")
- custom-set-face-font-family
- custom-face-font-family)
- (:size (editable-field :format "Size: %v"
- :help-echo "\
-Text size (e.g. 9pt or 2mm).")
- custom-set-face-font-size
- custom-face-font-size)
- (:strikethru (toggle :format "Strikethru: %[%v%]\n"
- :help-echo "\
-Control whether the text should be strikethru.")
- set-face-strikethru-p
- face-strikethru-p))
- custom-face-attributes)))
-
-;;; Frames.
-
-(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."
- (when (fboundp 'make-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)
- ;; Avoid creating frame local duplicates of the global face.
- (unless (and frame (eq display (get face 'custom-face-display)))
- (apply 'custom-face-attributes-set face frame atts))
- (unless frame
- (put face 'custom-face-display display))
- (setq spec nil))))))
-
-(defvar custom-default-frame-properties nil
- "The frame properties used for the global faces.
-Frames who doesn't match these propertiess should have frame local faces.
-The value should be nil, if uninitialized, or a plist otherwise.
-See `defface' for a list of valid keys and values for the plist.")
-
-(defun custom-get-frame-properties (&optional frame)
- "Return a plist with the frame properties of FRAME used by custom.
-If FRAME is nil, return the default frame properties."
- (cond (frame
- ;; Try to get from cache.
- (let ((cache (frame-property frame 'custom-properties)))
- (unless cache
- ;; Oh well, get it then.
- (setq cache (custom-extract-frame-properties frame))
- ;; and cache it...
- (modify-frame-parameters frame
- (list (cons 'custom-properties cache))))
- cache))
- (custom-default-frame-properties)
- (t
- (setq custom-default-frame-properties
- (custom-extract-frame-properties (selected-frame))))))
-
-(defun custom-display-match-frame (display frame)
- "Non-nil iff DISPLAY matches FRAME.
-If FRAME is nil, the current FRAME is used."
- ;; This is a kludge to get started, we really should use specifiers!
- (if (eq display t)
- t
- (let* ((props (custom-get-frame-properties frame))
- (type (plist-get props 'type))
- (class (plist-get props 'class))
- (background (plist-get props 'background))
- (match t)
- (entries display)
- entry req options)
- (while (and entries match)
- (setq entry (car entries)
- entries (cdr entries)
- req (car entry)
- options (cdr entry)
- match (cond ((eq req 'type)
- (memq type options))
- ((eq req 'class)
- (memq class options))
- ((eq req 'background)
- (memq background options))
- (t
- (error "Unknown req `%S' with options `%S'"
- req options)))))
- match)))
-
-(defun custom-relevant-frames ()
- "List of frames whose custom properties differ from the default."
- (let ((relevant nil)
- (default (custom-get-frame-properties))
- (frames (frame-list))
- frame)
- (while frames
- (setq frame (car frames)
- frames (cdr frames))
- (unless (equal default (custom-get-frame-properties frame))
- (push frame relevant)))
- relevant))
-
-(defun custom-initialize-faces (&optional frame)
- "Initialize all custom faces for FRAME.
-If FRAME is nil or omitted, initialize them for all frames."
- (mapcar (lambda (symbol)
- (let ((spec (or (get symbol 'saved-face)
- (get symbol 'factory-face))))
- (when spec
- (custom-face-display-set symbol spec frame)
- (initialize-face-resources symbol frame))))
- (face-list)))
-
-;;;###autoload
-(defun custom-initialize-frame (&optional frame)
- "Initialize local faces for FRAME if necessary.
-If FRAME is missing or nil, the first member of (frame-list) is used."
- (unless frame
- (setq frame (car (frame-list))))
- (unless (equal (custom-get-frame-properties)
- (custom-get-frame-properties frame))
- (custom-initialize-faces frame)))
-
-;;; Initializing.
-
-(and (fboundp 'make-face)
- (make-face 'custom-face-empty))
-
-;;;###autoload
-(defun custom-set-faces (&rest args)
- "Initialize faces according to user preferences.
-The arguments should be a list where each entry has the form:
-
- (FACE SPEC [NOW])
-
-SPEC will be stored as the saved value for FACE. If NOW is present
-and non-nil, FACE will also be created according to SPEC.
-
-See `defface' for the format of SPEC."
- (while args
- (let ((entry (car args)))
- (if (listp entry)
- (let ((face (nth 0 entry))
- (spec (nth 1 entry))
- (now (nth 2 entry)))
- (put face 'saved-face spec)
- (when now
- (put face 'force-face t))
- (when (or now (custom-facep face))
- (when (fboundp 'copy-face)
- (copy-face 'custom-face-empty face))
- (custom-face-display-set face spec))
- (setq args (cdr args)))
- ;; Old format, a plist of FACE SPEC pairs.
- (let ((face (nth 0 args))
- (spec (nth 1 args)))
- (put face 'saved-face spec))
- (setq args (cdr (cdr args)))))))
-
-;;; The End.
-
-(provide 'cus-face)
-
-;; cus-face.el ends here
+++ /dev/null
-;;; custom.el -- Tools for declaring and initializing options.
-;;
-;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
-;;
-;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
-;; Keywords: help, faces
-;; Version: 1.82
-;; 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
-;; `cus-edit.el'.
-
-;; The code implementing face declarations is in `cus-face.el'
-
-;;; Code:
-
-(require 'widget)
-
-(define-widget-keywords :prefix :tag :load :link :options :type :group)
-
-;; These autoloads should be deleted eventually.
-(unless (fboundp 'load-gc)
- ;; From cus-edit.el
- (autoload 'customize "cus-edit" nil t)
- (autoload 'customize-variable "cus-edit" nil t)
- (autoload 'customize-variable-other-window "cus-edit" nil t)
- (autoload 'customize-face "cus-edit" nil t)
- (autoload 'customize-face-other-window "cus-edit" nil t)
- (autoload 'customize-apropos "cus-edit" nil t)
- (autoload 'customize-customized "cus-edit" nil t)
- (autoload 'custom-buffer-create "cus-edit")
- (autoload 'custom-make-dependencies "cus-edit")
- (autoload 'customize-menu-create "cus-edit")
-
- ;; From cus-face.el
- (autoload 'custom-declare-face "cus-face")
- (autoload 'custom-set-faces "cus-face"))
-
-(defvar custom-define-hook nil
- ;; Customize information for this option is in `cus-edit.el'.
- "Hook called after defining each customize option.")
-
-;;; The `defcustom' Macro.
-
-(defun custom-declare-variable (symbol value doc &rest args)
- "Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments."
- ;; Bind this variable unless it already is bound.
- (unless (default-boundp symbol)
- ;; Use the saved value if it exists, otherwise the factory setting.
- (set-default symbol (if (get symbol 'saved-value)
- (eval (car (get symbol 'saved-value)))
- (eval value))))
- ;; Remember the factory setting.
- (put symbol 'factory-value (list value))
- ;; Maybe this option was rogue in an earlier version. It no longer is.
- (when (get symbol 'force-value)
- ;; It no longer is.
- (put symbol 'force-value nil))
- (when doc
- (put symbol 'variable-documentation doc))
- (while args
- (let ((arg (car args)))
- (setq args (cdr args))
- (unless (symbolp arg)
- (error "Junk in args %S" args))
- (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 :options)
- (if (get symbol 'custom-options)
- ;; Slow safe code to avoid duplicates.
- (mapcar (lambda (option)
- (custom-add-option symbol option))
- value)
- ;; Fast code for the common case.
- (put symbol 'custom-options (copy-list value))))
- (t
- (custom-handle-keyword symbol keyword value
- 'custom-variable))))))
- (run-hooks 'custom-define-hook)
- symbol)
-
-(defmacro defcustom (symbol value doc &rest args)
- "Declare SYMBOL as a customizable variable that defaults to VALUE.
-DOC is the variable documentation.
-
-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]...
-
-The following KEYWORD's are defined:
-
-:type VALUE should be a widget type.
-:options VALUE should be a list of valid members of the widget type.
-: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."
- `(eval-and-compile
- (custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args)))
-
-;;; The `defface' Macro.
-
-(defmacro defface (face spec doc &rest args)
- "Declare FACE as a customizable face that defaults to SPEC.
-FACE does not need to be quoted.
-
-Third argument DOC is the face documentation.
-
-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]...
-
-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 ,doc ,@args))
-
-;;; The `defgroup' Macro.
-
-(defun custom-declare-group (symbol members doc &rest args)
- "Like `defgroup', but SYMBOL is evaluated as a normal argument."
- (put symbol 'custom-group (nconc members (get symbol 'custom-group)))
- (when doc
- (put symbol 'group-documentation doc))
- (while args
- (let ((arg (car args)))
- (setq args (cdr args))
- (unless (symbolp arg)
- (error "Junk in args %S" args))
- (let ((keyword arg)
- (value (car args)))
- (unless args
- (error "Keyword %s is missing an argument" keyword))
- (setq args (cdr args))
- (cond ((eq keyword :prefix)
- (put symbol 'custom-prefix value))
- (t
- (custom-handle-keyword symbol keyword value
- 'custom-group))))))
- (run-hooks 'custom-define-hook)
- symbol)
-
-(defmacro defgroup (symbol members doc &rest args)
- "Declare SYMBOL as a customization group containing MEMBERS.
-SYMBOL does not need to be quoted.
-
-Third arg DOC is the group documentation.
-
-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]...
-
-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 ,doc ,@args))
-
-(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)))))))
-
-;;; Properties.
-
-(defun custom-handle-all-keywords (symbol args type)
- "For customization option SYMBOL, handle keyword arguments ARGS.
-Third argument TYPE is the custom option type."
- (while args
- (let ((arg (car args)))
- (setq args (cdr args))
- (unless (symbolp arg)
- (error "Junk in args %S" args))
- (let ((keyword arg)
- (value (car args)))
- (unless args
- (error "Keyword %s is missing an argument" keyword))
- (setq args (cdr args))
- (custom-handle-keyword symbol keyword value type)))))
-
-(defun custom-handle-keyword (symbol keyword value type)
- "For customization option SYMBOL, handle KEYWORD with VALUE.
-Fourth argument TYPE is the custom option type."
- (cond ((eq keyword :group)
- (custom-add-to-group value symbol type))
- ((eq keyword :link)
- (custom-add-link symbol value))
- ((eq keyword :load)
- (custom-add-load symbol value))
- ((eq keyword :tag)
- (put symbol 'custom-tag value))
- (t
- (error "Unknown keyword %s" symbol))))
-
-(defun custom-add-option (symbol option)
- "To the variable SYMBOL add OPTION.
-
-If SYMBOL is a hook variable, OPTION should be a hook member.
-For other types variables, the effect is undefined."
- (let ((options (get symbol 'custom-options)))
- (unless (member option options)
- (put symbol 'custom-options (cons option options)))))
-
-(defun custom-add-link (symbol widget)
- "To the custom option SYMBOL add the link WIDGET."
- (let ((links (get symbol 'custom-links)))
- (unless (member widget links)
- (put symbol 'custom-links (cons widget links)))))
-
-(defun custom-add-load (symbol load)
- "To the custom option SYMBOL add the dependency LOAD.
-LOAD should be either a library file name, or a feature name."
- (let ((loads (get symbol 'custom-loads)))
- (unless (member load loads)
- (put symbol 'custom-loads (cons load loads)))))
-
-;;; Initializing.
-
-(defun custom-set-variables (&rest args)
- "Initialize variables according to user preferences.
-
-The arguments should be a list where each entry has the form:
-
- (SYMBOL VALUE [NOW])
-
-The unevaluated VALUE is stored as the saved value for SYMBOL.
-If NOW is present and non-nil, VALUE is also evaluated and bound as
-the default value for the SYMBOL."
- (while args
- (let ((entry (car args)))
- (if (listp entry)
- (let ((symbol (nth 0 entry))
- (value (nth 1 entry))
- (now (nth 2 entry)))
- (put symbol 'saved-value (list value))
- (cond (now
- ;; Rogue variable, set it now.
- (put symbol 'force-value t)
- (set-default symbol (eval value)))
- ((default-boundp symbol)
- ;; Something already set this, overwrite it.
- (set-default symbol (eval value))))
- (setq args (cdr args)))
- ;; Old format, a plist of SYMBOL VALUE pairs.
- (let ((symbol (nth 0 args))
- (value (nth 1 args)))
- (put symbol 'saved-value (list value)))
- (setq args (cdr (cdr args)))))))
-
-;;; The End.
-
-(provide 'custom)
-
-;; custom.el ends here
(require 'cl)
(require 'bytecomp)
(push "." load-path)
+(push "~/lisp/custom" load-path)
(require 'lpath)
(defalias 'device-sound-enabled-p 'ignore)
agent minor mode in all Gnus buffers."
(interactive)
(add-hook 'gnus-before-startup-hook 'gnus-open-agent)
+ (add-hook 'gnus-setup-news-hook 'gnus-agent-queue-setup)
(unless gnus-agent-send-mail-function
(setq gnus-agent-send-mail-function message-send-mail-function
message-send-mail-function 'gnus-agent-send-mail))
(unless gnus-agent-covered-methods
(setq gnus-agent-covered-methods (list gnus-select-method))))
+(defun gnus-agent-queue-setup ()
+ "Make sure the queue group exists."
+ (unless (gnus-gethash "nndraft:queue" gnus-newsrc-hashtb)
+ (gnus-request-create-group "queue" '(nndraft ""))
+ (let ((gnus-level-default-subscribed 1))
+ (gnus-subscribe-group "nndraft:queue" nil '(nndraft "")))
+ (gnus-group-set-parameter
+ "nndraft:queue" 'gnus-dummy '((gnus-draft-mode)))))
+
(defun gnus-agent-send-mail ()
(if gnus-plugged
(funcall gnus-agent-send-mail-function)
(re-search-forward
(concat "^" (regexp-quote mail-header-separator) "\n"))
(replace-match "\n")
- (gnus-request-accept-article "nndraft:drafts")))
+ (gnus-request-accept-article "nndraft:queue")))
;;;
;;; Group mode commands
(interactive)
(gnus-set-global-variables)
(let ((article (gnus-summary-article-number)))
- (gnus-draft-setup article)
+ (gnus-draft-setup article gnus-newsgroup-name)
(push
`((lambda ()
(when (buffer-name (get-buffer ,gnus-summary-buffer))
(defun gnus-draft-send (article)
"Send message ARTICLE."
- (gnus-draft-setup article)
+ (message "In gnus-draft-send, article is %s" article)
+ (gnus-draft-setup article "nndraft:queue")
(message-send-and-exit))
(defun gnus-draft-send-all-messages ()
(gnus-draft-send-message))
(defun gnus-group-send-drafts ()
- "Send all sendable articles from the draft group."
+ "Send all sendable articles from the queue group."
(interactive)
- (gnus-request-group "nndraft:drafts")
+ (gnus-request-group "nndraft:queue")
(save-excursion
(let ((articles (nndraft-articles))
(unsendable (gnus-uncompress-range
(cdr (assq 'unsend
(gnus-info-marks
- (gnus-get-info "nndraft:drafts"))))))
+ (gnus-get-info "nndraft:queue"))))))
article)
(while (setq article (pop articles))
(unless (memq article unsendable)
;;; Utility functions
-(defun gnus-draft-setup (article)
+(defun gnus-draft-setup (article group)
+ (message "In gnus-draft-setup, article is %s %s" article group)
(gnus-setup-message 'forward
(message-mail)
(erase-buffer)
- (if (not (gnus-request-restore-buffer
- article (or gnus-newsgroup-name "nndraft:drafts")))
+ (message "Article is %s" article)
+ (if (not (gnus-request-restore-buffer article group))
(error "Couldn't restore the article")
;; Insert the separator.
(goto-char (point-min))
(provide 'gnus-draft)
;;; gnus-draft.el ends here
-
:group 'gnus-start
:type 'hook)
+(defcustom gnus-setup-news-hook nil
+ "A hook after reading the .newsrc file, but before generating the buffer."
+ :group 'gnus-start
+ :type 'hook)
+
(defcustom gnus-get-new-news-hook nil
"A hook run just before Gnus checks for new news."
:group 'gnus-group-new
;; Do the actual startup.
(gnus-setup-news nil level dont-connect)
+ (run-hooks 'gnus-setup-news-hook)
(gnus-start-draft-setup)
;; Generate the group buffer.
(gnus-group-list-groups level)
:link '(custom-manual "(gnus)Exiting Gnus")
:group 'gnus)
-(defconst gnus-version-number "0.7"
+(defconst gnus-version-number "0.8"
"Version number for this version of Gnus.")
(defconst gnus-version (format "Quassia Gnus v%s" gnus-version-number)
(defun message-set-auto-save-file-name ()
"Associate the message buffer with a file in the drafts directory."
(when message-autosave-directory
- (setq message-draft-article (nndraft-request-associate-buffer "drafts"))
- (clear-visited-file-modtime)))
+ (cond
+ ((fboundp 'nndraft-request-associate-buffer)
+ (setq message-draft-article (nndraft-request-associate-buffer "drafts"))
+ (clear-visited-file-modtime))
+ (t (unless (file-exists-p message-autosave-directory)
+ (make-directory message-autosave-directory t))
+ (let ((name (make-temp-name
+ (expand-file-name
+ (concat (file-name-as-directory
+ message-autosave-directory)
+ "msg."
+ (message-replace-chars-in-string
+ (message-replace-chars-in-string
+ (buffer-name) ?* ?.)
+ ?/ ?-))))))
+ (setq buffer-auto-save-file-name
+ (save-excursion
+ (prog1
+ (progn
+ (set-buffer (get-buffer-create " *draft tmp*"))
+ (setq buffer-file-name name)
+ (make-auto-save-file-name))
+ (kill-buffer (current-buffer)))))
+ (clear-visited-file-modtime))))))
(defun message-disassociate-draft ()
"Disassociate the message buffer from the drafts directory."
(when message-draft-article
- (nndraft-request-expire-articles
- (list message-draft-article) "drafts" nil t)))
+ (if (fboundp 'nndraft-request-expire-articles)
+ (nndraft-request-expire-articles
+ (list message-draft-article) "drafts" nil t))))
\f
(cdr local)))))
locals)))
+;;; Miscellaneous functions
+
+;; stolen (and renamed) from nnheader.el
+(defun message-replace-chars-in-string (string from to)
+ "Replace characters in STRING from FROM to TO."
+ (let ((string (substring string 0)) ;Copy string.
+ (len (length string))
+ (idx 0))
+ ;; Replace all occurrences of FROM with TO.
+ (while (< idx len)
+ (when (= (aref string idx) from)
+ (aset string idx to))
+ (setq idx (1+ idx)))
+ string))
+
(run-hooks 'message-load-hook)
(provide 'message)
nil)
(deffoo nnagent-request-post (&optional server)
- (gnus-request-accept-article "nndraft:drafts"))
+ (gnus-request-accept-article "nndraft:queue"))
;; Use nnml functions for just about everything.
(nnoo-import nnagent
(defvoo nndraft-directory (nnheader-concat gnus-directory "drafts/")
"Where nndraft will store its files."
- nnmh-current-directory)
+ nnmh-directory)
\f
(defvoo nndraft-current-group "" nil nnmh-current-group)
-(defvoo nndraft-top-directory nil nil nnmh-directory)
(defvoo nndraft-get-new-mail nil nil nnmh-get-new-mail)
+(defvoo nndraft-current-directory nil nil nnmh-current-directory)
(defconst nndraft-version "nndraft 1.0")
(defvoo nndraft-status-string "" nil nnmh-status-string)
(nnoo-define-basics nndraft)
(deffoo nndraft-open-server (server &optional defs)
- (push `(nndraft-current-group
- ,(file-name-nondirectory (directory-file-name nndraft-directory)))
- defs)
- (push `(nndraft-top-directory
- ,(file-name-directory (directory-file-name nndraft-directory)))
- defs)
(nnoo-change-server 'nndraft server defs)
(cond
((not (file-exists-p nndraft-directory))
t)))
(deffoo nndraft-retrieve-headers (articles &optional group server fetch-old)
+ (nndraft-possibly-change-group group)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
'headers))))
(deffoo nndraft-request-article (id &optional group server buffer)
+ (nndraft-possibly-change-group group)
(when (numberp id)
;; We get the newest file of the auto-saved file and the
;; "real" file.
(deffoo nndraft-request-restore-buffer (article &optional group server)
"Request a new buffer that is restored to the state of ARTICLE."
+ (nndraft-possibly-change-group group)
(when (nndraft-request-article article group server (current-buffer))
(let ((gnus-verbose-backends nil))
(nndraft-request-expire-articles (list article) group server t))
t))
(deffoo nndraft-request-update-info (group info &optional server)
+ (nndraft-possibly-change-group group)
(gnus-info-set-read
info
- (gnus-update-read-articles "nndraft:drafts" (nndraft-articles) t))
+ (gnus-update-read-articles (gnus-group-prefixed-name group '(nndraft ""))
+ (nndraft-articles) t))
(let (marks)
(when (setq marks (nth 3 info))
(setcar (nthcdr 3 info)
(deffoo nndraft-request-associate-buffer (group)
"Associate the current buffer with some article in the draft group."
+ (nndraft-possibly-change-group group)
(let ((gnus-verbose-backends nil)
(buf (current-buffer))
article file)
article))
(deffoo nndraft-request-expire-articles (articles group &optional server force)
+ (nndraft-possibly-change-group group)
(let* ((nnmh-allow-delete-final t)
(res (nndraft-execute-nnmh-command
`(nnmh-request-expire-articles
res))
(deffoo nndraft-request-accept-article (group &optional server last noinsert)
+ (nndraft-possibly-change-group group)
(let ((gnus-verbose-backends nil))
(nndraft-execute-nnmh-command
`(nnmh-request-accept-article group ,server ,last noinsert))))
(deffoo nndraft-request-create-group (group &optional server args)
- (if (file-exists-p nndraft-directory)
- (if (file-directory-p nndraft-directory)
+ (nndraft-possibly-change-group group)
+ (if (file-exists-p nndraft-current-directory)
+ (if (file-directory-p nndraft-current-directory)
t
nil)
(condition-case ()
(progn
- (gnus-make-directory nndraft-directory)
+ (gnus-make-directory nndraft-current-directory)
t)
(file-error nil))))
\f
;;; Low-Level Interface
+(defun nndraft-possibly-change-group (group)
+ (when (and group
+ (not (equal group nndraft-current-group)))
+ (setq nndraft-current-group group)
+ (setq nndraft-current-directory
+ (nnheader-concat nndraft-directory group))))
+
(defun nndraft-execute-nnmh-command (command)
- (let* ((dir (directory-file-name (expand-file-name nndraft-directory)))
+ (let* ((dir (directory-file-name
+ (expand-file-name nndraft-current-directory)))
(group (file-name-nondirectory dir))
(nnmh-directory (file-name-directory dir))
(nnmail-keep-last-article nil)
(defun nndraft-article-filename (article &rest args)
(apply 'concat
- (file-name-as-directory nndraft-directory)
+ (file-name-as-directory nndraft-current-directory)
(int-to-string article)
args))
(defun nndraft-articles ()
"Return the list of messages in the group."
- (gnus-make-directory nndraft-directory)
+ (gnus-make-directory nndraft-current-directory)
(sort
(mapcar 'string-to-int
- (directory-files nndraft-directory nil "\\`[0-9]+\\'" t))
+ (directory-files nndraft-current-directory nil "\\`[0-9]+\\'" t))
'<))
-(nnoo-map-functions nndraft
- (nnmh-retrieve-headers 0 nndraft-current-group 0 0)
- (nnmh-request-group nndraft-current-group 0 0)
- (nnmh-close-group nndraft-current-group 0)
- (nnmh-request-list (nnoo-current-server 'nndraft) nndraft-directory)
- (nnmh-request-newsgroups (nnoo-current-server 'nndraft) nndraft-directory))
+(nnoo-import nndraft
+ (nnmh
+ nnmh-retrieve-headers
+ nnmh-request-group
+ nnmh-close-group
+ nnmh-request-list
+ nnmh-request-newsgroups))
(provide 'nndraft)
(let ((dirs (and (file-readable-p dir)
(> (nth 1 (file-attributes (file-chase-links dir))) 2)
(directory-files dir t nil t)))
- dir)
+ rdir)
;; Recurse down directories.
- (while (setq dir (pop dirs))
- (when (and (not (member (file-name-nondirectory dir) '("." "..")))
- (file-directory-p dir)
- (file-readable-p dir))
- (nnmh-request-list-1 dir))))
+ (while (setq rdir (pop dirs))
+ (when (and (not (member (file-name-nondirectory rdir) '("." "..")))
+ (file-directory-p rdir)
+ (file-readable-p rdir)
+ (equal (file-truename rdir)
+ (file-truename dir)))
+ (nnmh-request-list-1 rdir))))
;; For each directory, generate an active file line.
(unless (string= (expand-file-name nnmh-toplev) dir)
(let ((files (mapcar
+++ /dev/null
-;;; wid-browse.el --- Functions for browsing widgets.
-;;
-;; Copyright (C) 1997 Free Software Foundation, Inc.
-;;
-;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
-;; Keywords: extensions
-;; Version: 1.82
-;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
-
-;;; Commentary:
-;;
-;; Widget browser. See `widget.el'.
-
-;;; Code:
-
-(require 'easymenu)
-(require 'custom)
-(require 'wid-edit)
-(require 'cl)
-
-(defgroup widget-browse nil
- "Customization support for browsing widgets."
- :group 'widgets)
-
-;;; The Mode.
-
-(defvar widget-browse-mode-map nil
- "Keymap for `widget-browse-mode'.")
-
-(unless widget-browse-mode-map
- (setq widget-browse-mode-map (make-sparse-keymap))
- (set-keymap-parent widget-browse-mode-map widget-keymap)
- (define-key widget-browse-mode-map "q" 'bury-buffer))
-
-(easy-menu-define widget-browse-mode-customize-menu
- widget-browse-mode-map
- "Menu used in widget browser buffers."
- (customize-menu-create 'widgets))
-
-(easy-menu-define widget-browse-mode-menu
- widget-browse-mode-map
- "Menu used in widget browser buffers."
- '("Widget"
- ["Browse" widget-browse t]
- ["Browse At" widget-browse-at t]))
-
-(defcustom widget-browse-mode-hook nil
- "Hook called when entering widget-browse-mode."
- :type 'hook
- :group 'widget-browse)
-
-(defun widget-browse-mode ()
- "Major mode for widget browser buffers.
-
-The following commands are available:
-
-\\[widget-forward] Move to next button or editable field.
-\\[widget-backward] Move to previous button or editable field.
-\\[widget-button-click] Activate button under the mouse pointer.
-\\[widget-button-press] Activate button under point.
-
-Entry to this mode calls the value of `widget-browse-mode-hook'
-if that value is non-nil."
- (kill-all-local-variables)
- (setq major-mode 'widget-browse-mode
- mode-name "Widget")
- (use-local-map widget-browse-mode-map)
- (easy-menu-add widget-browse-mode-customize-menu)
- (easy-menu-add widget-browse-mode-menu)
- (run-hooks 'widget-browse-mode-hook))
-
-;;; Commands.
-
-;;;###autoload
-(defun widget-browse-at (pos)
- "Browse the widget under point."
- (interactive "d")
- (let* ((field (get-text-property pos 'field))
- (button (get-text-property pos 'button))
- (doc (get-text-property pos 'widget-doc))
- (text (cond (field "This is an editable text area.")
- (button "This is an active area.")
- (doc "This is documentation text.")
- (t "This is unidentified text.")))
- (widget (or field button doc)))
- (when widget
- (widget-browse widget))
- (message text)))
-
-(defvar widget-browse-history nil)
-
-;;;###autoload
-(defun widget-browse (widget)
- "Create a widget browser for WIDGET."
- (interactive (list (completing-read "Widget: "
- obarray
- (lambda (symbol)
- (get symbol 'widget-type))
- t nil 'widget-browse-history)))
- (if (stringp widget)
- (setq widget (intern widget)))
- (unless (if (symbolp widget)
- (get widget 'widget-type)
- (and (consp widget)
- (get (widget-type widget) 'widget-type)))
- (error "Not a widget."))
- ;; Create the buffer.
- (if (symbolp widget)
- (let ((buffer (format "*Browse %s Widget*" widget)))
- (kill-buffer (get-buffer-create buffer))
- (switch-to-buffer (get-buffer-create buffer)))
- (kill-buffer (get-buffer-create "*Browse Widget*"))
- (switch-to-buffer (get-buffer-create "*Browse Widget*")))
- (widget-browse-mode)
-
- ;; Quick way to get out.
-;; (widget-create 'push-button
-;; :action (lambda (widget &optional event)
-;; (bury-buffer))
-;; "Quit")
-;; (widget-insert "\n")
-
- ;; Top text indicating whether it is a class or object browser.
- (if (listp widget)
- (widget-insert "Widget object browser.\n\nClass: ")
- (widget-insert "Widget class browser.\n\n")
- (widget-create 'widget-browse
- :format "%[%v%]\n%d"
- :doc (get widget 'widget-documentation)
- widget)
- (unless (eq (preceding-char) ?\n)
- (widget-insert "\n"))
- (widget-insert "\nSuper: ")
- (setq widget (get widget 'widget-type)))
-
- ;; Now show the attributes.
- (let ((name (car widget))
- (items (cdr widget))
- key value printer)
- (widget-create 'widget-browse
- :format "%[%v%]"
- name)
- (widget-insert "\n")
- (while items
- (setq key (nth 0 items)
- value (nth 1 items)
- printer (or (get key 'widget-keyword-printer)
- 'widget-browse-sexp)
- items (cdr (cdr items)))
- (widget-insert "\n" (symbol-name key) "\n\t")
- (funcall printer widget key value)
- (widget-insert "\n")))
- (widget-setup)
- (goto-char (point-min)))
-
-;;;###autoload
-(defun widget-browse-other-window (&optional widget)
- "Show widget browser for WIDGET in other window."
- (interactive)
- (let ((window (selected-window)))
- (switch-to-buffer-other-window "*Browse Widget*")
- (if widget
- (widget-browse widget)
- (call-interactively 'widget-browse))
- (select-window window)))
-
-
-;;; The `widget-browse' Widget.
-
-(define-widget 'widget-browse 'push-button
- "Button for creating a widget browser.
-The :value of the widget shuld be the widget to be browsed."
- :format "%[[%v]%]"
- :value-create 'widget-browse-value-create
- :action 'widget-browse-action)
-
-(defun widget-browse-action (widget &optional event)
- ;; Create widget browser for WIDGET's :value.
- (widget-browse (widget-get widget :value)))
-
-(defun widget-browse-value-create (widget)
- ;; Insert type name.
- (let ((value (widget-get widget :value)))
- (cond ((symbolp value)
- (insert (symbol-name value)))
- ((consp value)
- (insert (symbol-name (widget-type value))))
- (t
- (insert "strange")))))
-
-;;; Keyword Printer Functions.
-
-(defun widget-browse-widget (widget key value)
- "Insert description of WIDGET's KEY VALUE.
-VALUE is assumed to be a widget."
- (widget-create 'widget-browse value))
-
-(defun widget-browse-widgets (widget key value)
- "Insert description of WIDGET's KEY VALUE.
-VALUE is assumed to be a list of widgets."
- (while value
- (widget-create 'widget-browse
- (car value))
- (setq value (cdr value))
- (when value
- (widget-insert " "))))
-
-(defun widget-browse-sexp (widget key value)
- "Insert description of WIDGET's KEY VALUE.
-Nothing is assumed about value."
- (let ((pp (condition-case signal
- (pp-to-string value)
- (error (prin1-to-string signal)))))
- (when (string-match "\n\\'" pp)
- (setq pp (substring pp 0 (1- (length pp)))))
- (if (cond ((string-match "\n" pp)
- nil)
- ((> (length pp) (- (window-width) (current-column)))
- nil)
- (t t))
- (widget-insert pp)
- (widget-create 'push-button
- :tag "show"
- :action (lambda (widget &optional event)
- (with-output-to-temp-buffer
- "*Pp Eval Output*"
- (princ (widget-get widget :value))))
- pp))))
-
-(defun widget-browse-sexps (widget key value)
- "Insert description of WIDGET's KEY VALUE.
-VALUE is assumed to be a list of widgets."
- (let ((target (current-column)))
- (while value
- (widget-browse-sexp widget key (car value))
- (setq value (cdr value))
- (when value
- (widget-insert "\n" (make-string target ?\ ))))))
-
-;;; Keyword Printers.
-
-(put :parent 'widget-keyword-printer 'widget-browse-widget)
-(put :children 'widget-keyword-printer 'widget-browse-widgets)
-(put :buttons 'widget-keyword-printer 'widget-browse-widgets)
-(put :button 'widget-keyword-printer 'widget-browse-widget)
-(put :args 'widget-keyword-printer 'widget-browse-sexps)
-
-;;; The End:
-
-(provide 'wid-browse)
-
-;; wid-browse.el ends here
+++ /dev/null
-;;; wid-edit.el --- Functions for creating and using widgets.
-;;
-;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
-;;
-;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
-;; Keywords: extensions
-;; Version: 1.82
-;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
-
-;;; Commentary:
-;;
-;; See `widget.el'.
-
-;;; Code:
-
-(require 'widget)
-
-(eval-and-compile
- (require 'cl))
-
-;;; Compatibility.
-
-(eval-and-compile
- (autoload 'pp-to-string "pp")
- (autoload 'Info-goto-node "info")
-
- (when (string-match "XEmacs" emacs-version)
- (condition-case nil
- (require 'overlay)
- (error (load-library "x-overlay"))))
-
- (if (string-match "XEmacs" emacs-version)
- ;; XEmacs spell `intangible' as `atomic'.
- (defun widget-make-intangible (from to side)
- "Make text between FROM and TO atomic with regard to movement.
-Third argument should be `start-open' if it should be sticky to the rear,
-and `end-open' if it should sticky to the front."
- (require 'atomic-extents)
- (let ((ext (make-extent from to)))
- ;; XEmacs doesn't understant different kinds of read-only, so
- ;; we have to use extents instead.
- (put-text-property from to 'read-only nil)
- (set-extent-property ext 'read-only t)
- (set-extent-property ext 'start-open nil)
- (set-extent-property ext 'end-open nil)
- (set-extent-property ext side t)
- (set-extent-property ext 'atomic t)))
- (defun widget-make-intangible (from to size)
- "Make text between FROM and TO intangible."
- (put-text-property from to 'intangible 'front)))
-
-;; The following should go away when bundled with Emacs.
- (condition-case ()
- (require 'custom)
- (error nil))
-
- (unless (and (featurep 'custom) (fboundp 'custom-declare-variable))
- ;; We have the old custom-library, hack around it!
- (defmacro defgroup (&rest args) nil)
- (defmacro defcustom (var value doc &rest args)
- `(defvar ,var ,value ,doc))
- (defmacro defface (&rest args) nil)
- (define-widget-keywords :prefix :tag :load :link :options :type :group)
- (when (fboundp 'copy-face)
- (copy-face 'default 'widget-documentation-face)
- (copy-face 'bold 'widget-button-face)
- (copy-face 'italic 'widget-field-face)))
-
- (unless (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))))
-
- (unless (fboundp 'error-message-string)
- ;; Emacs function missing in XEmacs.
- (defun error-message-string (obj)
- "Convert an error value to an error message."
- (let ((buf (get-buffer-create " *error-message*")))
- (erase-buffer buf)
- (display-error obj buf)
- (buffer-string buf)))))
-
-;;; Customization.
-
-(defgroup widgets nil
- "Customization support for the Widget Library."
- :link '(custom-manual "(widget)Top")
- :link '(url-link :tag "Development Page"
- "http://www.dina.kvl.dk/~abraham/custom/")
- :prefix "widget-"
- :group 'extensions
- :group 'faces
- :group 'hypermedia)
-
-(defface widget-documentation-face '((((class color)
- (background dark))
- (:foreground "lime green"))
- (((class color)
- (background light))
- (:foreground "dark green"))
- (t nil))
- "Face used for documentation text."
- :group 'widgets)
-
-(defface widget-button-face '((t (:bold t)))
- "Face used for widget buttons."
- :group 'widgets)
-
-(defcustom widget-mouse-face 'highlight
- "Face used for widget buttons when the mouse is above them."
- :type 'face
- :group 'widgets)
-
-(defface widget-field-face '((((class grayscale color)
- (background light))
- (:background "light gray"))
- (((class grayscale color)
- (background dark))
- (:background "dark gray"))
- (t
- (:italic t)))
- "Face used for editable fields."
- :group 'widgets)
-
-(defcustom widget-menu-max-size 40
- "Largest number of items allowed in a popup-menu.
-Larger menus are read through the minibuffer."
- :group 'widgets
- :type 'integer)
-
-;;; Utility functions.
-;;
-;; These are not really widget specific.
-
-(defsubst 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 title
- (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
- (let ((val (completing-read (concat title ": ") items nil t)))
- (if (stringp val)
- (let ((try (try-completion val items)))
- (when (stringp try)
- (setq val try))
- (cdr (assoc val items)))
- nil)))))
-
-(defun widget-get-sibling (widget)
- "Get the item WIDGET is assumed to toggle.
-This is only meaningful for radio buttons or checkboxes in a list."
- (let* ((parent (widget-get widget :parent))
- (children (widget-get parent :children))
- child)
- (catch 'child
- (while children
- (setq child (car children)
- children (cdr children))
- (when (eq (widget-get child :button) widget)
- (throw 'child child)))
- nil)))
-
-;;; 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
- 'start-open t
- 'end-open 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 the front end of the field.
- (add-text-properties (1- from) from (list 'rear-nonsticky t
- 'end-open t
- 'invisible t))
- (when (or (string-match "\\(.\\|\n\\)%v" (widget-get widget :format))
- (widget-get widget :hide-front-space))
- ;; WARNING: This is going to lose horrible if the character just
- ;; before the field can be modified (e.g. if it belongs to a
- ;; choice widget). We try to compensate by checking the format
- ;; string, and hope the user hasn't changed the :create method.
- (widget-make-intangible (- from 2) from 'end-open))
-
- ;; Make it possible to edit back end of the field.
- (add-text-properties to (1+ to) (list 'front-sticky nil
- 'read-only t
- 'start-open t))
-
- (cond ((widget-get widget :size)
- (put-text-property to (1+ to) 'invisible t)
- (when (or (string-match "%v\\(.\\|\n\\)" (widget-get widget :format))
- (widget-get widget :hide-rear-space))
- ;; WARNING: This is going to lose horrible if the character just
- ;; after the field can be modified (e.g. if it belongs to a
- ;; choice widget). We try to compensate by checking the format
- ;; string, and hope the user hasn't changed the :create method.
- (widget-make-intangible to (+ to 2) 'start-open)))
- ((string-match "XEmacs" emacs-version)
- ;; XEmacs does not allow you to insert before a read-only
- ;; character, even if it is start.open.
- ;; XEmacs does allow you to delete an read-only extent, so
- ;; making the terminating newline read only doesn't help.
- ;; I tried putting an invisible intangible read-only space
- ;; before the newline, which gave really weird effects.
- ;; So for now, we just have trust the user not to delete the
- ;; newline.
- (put-text-property to (1+ to) 'read-only nil))))
-
-(defun widget-specify-field-update (widget from to)
- ;; Specify editable button for WIDGET between FROM and TO.
- (let ((map (widget-get widget :keymap))
- (secret (widget-get widget :secret))
- (secret-to to)
- (size (widget-get widget :size))
- (face (or (widget-get widget :value-face)
- 'widget-field-face))
- (help-echo (widget-get widget :help-echo))
- (help-property (if (featurep 'balloon-help)
- 'balloon-help
- 'help-echo)))
- (unless (or (stringp help-echo) (null help-echo))
- (setq help-echo 'widget-mouse-help))
-
- (when secret
- (while (and size
- (not (zerop size))
- (> secret-to from)
- (eq (char-after (1- secret-to)) ?\ ))
- (setq secret-to (1- secret-to)))
-
- (save-excursion
- (goto-char from)
- (while (< (point) secret-to)
- (let ((old (get-text-property (point) 'secret)))
- (when old
- (subst-char-in-region (point) (1+ (point)) secret old)))
- (forward-char))))
-
- (set-text-properties from to (list 'field widget
- 'read-only nil
- 'keymap map
- 'local-map map
- help-property help-echo
- 'face face))
-
- (when secret
- (save-excursion
- (goto-char from)
- (while (< (point) secret-to)
- (let ((old (following-char)))
- (subst-char-in-region (point) (1+ (point)) old secret)
- (put-text-property (point) (1+ (point)) 'secret old))
- (forward-char))))
-
- (unless (widget-get widget :size)
- (add-text-properties to (1+ to) (list 'field widget
- help-property help-echo
- 'face face)))
- (add-text-properties to (1+ to) (list 'local-map map
- 'keymap map))))
-
-(defun widget-specify-button (widget from to)
- ;; Specify button for WIDGET between FROM and TO.
- (let ((face (widget-apply widget :button-face-get))
- (help-echo (widget-get widget :help-echo))
- (help-property (if (featurep 'balloon-help)
- 'balloon-help
- 'help-echo)))
- (unless (or (null help-echo) (stringp help-echo))
- (setq help-echo 'widget-mouse-help))
- (add-text-properties from to (list 'button widget
- 'mouse-face widget-mouse-face
- 'start-open t
- 'end-open t
- help-property help-echo
- 'face face))))
-
-(defun widget-mouse-help (extent)
- "Find mouse help string for button in extent."
- (let* ((widget (widget-at (extent-start-position extent)))
- (help-echo (and widget (widget-get widget :help-echo))))
- (cond ((stringp help-echo)
- help-echo)
- ((and (symbolp help-echo) (fboundp help-echo)
- (stringp (setq help-echo (funcall help-echo widget))))
- help-echo)
- (t
- (format "(widget %S :help-echo %S)" widget help-echo)))))
-
-(defun widget-specify-sample (widget from to)
- ;; Specify sample for WIDGET between FROM and TO.
- (let ((face (widget-apply widget :sample-face-get)))
- (when face
- (add-text-properties from to (list 'start-open t
- 'end-open t
- 'face face)))))
-
-(defun widget-specify-doc (widget from to)
- ;; Specify documentation for WIDGET between FROM and TO.
- (add-text-properties from to (list 'widget-doc widget
- 'face 'widget-documentation-face)))
-
-(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)))
-
-(defface widget-inactive-face '((((class grayscale color)
- (background dark))
- (:foreground "light gray"))
- (((class grayscale color)
- (background light))
- (:foreground "dark gray"))
- (t
- (:italic t)))
- "Face used for inactive widgets."
- :group 'widgets)
-
-(defun widget-specify-inactive (widget from to)
- "Make WIDGET inactive for user modifications."
- (unless (widget-get widget :inactive)
- (let ((overlay (make-overlay from to nil t nil)))
- (overlay-put overlay 'face 'widget-inactive-face)
- (overlay-put overlay 'evaporate 't)
- (overlay-put overlay (if (string-match "XEmacs" emacs-version)
- 'read-only
- 'modification-hooks) '(widget-overlay-inactive))
- (widget-put widget :inactive overlay))))
-
-(defun widget-overlay-inactive (&rest junk)
- "Ignoring the arguments, signal an error."
- (unless inhibit-read-only
- (error "Attempt to modify inactive widget")))
-
-
-(defun widget-specify-active (widget)
- "Make WIDGET active for user modifications."
- (let ((inactive (widget-get widget :inactive)))
- (when inactive
- (delete-overlay inactive)
- (widget-put widget :inactive nil))))
-
-;;; Widget Properties.
-
-(defsubst widget-type (widget)
- "Return the type of WIDGET, a symbol."
- (car widget))
-
-(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'."
- (let ((missing t)
- value tmp)
- (while missing
- (cond ((setq tmp (widget-plist-member (cdr widget) property))
- (setq value (car (cdr tmp))
- missing nil))
- ((setq tmp (car widget))
- (setq widget (get tmp 'widget-type)))
- (t
- (setq missing nil))))
- value))
-
-(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)))
-
-;;;###autoload
-(defun widget-apply (widget property &rest args)
- "Apply the value of WIDGET's PROPERTY to the widget itself.
-ARGS are passed as extra arguments 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)))
-
-(defun widget-apply-action (widget &optional event)
- "Apply :action in WIDGET in response to EVENT."
- (if (widget-apply widget :active)
- (widget-apply widget :action event)
- (error "Attempt to perform action on inactive widget")))
-
-;;; Glyphs.
-
-(defcustom widget-glyph-directory (concat data-directory "custom/")
- "Where widget glyphs are located.
-If this variable is nil, widget will try to locate the directory
-automatically. This does not work yet."
- :group 'widgets
- :type 'directory)
-
-(defcustom widget-glyph-enable t
- "If non nil, use glyphs in images when available."
- :group 'widgets
- :type 'boolean)
-
-(defun widget-glyph-insert (widget tag image)
- "In WIDGET, insert the text TAG or, if supported, IMAGE.
-IMAGE should either be a glyph, or a name sans extension of an xpm or
-xbm file located in `widget-glyph-directory'.
-
-WARNING: If you call this with a glyph, and you want the user to be
-able to activate the glyph, make sure it is unique. If you use the
-same glyph for multiple widgets, activating any of the glyphs will
-cause the last created widget to be activated."
- (cond ((not (and (string-match "XEmacs" emacs-version)
- widget-glyph-enable
- (fboundp 'make-glyph)
- image))
- ;; We don't want or can't use glyphs.
- (insert tag))
- ((and (fboundp 'glyphp)
- (glyphp image))
- ;; Already a glyph. Insert it.
- (widget-glyph-insert-glyph widget tag image))
- (t
- ;; A string. Look it up in.
- (let ((file (concat widget-glyph-directory
- (if (string-match "/\\'" widget-glyph-directory)
- ""
- "/")
- image
- (if (featurep 'xpm) ".xpm" ".xbm"))))
- (if (file-readable-p file)
- (widget-glyph-insert-glyph widget tag (make-glyph file))
- ;; File not readable, give up.
- (insert tag))))))
-
-(defun widget-glyph-insert-glyph (widget tag glyph)
- "In WIDGET, with alternative text TAG, insert GLYPH."
- (set-glyph-image glyph (cons 'tty tag))
- (set-glyph-property glyph 'widget widget)
- (insert "*")
- (add-text-properties (1- (point)) (point)
- (list 'invisible t
- 'end-glyph glyph))
- (let ((help-echo (widget-get widget :help-echo)))
- (when help-echo
- (let ((extent (extent-at (1- (point)) nil 'end-glyph))
- (help-property (if (featurep 'balloon-help)
- 'balloon-help
- 'help-echo)))
- (set-extent-property extent help-property (if (stringp help-echo)
- help-echo
- 'widget-mouse-help))))))
-
-;;; 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))
-
-(defun widget-create-child-and-convert (parent type &rest args)
- "As part of the widget PARENT, create a child widget TYPE.
-The child is converted, using the keyword arguments ARGS."
- (let ((widget (apply 'widget-convert type args)))
- (widget-put widget :parent parent)
- (unless (widget-get widget :indent)
- (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
- (or (widget-get widget :extra-offset) 0)
- (widget-get parent :offset))))
- (widget-apply widget :create)
- widget))
-
-(defun widget-create-child (parent type)
- "Create widget of TYPE."
- (let ((widget (copy-list type)))
- (widget-put widget :parent parent)
- (unless (widget-get widget :indent)
- (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
- (or (widget-get widget :extra-offset) 0)
- (widget-get parent :offset))))
- (widget-apply widget :create)
- widget))
-
-(defun widget-create-child-value (parent type value)
- "Create widget of TYPE with value VALUE."
- (let ((widget (copy-list type)))
- (widget-put widget :value (widget-apply widget :value-to-internal value))
- (widget-put widget :parent parent)
- (unless (widget-get widget :indent)
- (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
- (or (widget-get widget :extra-offset) 0)
- (widget-get parent :offset))))
- (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 Commands.
-
-(defvar widget-keymap nil
- "Keymap containing useful binding for buffers containing widgets.
-Recommended as a parent keymap for modes using widgets.")
-
-(unless widget-keymap
- (setq widget-keymap (make-sparse-keymap))
- (define-key widget-keymap "\C-k" 'widget-kill-line)
- (define-key widget-keymap "\t" 'widget-forward)
- (define-key widget-keymap "\M-\t" 'widget-backward)
- (define-key widget-keymap [(shift tab)] 'widget-backward)
- (define-key widget-keymap [backtab] 'widget-backward)
- (if (string-match "XEmacs" (emacs-version))
- (progn
- (define-key widget-keymap [button2] 'widget-button-click)
- (define-key widget-keymap [button1] 'widget-button1-click))
- (define-key widget-keymap [mouse-2] 'ignore)
- (define-key widget-keymap [down-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)
-
-(defvar widget-field-keymap nil
- "Keymap used inside an editable field.")
-
-(unless widget-field-keymap
- (setq widget-field-keymap (copy-keymap widget-keymap))
- (unless (string-match "XEmacs" (emacs-version))
- (define-key widget-field-keymap [menu-bar] 'nil))
- (define-key widget-field-keymap "\C-m" 'widget-field-activate)
- (define-key widget-field-keymap "\C-a" 'widget-beginning-of-line)
- (define-key widget-field-keymap "\C-e" 'widget-end-of-line)
- (set-keymap-parent widget-field-keymap global-map))
-
-(defvar widget-text-keymap nil
- "Keymap used inside a text field.")
-
-(unless widget-text-keymap
- (setq widget-text-keymap (copy-keymap widget-keymap))
- (unless (string-match "XEmacs" (emacs-version))
- (define-key widget-text-keymap [menu-bar] 'nil))
- (define-key widget-text-keymap "\C-a" 'widget-beginning-of-line)
- (define-key widget-text-keymap "\C-e" 'widget-end-of-line)
- (set-keymap-parent widget-text-keymap global-map))
-
-(defun widget-field-activate (pos &optional event)
- "Activate the ediable field at point."
- (interactive "@d")
- (let ((field (get-text-property pos 'field)))
- (if field
- (widget-apply-action field event)
- (call-interactively
- (lookup-key widget-global-map (this-command-keys))))))
-
-(defun widget-button-click (event)
- "Activate button below mouse pointer."
- (interactive "@e")
- (cond ((and (fboundp 'event-glyph)
- (event-glyph event))
- (let ((widget (glyph-property (event-glyph event) 'widget)))
- (if widget
- (widget-apply-action widget event)
- (message "You clicked on a glyph."))))
- ((event-point event)
- (let ((button (get-text-property (event-point event) 'button)))
- (if button
- (widget-apply-action button event)
- (call-interactively
- (or (lookup-key widget-global-map [ button2 ])
- (lookup-key widget-global-map [ down-mouse-2 ])
- (lookup-key widget-global-map [ mouse-2]))))))
- (t
- (message "You clicked somewhere weird."))))
-
-(defun widget-button1-click (event)
- "Activate glyph below mouse pointer."
- (interactive "@e")
- (if (and (fboundp 'event-glyph)
- (event-glyph event))
- (let ((widget (glyph-property (event-glyph event) 'widget)))
- (if widget
- (widget-apply-action widget event)
- (message "You clicked on a glyph.")))
- (call-interactively (lookup-key widget-global-map (this-command-keys)))))
-
-(defun widget-button-press (pos &optional event)
- "Activate button at POS."
- (interactive "@d")
- (let ((button (get-text-property pos 'button)))
- (if button
- (widget-apply-action button event)
- (let ((command (lookup-key widget-global-map (this-command-keys))))
- (when (commandp command)
- (call-interactively command))))))
-
-(defun widget-move (arg)
- "Move point to the ARG next field or button.
-ARG may be negative to move backward."
- (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"))))))
- (setq button (widget-at (point)))
- (if (and button (widget-get button :tab-order)
- (< (widget-get button :tab-order) 0))
- (setq arg (1+ arg))))))
- (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)))
- (setq button (widget-at (point)))
- (if (and button (widget-get button :tab-order)
- (< (widget-get button :tab-order) 0))
- (setq arg (1- arg)))))
- (widget-echo-help (point))
- (run-hooks 'widget-move-hook))
-
-(defun widget-forward (arg)
- "Move point to the next field or button.
-With optional ARG, move across that many fields."
- (interactive "p")
- (run-hooks 'widget-forward-hook)
- (widget-move arg))
-
-(defun widget-backward (arg)
- "Move point to the previous field or button.
-With optional ARG, move across that many fields."
- (interactive "p")
- (run-hooks 'widget-backward-hook)
- (widget-move (- arg)))
-
-(defun widget-beginning-of-line ()
- "Go to beginning of field or beginning of line, whichever is first."
- (interactive)
- (let ((bol (save-excursion (beginning-of-line) (point)))
- (prev (previous-single-property-change (point) 'field)))
- (goto-char (max bol (or prev bol)))))
-
-(defun widget-end-of-line ()
- "Go to end of field or end of line, whichever is first."
- (interactive)
- (let ((bol (save-excursion (end-of-line) (point)))
- (prev (next-single-property-change (point) 'field)))
- (goto-char (min bol (or prev bol)))))
-
-(defun widget-kill-line ()
- "Kill to end of field or end of line, whichever is first."
- (interactive)
- (let ((field (get-text-property (point) 'field))
- (newline (save-excursion (search-forward "\n")))
- (next (next-single-property-change (point) 'field)))
- (if (and field (> newline next))
- (kill-region (point) next)
- (call-interactively 'kill-line))))
-
-;;; 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))
- (widget-specify-field-update field
- begin
- (+ begin size))))
- ((> (- 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))))
-
-;;; Widget Functions
-;;
-;; These functions are used in the definition of multiple widgets.
-
-(defun widget-children-value-delete (widget)
- "Delete all :children and :buttons in WIDGET."
- (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-types-convert-widget (widget)
- "Convert :args as widget types in WIDGET."
- (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args)))
- widget)
-
-;;; 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
- :indent nil
- :offset 0
- :format-handler 'widget-default-format-handler
- :button-face-get 'widget-default-button-face-get
- :sample-face-get 'widget-default-sample-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) nil)
- :active 'widget-default-active
- :activate 'widget-specify-active
- :deactivate 'widget-default-deactivate
- :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))
- (glyph (widget-get widget :tag-glyph))
- (doc (widget-get widget :doc))
- button-begin button-end
- sample-begin sample-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 ?\{)
- (setq sample-begin (point)))
- ((eq escape ?\})
- (setq sample-end (point)))
- ((eq escape ?n)
- (when (widget-get widget :indent)
- (insert "\n")
- (insert-char ? (widget-get widget :indent))))
- ((eq escape ?t)
- (cond (glyph
- (widget-glyph-insert widget (or tag "image") glyph))
- (tag
- (insert tag))
- (t
- (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, sample, and doc, and insert value.
- (and button-begin button-end
- (widget-specify-button widget button-begin button-end))
- (and sample-begin sample-end
- (widget-specify-sample widget sample-begin sample-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)
- ;; We recognize the %h escape by default.
- (let* ((buttons (widget-get widget :buttons))
- (doc-property (widget-get widget :documentation-property))
- (doc-try (cond ((widget-get widget :doc))
- ((symbolp doc-property)
- (documentation-property (widget-get widget :value)
- doc-property))
- (t
- (funcall doc-property (widget-get widget :value)))))
- (doc-text (and (stringp doc-try)
- (> (length doc-try) 1)
- doc-try)))
- (cond ((eq escape ?h)
- (when doc-text
- (and (eq (preceding-char) ?\n)
- (widget-get widget :indent)
- (insert-char ? (widget-get widget :indent)))
- ;; The `*' in the beginning is redundant.
- (when (eq (aref doc-text 0) ?*)
- (setq doc-text (substring doc-text 1)))
- ;; Get rid of trailing newlines.
- (when (string-match "\n+\\'" doc-text)
- (setq doc-text (substring doc-text 0 (match-beginning 0))))
- (push (if (string-match "\n." doc-text)
- ;; Allow multiline doc to be hiden.
- (widget-create-child-and-convert
- widget 'widget-help
- :doc (progn
- (string-match "\\`.*" doc-text)
- (match-string 0 doc-text))
- :widget-doc doc-text
- "?")
- ;; A single line is just inserted.
- (widget-create-child-and-convert
- widget 'item :format "%d" :doc doc-text nil))
- buttons)))
- (t
- (error "Unknown escape `%c'" escape)))
- (widget-put widget :buttons buttons)))
-
-(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-sample-face-get (widget)
- ;; Use :sample-face.
- (widget-get widget :sample-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)
- (when (< from to)
- ;; Kludge: this doesn't need to be true for empty formats.
- (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-active (widget)
- "Return t iff this widget active (user modifiable)."
- (and (not (widget-get widget :inactive))
- (let ((parent (widget-get widget :parent)))
- (or (null parent)
- (widget-apply parent :active)))))
-
-(defun widget-default-deactivate (widget)
- "Make WIDGET inactive for user modifications."
- (widget-specify-inactive widget
- (widget-get widget :from)
- (widget-get widget :to)))
-
-(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 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-button' Widget.
-
-(defcustom widget-push-button-gui t
- "If non nil, use GUI push buttons when available."
- :group 'widgets
- :type 'boolean)
-
-;; Cache already created GUI objects.
-(defvar widget-push-button-cache nil)
-
-(define-widget 'push-button 'item
- "A pushable button."
- :value-create 'widget-push-button-value-create
- :text-format "[%s]"
- :format "%[%v%]")
-
-(defun widget-push-button-value-create (widget)
- ;; Insert text representing the `on' and `off' states.
- (let* ((tag (or (widget-get widget :tag)
- (widget-get widget :value)))
- (text (format (widget-get widget :text-format) tag))
- (gui (cdr (assoc tag widget-push-button-cache))))
- (if (and (fboundp 'make-gui-button)
- (fboundp 'make-glyph)
- widget-push-button-gui
- (fboundp 'device-on-window-system-p)
- (device-on-window-system-p)
- (string-match "XEmacs" emacs-version))
- (progn
- (unless gui
- (setq gui (make-gui-button tag 'widget-gui-action widget))
- (push (cons tag gui) widget-push-button-cache))
- (widget-glyph-insert-glyph widget text
- (make-glyph (car (aref gui 1)))))
- (insert text))))
-
-(defun widget-gui-action (widget)
- "Apply :action for WIDGET."
- (widget-apply-action widget (this-command-keys)))
-
-;;; The `link' Widget.
-
-(define-widget 'link 'item
- "An embedded link."
- :help-echo "Follow the link."
- :format "%[_%t_%]")
-
-;;; The `info-link' Widget.
-
-(define-widget 'info-link 'link
- "A link to an info file."
- :action 'widget-info-link-action)
-
-(defun widget-info-link-action (widget &optional event)
- "Open the info node specified by WIDGET."
- (Info-goto-node (widget-value widget)))
-
-;;; The `url-link' Widget.
-
-(define-widget 'url-link 'link
- "A link to an www page."
- :action 'widget-url-link-action)
-
-(defun widget-url-link-action (widget &optional event)
- "Open the url specified by WIDGET."
- (require 'browse-url)
- (funcall browse-url-browser-function (widget-value widget)))
-
-;;; The `editable-field' Widget.
-
-(define-widget 'editable-field 'default
- "An editable text field."
- :convert-widget 'widget-item-convert-widget
- :keymap widget-field-keymap
- :format "%v"
- :value ""
- :action 'widget-field-action
- :validate 'widget-field-validate
- :valid-regexp ""
- :error "No match"
- :value-create 'widget-field-value-create
- :value-delete 'widget-field-value-delete
- :value-get 'widget-field-value-get
- :match 'widget-field-match)
-
-;; History of field minibuffer edits.
-(defvar widget-field-history nil)
-
-(defun widget-field-action (widget &optional event)
- ;; Edit the value in the minibuffer.
- (let ((tag (widget-apply widget :menu-tag-get))
- (invalid (widget-apply widget :validate)))
- (when invalid
- (error (widget-get invalid :error)))
- (widget-value-set widget
- (widget-apply widget
- :value-to-external
- (read-string (concat tag ": ")
- (widget-apply
- widget
- :value-to-internal
- (widget-value widget))
- 'widget-field-history)))
- (widget-apply widget :notify widget event)
- (widget-setup)))
-
-(defun widget-field-validate (widget)
- ;; Valid if the content matches `:valid-regexp'.
- (save-excursion
- (let ((value (widget-apply widget :value-get))
- (regexp (widget-get widget :valid-regexp)))
- (if (string-match regexp value)
- nil
- widget))))
-
-(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)))
- (insert value)
- (and size
- (< (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-to (copy-marker (point)))
- (set-marker-insertion-type (widget-get widget :value-to) nil)
- (if (null size)
- (insert ?\n)
- (insert ?\ ))
- (widget-put widget :value-from (copy-marker from))
- (set-marker-insertion-type (widget-get widget :value-from) t)))
-
-(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))
- ;; These are nil if the :format string doesn't contain `%v'.
- (when (widget-get widget :value-from)
- (set-marker (widget-get widget :value-from) nil))
- (when (widget-get widget :value-from)
- (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))
- (size (widget-get widget :size))
- (secret (widget-get widget :secret))
- (old (current-buffer)))
- (if (and from to)
- (progn
- (set-buffer (marker-buffer from))
- (setq from (1+ from)
- to (1- to))
- (while (and size
- (not (zerop size))
- (> to from)
- (eq (char-after (1- to)) ?\ ))
- (setq to (1- to)))
- (let ((result (buffer-substring-no-properties from to)))
- (when secret
- (let ((index 0))
- (while (< (+ from index) to)
- (aset result index
- (get-text-property (+ from index) 'secret))
- (setq index (1+ index)))))
- (set-buffer old)
- result))
- (widget-get widget :value))))
-
-(defun widget-field-match (widget value)
- ;; Match any string.
- (stringp value))
-
-;;; The `text' Widget.
-
-(define-widget 'text 'editable-field
- :keymap widget-text-keymap
- "A multiline text area.")
-
-;;; The `menu-choice' Widget.
-
-(define-widget 'menu-choice 'default
- "A menu of options."
- :convert-widget 'widget-types-convert-widget
- :format "%[%t%]: %v"
- :case-fold t
- :tag "choice"
- :void '(item :format "invalid (%t)\n")
- :value-create 'widget-choice-value-create
- :value-delete 'widget-children-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-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-child-value
- widget current 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-child-and-convert
- widget void :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))
- (completion-ignore-case (widget-get widget :case-fold))
- current choices)
- ;; Remember old value.
- (if (and old (not (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-apply widget :notify widget event)
- (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 'item
- "Toggle between two states."
- :format "%[%v%]\n"
- :value-create 'widget-toggle-value-create
- :action 'widget-toggle-action
- :match (lambda (widget value) t)
- :on "on"
- :off "off")
-
-(defun widget-toggle-value-create (widget)
- ;; Insert text representing the `on' and `off' states.
- (if (widget-value widget)
- (widget-glyph-insert widget
- (widget-get widget :on)
- (widget-get widget :on-glyph))
- (widget-glyph-insert widget
- (widget-get widget :off)
- (widget-get widget :off-glyph))))
-
-(defun widget-toggle-action (widget &optional event)
- ;; Toggle value.
- (widget-value-set widget (not (widget-value widget)))
- (widget-apply widget :notify widget event))
-
-;;; The `checkbox' Widget.
-
-(define-widget 'checkbox 'toggle
- "A checkbox toggle."
- :format "%[%v%]"
- :on "[X]"
- :on-glyph "check1"
- :off "[ ]"
- :off-glyph "check0"
- :action 'widget-checkbox-action)
-
-(defun widget-checkbox-action (widget &optional event)
- "Toggle checkbox, notify parent, and set active state of sibling."
- (widget-toggle-action widget event)
- (let ((sibling (widget-get-sibling widget)))
- (when sibling
- (if (widget-value widget)
- (widget-apply sibling :activate)
- (widget-apply sibling :deactivate)))))
-
-;;; The `checklist' Widget.
-
-(define-widget 'checklist 'default
- "A multiple choice widget."
- :convert-widget 'widget-types-convert-widget
- :format "%v"
- :offset 4
- :entry-format "%b %v"
- :menu-tag "checklist"
- :greedy nil
- :value-create 'widget-checklist-value-create
- :value-delete 'widget-children-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.
- (and (eq (preceding-char) ?\n)
- (widget-get widget :indent)
- (insert-char ? (widget-get widget :indent)))
- (widget-specify-insert
- (let* ((children (widget-get widget :children))
- (buttons (widget-get widget :buttons))
- (button-args (or (widget-get type :sibling-args)
- (widget-get widget :button-args)))
- (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 (apply 'widget-create-child-and-convert
- widget 'checkbox
- :value (not (null chosen))
- button-args)))
- ((eq escape ?v)
- (setq child
- (cond ((not chosen)
- (let ((child (widget-create-child widget type)))
- (widget-apply child :deactivate)
- child))
- ((widget-get type :inline)
- (widget-create-child-value
- widget type (cdr chosen)))
- (t
- (widget-create-child-value
- widget type (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)))
- (if found
- current
- nil)))
-
-(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
- :format "%[%v%]"
- :on "(*)"
- :on-glyph "radio1"
- :off "( )"
- :off-glyph "radio0")
-
-(defun widget-radio-button-notify (widget child &optional event)
- ;; Tell daddy.
- (widget-apply (widget-get widget :parent) :action widget event))
-
-;;; The `radio-button-choice' Widget.
-
-(define-widget 'radio-button-choice 'default
- "Select one of multiple options."
- :convert-widget 'widget-types-convert-widget
- :offset 4
- :format "%v"
- :entry-format "%b %v"
- :menu-tag "radio"
- :value-create 'widget-radio-value-create
- :value-delete 'widget-children-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))
- arg)
- (while args
- (setq arg (car args)
- args (cdr args))
- (widget-radio-add-item widget arg))))
-
-(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))
- (and (eq (preceding-char) ?\n)
- (widget-get widget :indent)
- (insert-char ? (widget-get widget :indent)))
- (widget-specify-insert
- (let* ((value (widget-get widget :value))
- (children (widget-get widget :children))
- (buttons (widget-get widget :buttons))
- (button-args (or (widget-get type :sibling-args)
- (widget-get widget :button-args)))
- (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 (apply 'widget-create-child-and-convert
- widget 'radio-button
- :value (not (null chosen))
- button-args)))
- ((eq escape ?v)
- (setq child (if chosen
- (widget-create-child-value
- widget type value)
- (widget-create-child widget type)))
- (unless chosen
- (widget-apply child :deactivate)))
- (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-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
- (progn
- (widget-value-set current value)
- (widget-apply current :activate))
- (widget-apply current :deactivate))
- (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-apply current :activate))
- ((widget-value button)
- (widget-value-set button nil)
- (widget-apply current :deactivate)))))))
- ;; Pass notification to parent.
- (widget-apply widget :notify child event))
-
-;;; The `insert-button' Widget.
-
-(define-widget 'insert-button 'push-button
- "An insert button for the `editable-list' widget."
- :tag "INS"
- :help-echo "Insert a new item into the list at this position."
- :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-button
- "A delete button for the `editable-list' widget."
- :tag "DEL"
- :help-echo "Delete this item from the list."
- :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 `editable-list' Widget.
-
-(defcustom widget-editable-list-gui nil
- "If non nil, use GUI push-buttons in editable list when available."
- :type 'boolean
- :group 'widgets)
-
-(define-widget 'editable-list 'default
- "A variable list of widgets of the same type."
- :convert-widget 'widget-types-convert-widget
- :offset 12
- :format "%v%i\n"
- :format-handler 'widget-editable-list-format-handler
- :entry-format "%i %d %v"
- :menu-tag "editable-list"
- :value-create 'widget-editable-list-value-create
- :value-delete 'widget-children-value-delete
- :value-get 'widget-editable-list-value-get
- :validate 'widget-editable-list-validate
- :match 'widget-editable-list-match
- :match-inline 'widget-editable-list-match-inline
- :insert-before 'widget-editable-list-insert-before
- :delete-at 'widget-editable-list-delete-at)
-
-(defun widget-editable-list-format-handler (widget escape)
- ;; We recognize the insert button.
- (let ((widget-push-button-gui widget-editable-list-gui))
- (cond ((eq escape ?i)
- (and (widget-get widget :indent)
- (insert-char ? (widget-get widget :indent)))
- (apply 'widget-create-child-and-convert
- widget 'insert-button
- (widget-get widget :append-button-args)))
- (t
- (widget-default-format-handler widget escape)))))
-
-(defun widget-editable-list-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-editable-list-entry-create
- widget
- (if inlinep
- (car answer)
- (car (car answer)))
- t)
- children)
- value (cdr answer))
- (setq value nil))))
- (widget-put widget :children (nreverse children))))
-
-(defun widget-editable-list-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-editable-list-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-editable-list-match (widget value)
- ;; Value must be a list and all the members must match the type.
- (and (listp value)
- (null (cdr (widget-editable-list-match-inline widget value)))))
-
-(defun widget-editable-list-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-editable-list-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-editable-list-entry-create
- widget nil nil)))
- (when (< (widget-get child :entry-from) (widget-get widget :from))
- (set-marker (widget-get widget :from)
- (widget-get child :entry-from)))
- (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 (widget-apply widget :notify widget))
-
-(defun widget-editable-list-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-editable-list-entry-create (widget value conv)
- ;; Create a new entry to the list.
- (let ((type (nth 0 (widget-get widget :args)))
- (widget-push-button-gui widget-editable-list-gui)
- child delete insert)
- (widget-specify-insert
- (save-excursion
- (and (widget-get widget :indent)
- (insert-char ? (widget-get widget :indent)))
- (insert (widget-get widget :entry-format)))
- ;; 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 (apply 'widget-create-child-and-convert
- widget 'insert-button
- (widget-get widget :insert-button-args))))
- ((eq escape ?d)
- (setq delete (apply 'widget-create-child-and-convert
- widget 'delete-button
- (widget-get widget :delete-button-args))))
- ((eq escape ?v)
- (if conv
- (setq child (widget-create-child-value
- widget type value))
- (setq child (widget-create-child widget type))))
- (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-types-convert-widget
- :format "%v"
- :value-create 'widget-group-value-create
- :value-delete 'widget-children-value-delete
- :value-get 'widget-editable-list-value-get
- :validate 'widget-editable-list-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))
- arg answer children)
- (while args
- (setq arg (car args)
- args (cdr args)
- answer (widget-match-inline arg value)
- value (cdr answer))
- (and (eq (preceding-char) ?\n)
- (widget-get widget :indent)
- (insert-char ? (widget-get widget :indent)))
- (push (cond ((null answer)
- (widget-create-child widget arg))
- ((widget-get arg :inline)
- (widget-create-child-value widget arg (car answer)))
- (t
- (widget-create-child-value widget arg (car (car answer)))))
- children))
- (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 `widget-help' Widget.
-
-(define-widget 'widget-help 'push-button
- "The widget documentation button."
- :format "%[[%t]%] %d"
- :help-echo "Toggle display of documentation."
- :action 'widget-help-action)
-
-(defun widget-help-action (widget &optional event)
- "Toggle documentation for WIDGET."
- (let ((old (widget-get widget :doc))
- (new (widget-get widget :widget-doc)))
- (widget-put widget :doc new)
- (widget-put widget :widget-doc old))
- (widget-value-set widget (widget-value widget)))
-
-;;; The Sexp Widgets.
-
-(define-widget 'const 'item
- "An immutable sexp."
- :format "%t\n%d")
-
-(define-widget 'function-item 'item
- "An immutable function name."
- :format "%v\n%h"
- :documentation-property (lambda (symbol)
- (condition-case nil
- (documentation symbol t)
- (error nil))))
-
-(define-widget 'variable-item 'item
- "An immutable variable name."
- :format "%v\n%h"
- :documentation-property 'variable-documentation)
-
-(define-widget 'string 'editable-field
- "A string"
- :tag "String"
- :format "%[%t%]: %v")
-
-(define-widget 'regexp 'string
- "A regular expression."
- ;; Should do validation.
- :tag "Regexp")
-
-(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 ": (default `" value "') ")
- dir nil must-match file)))
- (widget-value-set widget (abbreviate-file-name answer))
- (widget-apply widget :notify widget event)
- (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
- :tag "Symbol"
- :match (lambda (widget value) (symbolp value))
- :value-to-internal (lambda (widget value)
- (if (symbolp value)
- (symbol-name value)
- value))
- :value-to-external (lambda (widget value)
- (if (stringp value)
- (intern value)
- value)))
-
-(define-widget 'function 'sexp
- ;; Should complete on functions.
- "A lisp function."
- :tag "Function")
-
-(define-widget 'variable 'symbol
- ;; Should complete on variables.
- "A lisp variable."
- :tag "Variable")
-
-(define-widget 'sexp 'string
- "An arbitrary lisp expression."
- :tag "Lisp expression"
- :value nil
- :validate 'widget-sexp-validate
- :match (lambda (widget value) t)
- :value-to-internal 'widget-sexp-value-to-internal
- :value-to-external (lambda (widget value) (read value)))
-
-(defun widget-sexp-value-to-internal (widget value)
- ;; Use pp for printer representation.
- (let ((pp (pp-to-string value)))
- (while (string-match "\n\\'" pp)
- (setq pp (substring pp 0 -1)))
- (if (or (string-match "\n\\'" pp)
- (> (length pp) 40))
- (concat "\n" pp)
- pp)))
-
-(defun widget-sexp-validate (widget)
- ;; Valid if we can read the string and there is no junk left after it.
- (save-excursion
- (let ((buffer (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 buffer)))
- (if (eobp)
- (if (widget-apply widget :match value)
- nil
- (widget-put widget :error (widget-get widget :type-error))
- widget)
- (widget-put widget
- :error (format "Junk at end of expression: %s"
- (buffer-substring (point)
- (point-max))))
- widget))
- (error (widget-put widget :error (error-message-string data))
- widget)))))
-
-(define-widget 'integer 'sexp
- "An integer."
- :tag "Integer"
- :value 0
- :type-error "This field should contain an integer"
- :value-to-internal (lambda (widget value)
- (if (integerp value)
- (prin1-to-string value)
- value))
- :match (lambda (widget value) (integerp value)))
-
-(define-widget 'character 'string
- "An character."
- :tag "Character"
- :value 0
- :size 1
- :format "%{%t%}: %v\n"
- :type-error "This field should contain a character"
- :value-to-internal (lambda (widget value)
- (if (integerp value)
- (char-to-string value)
- value))
- :value-to-external (lambda (widget value)
- (if (stringp value)
- (aref value 0)
- value))
- :match (lambda (widget value) (integerp value)))
-
-(define-widget 'number 'sexp
- "A floating point number."
- :tag "Number"
- :value 0.0
- :type-error "This field should contain a number"
- :value-to-internal (lambda (widget value)
- (if (numberp value)
- (prin1-to-string value)
- value))
- :match (lambda (widget value) (numberp value)))
-
-(define-widget 'list 'group
- "A lisp list."
- :tag "List"
- :format "%{%t%}:\n%v")
-
-(define-widget 'vector 'group
- "A lisp vector."
- :tag "Vector"
- :format "%{%t%}:\n%v"
- :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 widget :value-to-internal value))))
-
-(define-widget 'cons 'group
- "A cons-cell."
- :tag "Cons-cell"
- :format "%{%t%}:\n%v"
- :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 widget :value-to-internal value))))
-
-(define-widget 'choice 'menu-choice
- "A union of several sexp types."
- :tag "Choice"
- :format "%[%t%]: %v")
-
-(define-widget 'radio 'radio-button-choice
- "A union of several sexp types."
- :tag "Choice"
- :format "%{%t%}:\n%v")
-
-(define-widget 'repeat 'editable-list
- "A variable length homogeneous list."
- :tag "Repeat"
- :format "%{%t%}:\n%v%i\n")
-
-(define-widget 'set 'checklist
- "A list of members from a fixed set."
- :tag "Set"
- :format "%{%t%}:\n%v")
-
-(define-widget 'boolean 'toggle
- "To be nil or non-nil, that is the question."
- :tag "Boolean"
- :format "%{%t%}: %[%v%]\n")
-
-;;; The `color' Widget.
-
-(define-widget 'color-item 'choice-item
- "A color name (with sample)."
- :format "%v (%{sample%})\n"
- :sample-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-button
- "Choose a color name (with sample)."
- :format "%[%t%]: %v"
- :tag "Color"
- :value "black"
- :value-create 'widget-color-value-create
- :value-delete 'widget-children-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-child-and-convert
- widget 'color-item (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)
- (widget-apply widget :notify widget event)
- (widget-setup))))
-
-;;; The Help Echo
-
-(defun widget-echo-help-mouse ()
- "Display the help message for the widget under the mouse.
-Enable with (run-with-idle-timer 1 t 'widget-echo-help-mouse)"
- (let* ((pos (mouse-position))
- (frame (car pos))
- (x (car (cdr pos)))
- (y (cdr (cdr pos)))
- (win (window-at x y frame))
- (where (coordinates-in-window-p (cons x y) win)))
- (when (consp where)
- (save-window-excursion
- (progn ; save-excursion
- (select-window win)
- (let* ((result (compute-motion (window-start win)
- '(0 . 0)
- (window-end win)
- where
- (window-width win)
- (cons (window-hscroll) 0)
- win)))
- (when (and (eq (nth 1 result) x)
- (eq (nth 2 result) y))
- (widget-echo-help (nth 0 result))))))))
- (unless track-mouse
- (setq track-mouse t)
- (add-hook 'post-command-hook 'widget-stop-mouse-tracking)))
-
-(defun widget-stop-mouse-tracking (&rest args)
- "Stop the mouse tracking done while idle."
- (remove-hook 'post-command-hook 'widget-stop-mouse-tracking)
- (setq track-mouse nil))
-
-(defun widget-at (pos)
- "The button or field at POS."
- (or (get-text-property pos 'button)
- (get-text-property pos 'field)))
-
-(defun widget-echo-help (pos)
- "Display the help echo for widget at POS."
- (let* ((widget (widget-at pos))
- (help-echo (and widget (widget-get widget :help-echo))))
- (cond ((stringp help-echo)
- (message "%s" help-echo))
- ((and (symbolp help-echo) (fboundp help-echo)
- (stringp (setq help-echo (funcall help-echo widget))))
- (message "%s" help-echo)))))
-
-;;; The End:
-
-(provide 'wid-edit)
-
-;; wid-edit.el ends here
+++ /dev/null
-;;; widget.el --- a library of user interface components.
-;;
-;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
-;;
-;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
-;; Keywords: help, extensions, faces, hypermedia
-;; Version: 1.82
-;; 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 `wid-edit.el'.
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-
-(defmacro define-widget-keywords (&rest keys)
- (`
- (eval-and-compile
- (let ((keywords (quote (, keys))))
- (while keywords
- (or (boundp (car keywords))
- (set (car keywords) (car keywords)))
- (setq keywords (cdr keywords)))))))
-
-(define-widget-keywords :text-format :deactivate :active :inactive
- :activate :sibling-args :delete-button-args
- :insert-button-args :append-button-args :button-args
- :tag-glyph :off-glyph :on-glyph :valid-regexp
- :secret :sample-face :sample-face-get :case-fold :widget-doc
- :create :convert-widget :format :value-create :offset :extra-offset
- :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 :documentation-property :hide-front-space
- :hide-rear-space :tab-order)
-
-;; These autoloads should be deleted when the file is added to Emacs.
-(unless (fboundp 'load-gc)
- (autoload 'widget-apply "wid-edit")
- (autoload 'widget-create "wid-edit")
- (autoload 'widget-insert "wid-edit")
- (autoload 'widget-browse "wid-browse" nil t)
- (autoload 'widget-browse-other-window "wid-browse" nil t)
- (autoload 'widget-browse-at "wid-browse" nil t))
-
-(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
+Sat Sep 20 20:53:43 1997 Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+
+ * gnus.texi (Startup Variables): Addition.
+
1997-09-16 SL Baur <steve@altair.xemacs.org>
* gnus.texi: Correct typo.
\input texinfo @c -*-texinfo-*-
@setfilename gnus
-@settitle Quassia Gnus 0.7 Manual
+@settitle Quassia Gnus 0.8 Manual
@synindex fn cp
@synindex vr cp
@synindex pg cp
@tex
@titlepage
-@title Quassia Gnus 0.7 Manual
+@title Quassia Gnus 0.8 Manual
@author by Lars Magne Ingebrigtsen
@page
spool or your mbox file. All at the same time, if you want to push your
luck.
-This manual corresponds to Quassia Gnus 0.7.
+This manual corresponds to Quassia Gnus 0.8.
@end ifinfo
A hook that is run as the very last thing after starting up Gnus
successfully.
+@item gnus-started-hook
+@vindex gnus-started-hook
+A hook that is run after reading the @file{.newsrc} file(s), but before
+generating the group buffer.
+
@item gnus-check-bogus-newsgroups
@vindex gnus-check-bogus-newsgroups
If non-@code{nil}, Gnus will check for and delete all bogus groups at
\input texinfo @c -*-texinfo-*-
@setfilename message
-@settitle Message 0.7 Manual
+@settitle Message 0.8 Manual
@synindex fn cp
@synindex vr cp
@synindex pg cp
@tex
@titlepage
-@title Message 0.7 Manual
+@title Message 0.8 Manual
@author by Lars Magne Ingebrigtsen
@page
* Key Index:: List of Message mode keys.
@end menu
-This manual corresponds to Message 0.7. Message is distributed with
+This manual corresponds to Message 0.8. Message is distributed with
the Gnus distribution bearing the same version number as this manual
has.
projects / gnus / commitdiff