Mercurial > hg > xemacs-beta
changeset 106:8ff55ebd4be9 r20-1b5
Import from CVS: tag r20-1b5
author | cvs |
---|---|
date | Mon, 13 Aug 2007 09:17:26 +0200 |
parents | e59cf502fb45 |
children | 523141596bda |
files | CHANGES-beta ChangeLog lisp/ChangeLog lisp/custom/ChangeLog lisp/custom/cus-edit.el lisp/custom/cus-face.el lisp/custom/custom-edit.el lisp/custom/custom-xmas.el lisp/custom/custom.el lisp/custom/wid-browse.el lisp/custom/wid-edit.el lisp/custom/widget-browse.el lisp/custom/widget-edit.el lisp/custom/widget-example.el lisp/custom/widget.el lisp/gnus/gnus-cus.el lisp/gnus/gnus-load.el lisp/gnus/gnus-sum.el lisp/prim/auto-autoloads.el lisp/prim/faces.el lisp/prim/loadup.el lisp/tm/gnus-mime.el lisp/version.el lisp/x11/x-faces.el man/custom.texi man/widget.texi src/ChangeLog src/Makefile.in.in |
diffstat | 28 files changed, 5155 insertions(+), 4867 deletions(-) [+] |
line wrap: on
line diff
--- a/CHANGES-beta Mon Aug 13 09:16:54 2007 +0200 +++ b/CHANGES-beta Mon Aug 13 09:17:26 2007 +0200 @@ -1,4 +1,8 @@ -*- indented-text -*- +to 20.1 beta5 +-- bug fix to gnus-mime.el +-- custom-1.50 + to 20.1 beta4 -- mine.el (almost) fully ported to XEmacs -- time.el updated for XEmacs Courtesy of Jens Lautenbacher
--- a/ChangeLog Mon Aug 13 09:16:54 2007 +0200 +++ b/ChangeLog Mon Aug 13 09:17:26 2007 +0200 @@ -1,3 +1,7 @@ +Mon Mar 3 23:57:56 1997 Steven L Baur <steve@altair.xemacs.org> + + * XEmacs 20.1-b5 is released. + Mon Mar 3 18:09:17 1997 Steven L Baur <steve@altair.xemacs.org> * XEmacs 20.1-b4 is released.
--- a/lisp/ChangeLog Mon Aug 13 09:16:54 2007 +0200 +++ b/lisp/ChangeLog Mon Aug 13 09:17:26 2007 +0200 @@ -1,5 +1,7 @@ Mon Mar 3 14:45:16 1997 Steven L Baur <steve@altair.xemacs.org> + * prim/loadup.el: Remove custom.elc. + * prim/simple.el (newline): Attempt to not add newline to a previous end-open extent.
--- a/lisp/custom/ChangeLog Mon Aug 13 09:16:54 2007 +0200 +++ b/lisp/custom/ChangeLog Mon Aug 13 09:17:26 2007 +0200 @@ -1,3 +1,80 @@ +Mon Mar 03 18:29:27 1997 Per Abrahamsen <abraham@dina.kvl.dk> + + * Version 1.50 released. + +Mon Mar 3 15:01:25 1997 Per Abrahamsen <abraham@dina.kvl.dk> + + * cus-face.el (face-documentation): Renamed from + `get-face-documentation'. + (custom-declare-face): Change caller. + * cus-edit.el (custom-face): Ditto. + + * cus-face.el (make-empty-face): New function. + (initialize-face-resources): New option. + (initialize-face-resources): New function. + (custom-declare-face): Call them here. + (custom-face-display-set): Don't create face here. + (custom-set-faces): Clear face. + * cus-edit.el (custom-face-set): Ditto. + (custom-face-save): Ditto. + (custom-face-reset-saved): Ditto. + (custom-face-reset-factory): Ditto. + +Mon Mar 03 10:36:40 1997 Per Abrahamsen <abraham@dina.kvl.dk> + + * Version 1.49 released. + +Mon Mar 3 10:34:44 1997 Per Abrahamsen <abraham@dina.kvl.dk> + + * cus-face.el (custom-background-mode): Don't call + `x-color-values' on Emacs tty frame. + Patch by Katsumi Yamaoka <yamaoka@ga.sony.co.jp>. + +Sat Mar 1 22:55:17 1997 Per Abrahamsen <abraham@dina.kvl.dk> + + * cus-edit.el (cus-face): Require. + +Sat Mar 01 22:35:07 1997 Per Abrahamsen <abraham@dina.kvl.dk> + + * Version 1.48 released. + +Sat Mar 1 21:45:44 1997 Per Abrahamsen <abraham@dina.kvl.dk> + + * wid-edit.el: Renamed from widget-edit.el + * wid-browse.el: Renamed from widget-browse.el + * cus-edit.el: Renamed from custom-edit.el + * cus-face.el: New file. + * custom-xmas.el: Deleted. + * custom.el: Updated autoloads. + * widget.el: Ditto + * widget.texi: Updated examples. + * widget-example.el: Updated require. + +Fri Feb 28 02:04:49 1997 Per Abrahamsen <abraham@dina.kvl.dk> + + * custom.el (custom-declare-face): Ignore already declared faces. + + * Version 1.47 released. + +Fri Feb 28 01:46:22 1997 Per Abrahamsen <abraham@dina.kvl.dk> + + * custom.el (custom-background-mode): Take a frame argument. + (custom-declare-face): Create frame local faces where relevant. + (custom-declare-face): Whine when called during dump. + (custom-face-display-set): Don'e create frame local face if the + display is identical to the global face. + (custom-default-frame-properties): New variable and function. + (custom-extract-frame-properties): New function. + (custom-get-frame-properties): New function. + (custom-display-match-frame): Use it. + (custom-relevant-frames): New variable and function. + (custom-initialize-frame): New function. + (after-make-frame-hook): Enable it. + +Thu Feb 27 18:58:45 1997 Per Abrahamsen <abraham@dina.kvl.dk> + + * custom-edit.el (custom-buffer-create): Read up event when + Wed Feb 26 22:17:38 1997 Per Abrahamsen <abraham@dina.kvl.dk> * Version 1.46 released.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/cus-edit.el Mon Aug 13 09:17:26 2007 +0200 @@ -0,0 +1,1861 @@ +;;; 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.50 +;; 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) + +;;; 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 + :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)) + +(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)) + (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)) + +;;; The Custom Mode. + +(defvar custom-options nil + "Customization widgets in the current buffer.") + +(defvar custom-mode-map nil + "Keymap for `custom-mode'.") + +(unless custom-mode-map + (setq custom-mode-map (make-sparse-keymap)) + (set-keymap-parent custom-mode-map widget-keymap)) + +(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: + +\\[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. +\\[custom-set] Set all modifications. +\\[custom-save] Make all modifications default. +\\[custom-reset-current] Reset all modified options. +\\[custom-reset-saved] Reset all modified or set options. +\\[custom-reset-factory] Reset all options. + +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-menu) + (make-local-variable 'custom-options) + (run-hooks 'custom-mode-hook)) + +;;; Custom Mode Commands. + +(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 + ;; Code stolen from `help.el'. + (let ((v (variable-at-point)) + (enable-recursive-minibuffers t) + val) + (setq val (completing-read + (if v + (format "Customize variable (default %s): " v) + "Customize variable: ") + obarray 'boundp t)) + (list (if (equal val "") + v (intern val))))) + (custom-buffer-create (list (list symbol 'custom-variable)))) + +;;;###autoload +(defun customize-face (&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))) + (face-list)) + (message "Creating customization buffer...") + (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-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-mode) + (widget-insert "This is a customization buffer. +Push RET or click mouse-2 on the word ") + (widget-create 'info-link + :tag "help" + :help-echo "Push me for help." + "(custom)The Customization Buffer") + (widget-insert " for more information.\n\n") + (setq custom-options + (mapcar (lambda (entry) + (prog1 + (if (> (length options) 1) + (widget-create (nth 1 entry) + :tag (custom-unlispify-tag-name + (nth 0 entry)) + :value (nth 0 entry)) + ;; If there is only one entry, don't hide it! + (widget-create (nth 1 entry) + :custom-state 'unknown + :tag (custom-unlispify-tag-name + (nth 0 entry)) + :value (nth 0 entry))) + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")) + (widget-insert "\n"))) + options)) + (mapcar 'custom-magic-reset custom-options) + (widget-create 'push-button + :tag "Set" + :help-echo "Push me to set all modifications." + :action (lambda (widget &optional event) + (custom-set))) + (widget-insert " ") + (widget-create 'push-button + :tag "Save" + :help-echo "Push me to make the modifications default." + :action (lambda (widget &optional event) + (custom-save))) + (widget-insert " ") + (widget-create 'push-button + :tag "Reset" + :help-echo "Push me to undo all modifications." + :action (lambda (widget &optional event) + (custom-reset event))) + (widget-insert " ") + (widget-create 'push-button + :tag "Done" + :help-echo "Push me to 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") + (widget-setup)) + +;;; 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 "Push me to read the manual." + :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) + +(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 "\ +Push me to 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 "\ +Push me to 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 "Push me to expand or collapse this item." + :action 'custom-level-action) + +(defun custom-level-action (widget &optional event) + "Toggle visibility for parent to WIDGET." + (let* ((parent (widget-get widget :parent)) + (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." + (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))))) + +(defun custom-load-symbol (symbol) + "Load all dependencies for SYMBOL." + (let ((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 'customize) + +(defface custom-variable-button-face '((t (:underline t :bold t))) + "Face used for pushable variable tags." + :group 'customize) + +(define-widget 'custom-variable 'custom + "Customize variable." + :format "%l%v%m%h%a" + :help-echo "Push me to 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-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)) + (options (get symbol 'custom-options)) + (child-type (or (get symbol 'custom-type) 'sexp)) + (tag (widget-get widget :tag)) + (type (let ((tmp (if (listp child-type) + (copy-list child-type) + (list child-type)))) + (when options + (widget-put tmp :options options)) + tmp)) + (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 symbol (eval (setq val (widget-value child)))) + (put symbol 'customized-value (list val))) + (t + (set 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 symbol (eval (widget-value child)))) + (t + (put symbol + 'saved-value (list (custom-quote (widget-value + child)))) + (set 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 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 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. + +(defvar custom-face-edit-args + (mapcar (lambda (att) + (list 'group + :inline t + (list 'const :format "" :value (nth 0 att)) + (nth 1 att))) + custom-face-attributes)) + +(define-widget 'custom-face-edit 'checklist + "Edit face attributes." + :format "%t: %v" + :tag "Attributes" + :extra-offset 12 + :args (mapcar (lambda (att) + (list 'group + :inline t + (list 'const :format "" :value (nth 0 att)) + (nth 1 att))) + custom-face-attributes)) + +;;; The `custom-display' Widget. + +(define-widget 'custom-display 'menu-choice + "Select a display type." + :tag "Display" + :value t + :args '((const :tag "all" t) + (checklist :offset 0 + :extra-offset 9 + :args ((group (const :format "Type: " type) + (checklist :inline t + :offset 0 + (const :format "X " + x) + (const :format "PM " + pm) + (const :format "Win32 " + win32) + (const :format "DOS " + pc) + (const :format "TTY%n" + tty))) + (group (const :format "Class: " class) + (checklist :inline t + :offset 0 + (const :format "Color " + color) + (const :format + "Grayscale " + grayscale) + (const :format "Monochrome%n" + mono))) + (group (const :format "Background: " background) + (checklist :inline t + :offset 0 + (const :format "Light " + light) + (const :format "Dark\n" + dark))))))) + +;;; The `custom-face' Widget. + +(defface custom-face-tag-face '((t (:underline t))) + "Face used for face tags." + :group 'customize) + +(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 "Push me to set or reset this face." + :documentation-property '(lambda (face) + (face-documentation face)) + :value-create 'custom-face-value-create + :action 'custom-face-action + :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)))))) + +(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)) + (custom-load-widget widget) + (let* ((symbol (widget-value widget)) + (edit (widget-create-child-and-convert + widget 'editable-list + :entry-format "%i %d %v" + :value (or (get symbol 'saved-face) + (get symbol 'factory-face)) + '(group :format "%v" + custom-display custom-face-edit)))) + (custom-face-state-set widget) + (widget-put widget :children (list edit))))) + +(defvar custom-face-menu + '(("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-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 'customize) + +(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 'customize) + +(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 "Push me to 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) + (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)) + (children (mapcar (lambda (entry) + (widget-insert "\n") + (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))) + (mapcar 'custom-magic-reset children) + (widget-put widget :children children) + (custom-group-state-update widget))))) + +(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 (eolp) + (princ "\n"))))) + +(defun custom-save-faces () + "Save all customized faces in `custom-file'." + (save-excursion + (custom-save-delete 'custom-set-faces) + (let ((standard-output (current-buffer))) + (unless (bolp) + (princ "\n")) + (princ "(custom-set-faces") + (mapatoms (lambda (symbol) + (let ((value (get symbol 'saved-face))) + (when value + (princ "\n '(") + (princ symbol) + (princ " ") + (prin1 value) + (if (or (get symbol 'factory-face) + (and (not (custom-facep symbol)) + (not (get symbol 'force-face)))) + (princ ")") + (princ " t)")))))) + (princ ")") + (unless (eolp) + (princ "\n"))))) + +(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. + +(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)))) + +(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))) + +(defun custom-group-menu-create (widget symbol) + "Ignoring WIDGET, create a menu entry for customization group SYMBOL." + (custom-menu-create symbol)) + +(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 (> custom-menu-nesting 0) + (< (length (get symbol 'custom-group)) widget-menu-max-size)) + (let ((custom-menu-nesting (1- custom-menu-nesting)) + (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 custom-menu-update () + "Update customize menu." + (interactive) + (add-hook 'custom-define-hook 'custom-menu-reset) + (let ((menu `(,(car custom-help-menu) + ,(widget-apply '(custom-group) :custom-menu 'emacs) + ,@(cdr (cdr custom-help-menu))))) + (if (fboundp 'add-submenu) + (add-submenu '("Help") menu) + (define-key global-map [menu-bar help-menu customize-menu] + (cons (car menu) (easy-menu-create-keymaps (car menu) (cdr menu))))))) + +;;; Dependencies. + +;;;###autoload +(defun custom-make-dependencies () + "Batch function to extract custom dependencies from .el files. +Usage: emacs -batch *.el -f custom-make-dependencies > deps.el" + (let ((buffers (buffer-list))) + (while buffers + (set-buffer (car buffers)) + (setq buffers (cdr buffers)) + (let ((file (buffer-file-name))) + (when (and file (string-match "\\`\\(.*\\)\\.el\\'" file)) + (goto-char (point-min)) + (condition-case nil + (let ((name (file-name-nondirectory (match-string 1 file)))) + (while t + (let ((expr (read (current-buffer)))) + (when (and (listp expr) + (memq (car expr) '(defcustom defface defgroup))) + (eval expr) + (put (nth 1 expr) 'custom-where name))))) + (error nil)))))) + (mapatoms (lambda (symbol) + (let ((members (get symbol 'custom-group)) + item where found) + (when members + (princ "(put '") + (princ symbol) + (princ " 'custom-loads '(") + (while members + (setq item (car (car members)) + members (cdr members) + where (get item 'custom-where)) + (unless (or (null where) + (member where found)) + (when found + (princ " ")) + (prin1 where) + (push where found))) + (princ "))\n")))))) + +;;; The End. + +(provide 'cus-edit) + +;; cus-edit.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/cus-face.el Mon Aug 13 09:17:26 2007 +0200 @@ -0,0 +1,434 @@ +;;; 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.50 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;;; Commentary: +;; +;; See `custom.el'. + +;;; Code: + +(require 'custom) + +;;; Compatibility. + +(unless (fboundp 'frame-property) + ;; XEmacs function missing in Emacs 19.34. + (defun frame-property (frame property &optional default) + "Return FRAME's value for property PROPERTY." + (or (cdr (assq property (frame-parameters frame))) + default))) + +(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) + (defalias 'make-empty-face 'make-face) + (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 + ;; Not implemented in XEmacs. + "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) + (progn + (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)))) + +(defun face-documentation (face) + "Get the documentation string for FACE." + (face-property face 'doc-string)) + + (defun set-face-documentation (face string) + "Set the documentation string for FACE to STRING." + (set-face-property face 'doc-string string))) + + (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)))) + + (defun face-documentation (face) + "Get the documentation string for FACE." + (get face 'face-documentation)) + + (defun set-face-documentation (face string) + "Set the documentation string for FACE to STRING." + (put face 'face-documentation string))) + +;;; 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 (and (custom-facep face) + (not (get face 'saved-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-documentation face))) + (set-face-documentation face doc)) + (custom-handle-all-keywords face args 'custom-face) + (run-hooks 'custom-define-hook)) + face) + +;;; Font Attributes. + +(defun custom-face-attribites-set (face frame &rest atts) + "For FACE on FRAME set the attributes [KEYWORD VALUE].... +Each keyword should be listed in `custom-face-attributes'. + +If FRAME is nil, set the default face." + (while atts + (let* ((name (nth 0 atts)) + (value (nth 1 atts)) + (fun (nth 2 (assq name custom-face-attributes)))) + (setq atts (cdr (cdr atts))) + (condition-case nil + (funcall fun face value frame) + (error nil))))) + +(defconst custom-face-attributes + '((:bold (toggle :format "Bold: %[%v%]\n") custom-set-face-bold) + (:italic (toggle :format "Italic: %[%v%]\n") custom-set-face-italic) + (:underline + (toggle :format "Underline: %[%v%]\n") set-face-underline-p) + (:foreground (color :tag "Foreground") set-face-foreground) + (:background (color :tag "Background") set-face-background) + (:stipple (editable-field :format "Stipple: %v") set-face-stipple)) + "Alist of face attributes. + +The elements are of the form (KEY TYPE SET) where KEY is a symbol +identifying the attribute, TYPE is a widget type for editing the +attibute, SET is a function for setting the attribute value. + +The SET function should take three arguments, the face to modify, the +value of the attribute, and optionally the frame where the face should +be changed.") + +(defun custom-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-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))) + +(when (string-match "XEmacs" emacs-version) + ;; Support for special XEmacs font attributes. + (autoload 'font-create-object "font" nil) + + (unless (fboundp 'face-font-name) + (defun face-font-name (face &rest args) + (apply 'face-font face args))) + + (defun custom-set-face-font-size (face size &rest args) + "Set the font of FACE to SIZE" + (let* ((font (apply 'face-font-name face args)) + (fontobj (font-create-object font))) + (set-font-size fontobj size) + (apply 'set-face-font face fontobj args))) + + (defun custom-set-face-font-family (face family &rest args) + "Set the font of FACE to FAMILY" + (let* ((font (apply 'face-font-name face args)) + (fontobj (font-create-object font))) + (set-font-family fontobj family) + (apply 'set-face-font face fontobj args))) + + (nconc custom-face-attributes + '((:family (editable-field :format "Family: %v") + custom-set-face-font-family) + (:size (editable-field :format "Size: %v") + custom-set-face-font-size))) + + ;; Disable frame local faces. + (setq custom-relevant-frames nil) + (remove-hook 'after-make-frame-hook 'custom-initialize-frame)) + +;;; 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-attribites-set face frame atts)) + (unless frame + (put face 'custom-face-display display)) + (setq spec nil)))))) + +(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) + (color-instance-name + (specifier-instance + (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)) + +(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))) + +(defvar custom-relevant-frames t + "List of frames whose custom properties differ from the default.") + +(defun custom-relevant-frames () + "List of frames whose custom properties differ from the default." + (when (eq custom-relevant-frames t) + (setq custom-relevant-frames nil) + (let ((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 custom-relevant-frames))))) + custom-relevant-frames) + +(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))) + +(defun custom-initialize-frame (&optional frame) + "Initialize local faces for FRAME if necessary. +If FRAME is missing or nil, the first member (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) + (custom-relevant-frames) + (push frame custom-relevant-frames))) + +;; Enable. This should go away when bundled with Emacs. +(add-hook 'after-make-frame-hook 'custom-initialize-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 (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
--- a/lisp/custom/custom-edit.el Mon Aug 13 09:16:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1843 +0,0 @@ -;;; custom-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.46 -;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ - -;;; Commentary: -;; -;; See `custom.el'. - -;;; Code: - -(require 'custom) -(require 'widget-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) - -;;; 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 - :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)) - -(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)) - (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)) - -;;; The Custom Mode. - -(defvar custom-options nil - "Customization widgets in the current buffer.") - -(defvar custom-mode-map nil - "Keymap for `custom-mode'.") - -(unless custom-mode-map - (setq custom-mode-map (make-sparse-keymap)) - (set-keymap-parent custom-mode-map widget-keymap)) - -(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: - -\\[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. -\\[custom-set] Set all modifications. -\\[custom-save] Make all modifications default. -\\[custom-reset-current] Reset all modified options. -\\[custom-reset-saved] Reset all modified or set options. -\\[custom-reset-factory] Reset all options. - -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-menu) - (make-local-variable 'custom-options) - (run-hooks 'custom-mode-hook)) - -;;; Custom Mode Commands. - -(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 - ;; Code stolen from `help.el'. - (let ((v (variable-at-point)) - (enable-recursive-minibuffers t) - val) - (setq val (completing-read - (if v - (format "Customize variable (default %s): " v) - "Customize variable: ") - obarray 'boundp t)) - (list (if (equal val "") - v (intern val))))) - (custom-buffer-create (list (list symbol 'custom-variable)))) - -;;;###autoload -(defun customize-face (&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))) - (face-list)) - (message "Creating customization buffer...") - (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-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-mode) - (widget-insert "This is a customization buffer. -Push RET or click mouse-2 on the word ") - (widget-create 'info-link - :tag "help" - :help-echo "Push me for help." - "(custom)The Customization Buffer") - (widget-insert " for more information.\n\n") - (setq custom-options - (mapcar (lambda (entry) - (prog1 - (if (> (length options) 1) - (widget-create (nth 1 entry) - :tag (custom-unlispify-tag-name - (nth 0 entry)) - :value (nth 0 entry)) - ;; If there is only one entry, don't hide it! - (widget-create (nth 1 entry) - :custom-state 'unknown - :tag (custom-unlispify-tag-name - (nth 0 entry)) - :value (nth 0 entry))) - (unless (eq (preceding-char) ?\n) - (widget-insert "\n")) - (widget-insert "\n"))) - options)) - (mapcar 'custom-magic-reset custom-options) - (widget-create 'push-button - :tag "Set" - :help-echo "Push me to set all modifications." - :action (lambda (widget &optional event) - (custom-set))) - (widget-insert " ") - (widget-create 'push-button - :tag "Save" - :help-echo "Push me to make the modifications default." - :action (lambda (widget &optional event) - (custom-save))) - (widget-insert " ") - (widget-create 'push-button - :tag "Reset" - :help-echo "Push me to undo all modifications." - :action (lambda (widget &optional event) - (custom-reset event))) - (widget-insert " ") - (widget-create 'push-button - :tag "Done" - :help-echo "Push me to bury the buffer." - :action (lambda (widget &optional event) - (bury-buffer))) - (widget-insert "\n") - (widget-setup)) - -;;; 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 "Push me to read the manual." - :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) - -(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 "\ -Push me to 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 "\ -Push me to 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 "Push me to expand or collapse this item." - :action 'custom-level-action) - -(defun custom-level-action (widget &optional event) - "Toggle visibility for parent to WIDGET." - (let* ((parent (widget-get widget :parent)) - (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." - (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))))) - -(defun custom-load-symbol (symbol) - "Load all dependencies for SYMBOL." - (let ((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 'customize) - -(defface custom-variable-button-face '((t (:underline t :bold t))) - "Face used for pushable variable tags." - :group 'customize) - -(define-widget 'custom-variable 'custom - "Customize variable." - :format "%l%v%m%h%a" - :help-echo "Push me to 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-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)) - (options (get symbol 'custom-options)) - (child-type (or (get symbol 'custom-type) 'sexp)) - (tag (widget-get widget :tag)) - (type (let ((tmp (if (listp child-type) - (copy-list child-type) - (list child-type)))) - (when options - (widget-put tmp :options options)) - tmp)) - (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 symbol (eval (setq val (widget-value child)))) - (put symbol 'customized-value (list val))) - (t - (set 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 symbol (eval (widget-value child)))) - (t - (put symbol - 'saved-value (list (custom-quote (widget-value - child)))) - (set 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 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 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. - -(defvar custom-face-edit-args - (mapcar (lambda (att) - (list 'group - :inline t - (list 'const :format "" :value (nth 0 att)) - (nth 1 att))) - custom-face-attributes)) - -(define-widget 'custom-face-edit 'checklist - "Edit face attributes." - :format "%t: %v" - :tag "Attributes" - :extra-offset 12 - :args (mapcar (lambda (att) - (list 'group - :inline t - (list 'const :format "" :value (nth 0 att)) - (nth 1 att))) - custom-face-attributes)) - -;;; The `custom-display' Widget. - -(define-widget 'custom-display 'menu-choice - "Select a display type." - :tag "Display" - :value t - :args '((const :tag "all" t) - (checklist :offset 0 - :extra-offset 9 - :args ((group (const :format "Type: " type) - (checklist :inline t - :offset 0 - (const :format "X " - x) - (const :format "PM " - pm) - (const :format "Win32 " - win32) - (const :format "DOS " - pc) - (const :format "TTY%n" - tty))) - (group (const :format "Class: " class) - (checklist :inline t - :offset 0 - (const :format "Color " - color) - (const :format - "Grayscale " - grayscale) - (const :format "Monochrome%n" - mono))) - (group (const :format "Background: " background) - (checklist :inline t - :offset 0 - (const :format "Light " - light) - (const :format "Dark\n" - dark))))))) - -;;; The `custom-face' Widget. - -(defface custom-face-tag-face '((t (:underline t))) - "Face used for face tags." - :group 'customize) - -(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 "Push me to set or reset this face." - :documentation-property '(lambda (face) - (get-face-documentation face)) - :value-create 'custom-face-value-create - :action 'custom-face-action - :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)))))) - -(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)) - (custom-load-widget widget) - (let* ((symbol (widget-value widget)) - (edit (widget-create-child-and-convert - widget 'editable-list - :entry-format "%i %d %v" - :value (or (get symbol 'saved-face) - (get symbol 'factory-face)) - '(group :format "%v" - custom-display custom-face-edit)))) - (custom-face-state-set widget) - (widget-put widget :children (list edit))))) - -(defvar custom-face-menu - '(("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-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) - (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))) - (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) - (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)) - (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 'customize) - -(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 'customize) - -(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 "Push me to 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) - (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)) - (children (mapcar (lambda (entry) - (widget-insert "\n") - (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))) - (mapcar 'custom-magic-reset children) - (widget-put widget :children children) - (custom-group-state-update widget))))) - -(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 (eolp) - (princ "\n"))))) - -(defun custom-save-faces () - "Save all customized faces in `custom-file'." - (save-excursion - (custom-save-delete 'custom-set-faces) - (let ((standard-output (current-buffer))) - (unless (bolp) - (princ "\n")) - (princ "(custom-set-faces") - (mapatoms (lambda (symbol) - (let ((value (get symbol 'saved-face))) - (when value - (princ "\n '(") - (princ symbol) - (princ " ") - (prin1 value) - (if (or (get symbol 'factory-face) - (and (not (custom-facep symbol)) - (not (get symbol 'force-face)))) - (princ ")") - (princ " t)")))))) - (princ ")") - (unless (eolp) - (princ "\n"))))) - -(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. - -(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)))) - -(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))) - -(defun custom-group-menu-create (widget symbol) - "Ignoring WIDGET, create a menu entry for customization group SYMBOL." - (custom-menu-create symbol)) - -(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 (> custom-menu-nesting 0) - (< (length (get symbol 'custom-group)) widget-menu-max-size)) - (let ((custom-menu-nesting (1- custom-menu-nesting)) - (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 custom-menu-update () - "Update customize menu." - (interactive) - (add-hook 'custom-define-hook 'custom-menu-reset) - (let ((menu `(,(car custom-help-menu) - ,(widget-apply '(custom-group) :custom-menu 'emacs) - ,@(cdr (cdr custom-help-menu))))) - (if (fboundp 'add-submenu) - (add-submenu '("Help") menu) - (define-key global-map [menu-bar help-menu customize-menu] - (cons (car menu) (easy-menu-create-keymaps (car menu) (cdr menu))))))) - -;;; Dependencies. - -;;;###autoload -(defun custom-make-dependencies () - "Batch function to extract custom dependencies from .el files. -Usage: emacs -batch *.el -f custom-make-dependencies > deps.el" - (let ((buffers (buffer-list))) - (while buffers - (set-buffer (car buffers)) - (setq buffers (cdr buffers)) - (let ((file (buffer-file-name))) - (when (and file (string-match "\\`\\(.*\\)\\.el\\'" file)) - (goto-char (point-min)) - (condition-case nil - (let ((name (file-name-nondirectory (match-string 1 file)))) - (while t - (let ((expr (read (current-buffer)))) - (when (and (listp expr) - (memq (car expr) '(defcustom defface defgroup))) - (eval expr) - (put (nth 1 expr) 'custom-where name))))) - (error nil)))))) - (mapatoms (lambda (symbol) - (let ((members (get symbol 'custom-group)) - item where found) - (when members - (princ "(put '") - (princ symbol) - (princ " 'custom-loads '(") - (while members - (setq item (car (car members)) - members (cdr members) - where (get item 'custom-where)) - (unless (or (null where) - (member where found)) - (when found - (princ " ")) - (prin1 where) - (push where found))) - (princ "))\n")))))) - -;;; The End. - -(provide 'custom-edit) - -;; custom-edit.el ends here
--- a/lisp/custom/custom-xmas.el Mon Aug 13 09:16:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,75 +0,0 @@ -;;; custom-xmas.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.46 -;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ - -;;; Commentary: -;; -;; See `custom.el'. - -;;; Code: - -(unless (featurep 'custom) - (error "Load `custom.el' instead")) - -;; Emacs function missing in XEmacs 19.14. -(unless (fboundp 'x-color-values) - (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)))) - -;; Overwrite Emacs definition. -(defalias 'custom-facep 'find-face) - -;; Support for special XEmacs font attributes. -(autoload 'font-create-object "font" nil) - -(unless (fboundp 'face-font-name) - (defun face-font-name (face &rest args) - (apply 'face-font face args))) - -(defun custom-set-face-font-size (face size &rest args) - "Set the font of FACE to SIZE" - (let* ((font (apply 'face-font-name face args)) - (fontobj (font-create-object font))) - (set-font-size fontobj size) - (apply 'set-face-font face fontobj args))) - -(defun custom-set-face-font-family (face family &rest args) - "Set the font of FACE to FAMILY" - (let* ((font (apply 'face-font-name face args)) - (fontobj (font-create-object font))) - (set-font-family fontobj family) - (apply 'set-face-font face fontobj args))) - -(nconc custom-face-attributes - '((:family (editable-field :format "Family: %v") - custom-set-face-font-family) - (:size (editable-field :format "Size: %v") - custom-set-face-font-size))) - -;; Overwrite Emacs definition. -(defun custom-menu-reset () - "Reset customize menu." - (remove-hook 'custom-define-hook 'custom-menu-reset) - (when (fboundp 'add-submenu) - ;; XEmacs with menus. - (add-submenu '("Help") custom-help-menu))) - -(defun get-face-documentation (face) - "Get the documentation string for FACE." - (face-property face 'doc-string)) - -(defun set-face-documentation (face string) - "Set the documentation string for FACE to STRING." - (set-face-property face 'doc-string string)) - -;; custom-xmas.el ends here
--- a/lisp/custom/custom.el Mon Aug 13 09:16:54 2007 +0200 +++ b/lisp/custom/custom.el Mon Aug 13 09:17:26 2007 +0200 @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> ;; Keywords: help, faces -;; Version: 1.46 +;; Version: 1.50 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;;; Commentary: @@ -13,7 +13,9 @@ ;; ;; This file only contain the code needed to declare and initialize ;; user options. The code to customize options is autoloaded from -;; `custom-edit.el'. +;; `cus-edit.el'. + +;; The code implementing face declarations is in `cus-face.el' ;;; Code: @@ -24,57 +26,18 @@ ;; These autoloads should be deleted when the file is added to Emacs (unless (fboundp 'load-gc) - (autoload 'customize "custom-edit" nil t) - (autoload 'customize-variable "custom-edit" nil t) - (autoload 'customize-face "custom-edit" nil t) - (autoload 'customize-apropos "custom-edit" nil t) - (autoload 'customize-customized "custom-edit" nil t) - (autoload 'custom-buffer-create "custom-edit") - (autoload 'custom-menu-update "custom-edit") - (autoload 'custom-make-dependencies "custom-edit")) - -;;; Compatibility. - -(unless (fboundp 'frame-property) - ;; XEmacs function missing in Emacs 19.34. - (defun frame-property (frame property &optional default) - "Return FRAME's value for property PROPERTY." - (or (cdr (assq property (frame-parameters frame))) - default))) - -(defun custom-background-mode () - "Kludge to detect background mode." - (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 - (selected-frame) - 'background-color) - (color-instance-name - (specifier-instance - (face-background 'default)))) - (error nil))) - (< (apply '+ (x-color-values color)) - (/ (apply '+ (x-color-values "white")) - 3))) - 'dark) - (t 'light)))) - (modify-frame-parameters (selected-frame) - (list (cons 'background-mode mode))) - mode)) - -;; XEmacs and Emacs have different definitions of `facep'. -;; The Emacs definition is the useful one, so emulate that. -(if (fboundp 'facep) - (defalias 'custom-facep 'facep) - (defun custom-facep (face) - "No faces" - nil)) + ;; From cus-edit.el + (autoload 'customize "cus-edit" nil t) + (autoload 'customize-variable "cus-edit" nil t) + (autoload 'customize-face "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-menu-update "cus-edit") + (autoload 'custom-make-dependencies "cus-edit") + ;; From cus-face.el + (autoload 'custom-declare-face "cus-face") + (autoload 'custom-set-faces "cus-face")) ;;; The `defcustom' Macro. @@ -138,30 +101,6 @@ ;;; The `defface' Macro. - -;(defun get-face-documentation (face) -; "Get the documentation string for FACE." -; (get face 'face-documentation)) - -;(defun set-face-documentation (face string) -; "Set the documentation string for FACE to STRING." -; (put face 'face-documentation string)) - -(defun custom-declare-face (face spec doc &rest args) - "Like `defface', but FACE is evaluated as a normal argument." - (put face 'factory-face spec) - (when (fboundp 'facep) - (unless (and (custom-facep face) - (not (get face 'saved-face))) - ;; If the user has already created the face, respect that. - (let ((value (or (get face 'saved-face) spec))) - (custom-face-display-set face value)))) - (when (and doc (null (get-face-documentation face))) - (set-face-documentation face doc)) - (custom-handle-all-keywords face args 'custom-face) - (run-hooks 'custom-define-hook) - face) - (defmacro defface (face spec doc &rest args) "Declare FACE as a customizable face that defaults to SPEC. FACE does not need to be quoted. @@ -320,122 +259,6 @@ (unless (member load loads) (put symbol 'custom-loads (cons load loads))))) -;;; Face Utilities. - -(and (fboundp 'make-face) - (make-face 'custom-face-empty)) - -(defun custom-face-display-set (face spec &optional frame) - "Set FACE to the attributes to the first matching entry in SPEC. -Iff optional FRAME is non-nil, set it for that frame only. -See `defface' for information about SPEC." - (when (fboundp 'copy-face) - (copy-face 'custom-face-empty face frame) - (while spec - (let* ((entry (car spec)) - (display (nth 0 entry)) - (atts (nth 1 entry))) - (setq spec (cdr spec)) - (when (custom-display-match-frame display frame) - (apply 'custom-face-attribites-set face frame atts) - (setq spec nil)))))) - -(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-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! - (unless frame - (setq frame (selected-frame))) - (if (eq display t) - t - (let ((match t)) - (while (and display match) - (let* ((entry (car display)) - (req (car entry)) - (options (cdr entry))) - (setq display (cdr display)) - (cond ((eq req 'type) - (let ((type (if (fboundp 'device-type) - (device-type (frame-device frame)) - window-system))) - (setq match (memq type options)))) - ((eq req 'class) - (let ((class (if (fboundp 'device-class) - (device-class (frame-device frame)) - (frame-property frame 'display-type)))) - (setq match (memq class options)))) - ((eq req 'background) - (let ((background (or custom-background-mode - (frame-property frame 'background-mode) - (custom-background-mode)))) - (setq match (memq background options)))) - (t - (error "Unknown req `%S' with options `%S'" req options))))) - match))) - -(defconst custom-face-attributes - '((:bold (toggle :format "Bold: %[%v%]\n") custom-set-face-bold) - (:italic (toggle :format "Italic: %[%v%]\n") custom-set-face-italic) - (:underline - (toggle :format "Underline: %[%v%]\n") set-face-underline-p) - (:foreground (color :tag "Foreground") set-face-foreground) - (:background (color :tag "Background") set-face-background) - (:stipple (editable-field :format "Stipple: %v") set-face-stipple)) - "Alist of face attributes. - -The elements are of the form (KEY TYPE SET) where KEY is a symbol -identifying the attribute, TYPE is a widget type for editing the -attibute, SET is a function for setting the attribute value. - -The SET function should take three arguments, the face to modify, the -value of the attribute, and optionally the frame where the face should -be changed.") - -(defun custom-face-attribites-set (face frame &rest atts) - "For FACE on FRAME set the attributes [KEYWORD VALUE].... -Each keyword should be listed in `custom-face-attributes'. - -If FRAME is nil, set the default face." - (while atts - (let* ((name (nth 0 atts)) - (value (nth 1 atts)) - (fun (nth 2 (assq name custom-face-attributes)))) - (setq atts (cdr (cdr atts))) - (condition-case nil - (funcall fun face value frame) - (error nil))))) - -(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-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-initialize-faces (&optional frame) - "Initialize all custom faces for FRAME. -If FRAME is nil or omitted, initialize them for all frames." - (mapatoms (lambda (symbol) - (let ((spec (or (get symbol 'saved-face) - (get symbol 'factory-face)))) - (when spec - (custom-face-display-set symbol spec frame)))))) - ;;; Initializing. (defun custom-set-variables (&rest args) @@ -465,33 +288,6 @@ (put symbol 'saved-value (list value))) (setq args (cdr (cdr args))))))) -(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) - (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))))))) - ;;; Meta Customization (defcustom custom-define-hook nil @@ -510,24 +306,19 @@ ["Apropos..." customize-apropos t]) "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-reset () + "Reset customize menu." + (remove-hook 'custom-define-hook 'custom-menu-reset) + (if (string-match "XEmacs" emacs-version) + (when (fboundp 'add-submenu) + (add-submenu '("Help") custom-help-menu)) + (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)))))) ;;; The End. (provide 'custom) -(when (and (not (fboundp 'load-gc)) - (string-match "XEmacs" emacs-version)) - ;; Overwrite definitions for XEmacs. - (load-library "custom-xmas")) - -(unless (fboundp 'load-gc) - (custom-menu-reset)) - ;; custom.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/wid-browse.el Mon Aug 13 09:17:26 2007 +0200 @@ -0,0 +1,232 @@ +;;; 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.50 +;; 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)) + +(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-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) + +(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))) + +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/wid-edit.el Mon Aug 13 09:17:26 2007 +0200 @@ -0,0 +1,2383 @@ +;;; 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.50 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;;; Commentary: +;; +;; See `widget.el'. + +;;; Code: + +(require 'widget) +(require 'cl) +(autoload 'pp-to-string "pp") +(autoload 'Info-goto-node "info") + +(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. +(eval-and-compile + (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)))) + +;;; Compatibility. + +(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 + (cdr (assoc (completing-read (concat title ": ") + items nil t) + items))))) + +(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))) + + (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 + '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 + '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))) + (add-text-properties from to (list 'button widget + 'mouse-face widget-mouse-face + 'start-open t + 'end-open t + 'face face)))) + +(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))) + +;;; 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))) + +(defun widget-apply (widget property &rest args) + "Apply the value of WIDGET's PROPERTY to the widget itself. +ARGS are passed as extra argments to the function." + (apply (widget-get widget property) widget args)) + +(defun widget-value (widget) + "Extract the current value of WIDGET." + (widget-apply widget + :value-to-external (widget-apply widget :value-get))) + +(defun widget-value-set (widget value) + "Set the current value of WIDGET to VALUE." + (widget-apply widget + :value-set (widget-apply widget + :value-to-internal value))) + +(defun widget-match-inline (widget vals) + ;; In WIDGET, match the start of VALS. + (cond ((widget-get widget :inline) + (widget-apply widget :match-inline vals)) + ((and vals + (widget-apply widget :match (car vals))) + (cons (list (car vals)) (cdr vals))) + (t nil))) + +;;; 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 be a name sans extension of an xpm or xbm file located in +`widget-glyph-directory'" + (if (and (string-match "XEmacs" emacs-version) + widget-glyph-enable + (fboundp 'make-glyph) + image) + (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))) + ;; We don't want or can't use glyphs. + (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))) + +;;; 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 Comands. + +(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 field :action 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 widget :action event) + (message "You clicked on a glyph.")))) + ((event-point event) + (let ((button (get-text-property (event-point event) 'button))) + (if button + (widget-apply button :action 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 widget :action 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 button :action 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"))))))))) + (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))))) + (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) + :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) + (delete-region from to) + (set-marker from nil) + (set-marker to nil))) + +(defun widget-default-value-set (widget value) + ;; Recreate widget with new value. + (save-excursion + (goto-char (widget-get widget :from)) + (widget-apply widget :delete) + (widget-put widget :value value) + (widget-apply widget :create))) + +(defun widget-default-value-inline (widget) + ;; Wrap value in a list unless it is inline. + (if (widget-get widget :inline) + (widget-value widget) + (list (widget-value widget)))) + +(defun widget-default-menu-tag-get (widget) + ;; Use tag or value for menus. + (or (widget-get widget :menu-tag) + (widget-get widget :tag) + (widget-princ-to-string (widget-get widget :value)))) + +(defun widget-default-action (widget &optional event) + ;; Notify the parent when a widget change + (let ((parent (widget-get widget :parent))) + (when parent + (widget-apply parent :notify widget event)))) + +(defun widget-default-notify (widget child &optional event) + ;; Pass notification to parent. + (widget-default-action widget event)) + +;;; The `item' Widget. + +(define-widget 'item 'default + "Constant items for inclusion in other widgets." + :convert-widget 'widget-item-convert-widget + :value-create 'widget-item-value-create + :value-delete 'ignore + :value-get 'widget-item-value-get + :match 'widget-item-match + :match-inline 'widget-item-match-inline + :action 'widget-item-action + :format "%t\n") + +(defun widget-item-convert-widget (widget) + ;; Initialize :value 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 + :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 (concat "[" 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 widget :action (this-command-keys))) + +;;; The `link' Widget. + +(define-widget 'link 'item + "An embedded link." + :help-echo "Push me to 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") + +;;; 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)) + (from (point)) + child button) + (insert (widget-get widget :entry-format)) + (goto-char from) + ;; Parse % escapes in format. + (while (re-search-forward "%\\([bv%]\\)" nil t) + (let ((escape (aref (match-string 1) 0))) + (replace-match "" t t) + (cond ((eq escape ?%) + (insert "%")) + ((eq escape ?b) + (setq button (widget-create-child-and-convert + widget 'checkbox :value (not (null chosen))))) + ((eq escape ?v) + (setq child + (cond ((not chosen) + (widget-create-child widget type)) + ((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)) + (from (point)) + (chosen (and (null (widget-get widget :choice)) + (widget-apply type :match value))) + child button) + (insert (widget-get widget :entry-format)) + (goto-char from) + ;; Parse % escapes in format. + (while (re-search-forward "%\\([bv%]\\)" nil t) + (let ((escape (aref (match-string 1) 0))) + (replace-match "" t t) + (cond ((eq escape ?%) + (insert "%")) + ((eq escape ?b) + (setq button (widget-create-child-and-convert + widget 'radio-button + :value (not (null chosen))))) + ((eq escape ?v) + (setq child (if chosen + (widget-create-child-value + widget type value) + (widget-create-child widget type)))) + (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 + (widget-value-set current value)) + (setq found (or found match)))))) + +(defun widget-radio-validate (widget) + ;; Valid if we have made a valid choice. + (let ((children (widget-get widget :children)) + current found button) + (while (and children (not found)) + (setq current (car children) + children (cdr children) + button (widget-get current :button) + found (widget-apply button :value-get))) + (if found + (widget-apply current :validate) + widget))) + +(defun widget-radio-action (widget child event) + ;; Check if a radio button was pressed. + (let ((children (widget-get widget :children)) + (buttons (widget-get widget :buttons)) + current) + (when (memq child buttons) + (while children + (setq current (car children) + children (cdr children)) + (let* ((button (widget-get current :button))) + (cond ((eq child button) + (widget-value-set button t)) + ((widget-value button) + (widget-value-set button nil))))))) + ;; Pass notification to parent. + (widget-apply widget :notify child event)) + +;;; The `insert-button' Widget. + +(define-widget 'insert-button 'push-button + "An insert button for the `editable-list' widget." + :tag "INS" + :action 'widget-insert-button-action) + +(defun widget-insert-button-action (widget &optional event) + ;; Ask the parent to insert a new item. + (widget-apply (widget-get widget :parent) + :insert-before (widget-get widget :widget))) + +;;; The `delete-button' Widget. + +(define-widget 'delete-button 'push-button + "A delete button for the `editable-list' widget." + :tag "DEL" + :action 'widget-delete-button-action) + +(defun widget-delete-button-action (widget &optional event) + ;; Ask the parent to insert a new item. + (widget-apply (widget-get widget :parent) + :delete-at (widget-get widget :widget))) + +;;; The `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))) + (widget-create-child-and-convert widget 'insert-button)) + (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-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 (widget-create-child-and-convert + widget 'insert-button))) + ((eq escape ?d) + (setq delete (widget-create-child-and-convert + widget 'delete-button))) + ((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 "Push me to toggle the 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 ": (defalt `" 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 :value-to-internal widget 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" + :button-face-get 'widget-color-item-button-face-get) + +(defun widget-color-item-button-face-get (widget) + ;; We create a face from the value. + (require 'facemenu) + (condition-case nil + (facemenu-get-face (intern (concat "fg:" (widget-value widget)))) + (error 'default))) + +(define-widget 'color 'push-button + "Choose a color name (with sample)." + :format "%[%t%]: %v" + :tag "Color" + :value "default" + :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
--- a/lisp/custom/widget-browse.el Mon Aug 13 09:16:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,232 +0,0 @@ -;;; widget-browse.el --- Functions for browsing widgets. -;; -;; Copyright (C) 1997 Free Software Foundation, Inc. -;; -;; Author: Per Abrahamsen <abraham@dina.kvl.dk> -;; Keywords: extensions -;; Version: 1.46 -;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ - -;;; Commentary: -;; -;; Widget browser. See `widget.el'. - -;;; Code: - -(require 'easymenu) -(require 'custom) -(require 'widget-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)) - -(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-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) - -(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))) - -;;; 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 'widget-browse) - -;; widget-browse.el ends here
--- a/lisp/custom/widget-edit.el Mon Aug 13 09:16:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2384 +0,0 @@ -;;; widget-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.46 -;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ - -;;; Commentary: -;; -;; See `widget.el'. - -;;; Code: - -(require 'widget) -(require 'cl) -(autoload 'pp-to-string "pp") -(autoload 'Info-goto-node "info") - -(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. -(eval-and-compile - (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)))) - -;;; Compatibility. - -(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 'help - :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 - (cdr (assoc (completing-read (concat title ": ") - items nil t) - items))))) - -(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))) - - (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 - '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 - '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))) - (add-text-properties from to (list 'button widget - 'mouse-face widget-mouse-face - 'start-open t - 'end-open t - 'face face)))) - -(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))) - -;;; 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))) - -(defun widget-apply (widget property &rest args) - "Apply the value of WIDGET's PROPERTY to the widget itself. -ARGS are passed as extra argments to the function." - (apply (widget-get widget property) widget args)) - -(defun widget-value (widget) - "Extract the current value of WIDGET." - (widget-apply widget - :value-to-external (widget-apply widget :value-get))) - -(defun widget-value-set (widget value) - "Set the current value of WIDGET to VALUE." - (widget-apply widget - :value-set (widget-apply widget - :value-to-internal value))) - -(defun widget-match-inline (widget vals) - ;; In WIDGET, match the start of VALS. - (cond ((widget-get widget :inline) - (widget-apply widget :match-inline vals)) - ((and vals - (widget-apply widget :match (car vals))) - (cons (list (car vals)) (cdr vals))) - (t nil))) - -;;; 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 be a name sans extension of an xpm or xbm file located in -`widget-glyph-directory'" - (if (and (string-match "XEmacs" emacs-version) - widget-glyph-enable - (fboundp 'make-glyph) - image) - (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))) - ;; We don't want or can't use glyphs. - (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))) - -;;; 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 Comands. - -(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 field :action 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 widget :action event) - (message "You clicked on a glyph.")))) - ((event-point event) - (let ((button (get-text-property (event-point event) 'button))) - (if button - (widget-apply button :action 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 widget :action 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 button :action 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"))))))))) - (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))))) - (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) - :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) - (delete-region from to) - (set-marker from nil) - (set-marker to nil))) - -(defun widget-default-value-set (widget value) - ;; Recreate widget with new value. - (save-excursion - (goto-char (widget-get widget :from)) - (widget-apply widget :delete) - (widget-put widget :value value) - (widget-apply widget :create))) - -(defun widget-default-value-inline (widget) - ;; Wrap value in a list unless it is inline. - (if (widget-get widget :inline) - (widget-value widget) - (list (widget-value widget)))) - -(defun widget-default-menu-tag-get (widget) - ;; Use tag or value for menus. - (or (widget-get widget :menu-tag) - (widget-get widget :tag) - (widget-princ-to-string (widget-get widget :value)))) - -(defun widget-default-action (widget &optional event) - ;; Notify the parent when a widget change - (let ((parent (widget-get widget :parent))) - (when parent - (widget-apply parent :notify widget event)))) - -(defun widget-default-notify (widget child &optional event) - ;; Pass notification to parent. - (widget-default-action widget event)) - -;;; The `item' Widget. - -(define-widget 'item 'default - "Constant items for inclusion in other widgets." - :convert-widget 'widget-item-convert-widget - :value-create 'widget-item-value-create - :value-delete 'ignore - :value-get 'widget-item-value-get - :match 'widget-item-match - :match-inline 'widget-item-match-inline - :action 'widget-item-action - :format "%t\n") - -(defun widget-item-convert-widget (widget) - ;; Initialize :value 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 - :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 (concat "[" 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 widget :action (this-command-keys))) - -;;; The `link' Widget. - -(define-widget 'link 'item - "An embedded link." - :help-echo "Push me to 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") - -;;; 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)) - (from (point)) - child button) - (insert (widget-get widget :entry-format)) - (goto-char from) - ;; Parse % escapes in format. - (while (re-search-forward "%\\([bv%]\\)" nil t) - (let ((escape (aref (match-string 1) 0))) - (replace-match "" t t) - (cond ((eq escape ?%) - (insert "%")) - ((eq escape ?b) - (setq button (widget-create-child-and-convert - widget 'checkbox :value (not (null chosen))))) - ((eq escape ?v) - (setq child - (cond ((not chosen) - (widget-create-child widget type)) - ((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)) - (from (point)) - (chosen (and (null (widget-get widget :choice)) - (widget-apply type :match value))) - child button) - (insert (widget-get widget :entry-format)) - (goto-char from) - ;; Parse % escapes in format. - (while (re-search-forward "%\\([bv%]\\)" nil t) - (let ((escape (aref (match-string 1) 0))) - (replace-match "" t t) - (cond ((eq escape ?%) - (insert "%")) - ((eq escape ?b) - (setq button (widget-create-child-and-convert - widget 'radio-button - :value (not (null chosen))))) - ((eq escape ?v) - (setq child (if chosen - (widget-create-child-value - widget type value) - (widget-create-child widget type)))) - (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 - (widget-value-set current value)) - (setq found (or found match)))))) - -(defun widget-radio-validate (widget) - ;; Valid if we have made a valid choice. - (let ((children (widget-get widget :children)) - current found button) - (while (and children (not found)) - (setq current (car children) - children (cdr children) - button (widget-get current :button) - found (widget-apply button :value-get))) - (if found - (widget-apply current :validate) - widget))) - -(defun widget-radio-action (widget child event) - ;; Check if a radio button was pressed. - (let ((children (widget-get widget :children)) - (buttons (widget-get widget :buttons)) - current) - (when (memq child buttons) - (while children - (setq current (car children) - children (cdr children)) - (let* ((button (widget-get current :button))) - (cond ((eq child button) - (widget-value-set button t)) - ((widget-value button) - (widget-value-set button nil))))))) - ;; Pass notification to parent. - (widget-apply widget :notify child event)) - -;;; The `insert-button' Widget. - -(define-widget 'insert-button 'push-button - "An insert button for the `editable-list' widget." - :tag "INS" - :action 'widget-insert-button-action) - -(defun widget-insert-button-action (widget &optional event) - ;; Ask the parent to insert a new item. - (widget-apply (widget-get widget :parent) - :insert-before (widget-get widget :widget))) - -;;; The `delete-button' Widget. - -(define-widget 'delete-button 'push-button - "A delete button for the `editable-list' widget." - :tag "DEL" - :action 'widget-delete-button-action) - -(defun widget-delete-button-action (widget &optional event) - ;; Ask the parent to insert a new item. - (widget-apply (widget-get widget :parent) - :delete-at (widget-get widget :widget))) - -;;; The `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))) - (widget-create-child-and-convert widget 'insert-button)) - (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-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 (widget-create-child-and-convert - widget 'insert-button))) - ((eq escape ?d) - (setq delete (widget-create-child-and-convert - widget 'delete-button))) - ((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 "Push me to toggle the 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 ": (defalt `" 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 :value-to-internal widget 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" - :button-face-get 'widget-color-item-button-face-get) - -(defun widget-color-item-button-face-get (widget) - ;; We create a face from the value. - (require 'facemenu) - (condition-case nil - (facemenu-get-face (intern (concat "fg:" (widget-value widget)))) - (error 'default))) - -(define-widget 'color 'push-button - "Choose a color name (with sample)." - :format "%[%t%]: %v" - :tag "Color" - :value "default" - :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 'widget-edit) - -;; widget-edit.el ends here
--- a/lisp/custom/widget-example.el Mon Aug 13 09:16:54 2007 +0200 +++ b/lisp/custom/widget-example.el Mon Aug 13 09:17:26 2007 +0200 @@ -4,13 +4,13 @@ ;; ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> ;; Keywords: help, extensions, faces, hypermedia -;; Version: 1.46 +;; Version: 1.50 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ (require 'widget) (eval-when-compile - (require 'widget-edit)) + (require 'wid-edit)) (defvar widget-example-repeat)
--- a/lisp/custom/widget.el Mon Aug 13 09:16:54 2007 +0200 +++ b/lisp/custom/widget.el Mon Aug 13 09:17:26 2007 +0200 @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> ;; Keywords: help, extensions, faces, hypermedia -;; Version: 1.46 +;; Version: 1.50 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;;; Commentary: @@ -12,7 +12,7 @@ ;; If you want to use this code, please visit the URL above. ;; ;; This file only contain the code needed to define new widget types. -;; Everything else is autoloaded from `widget-edit.el'. +;; Everything else is autoloaded from `wid-edit.el'. ;;; Code: @@ -43,10 +43,10 @@ ;; These autoloads should be deleted when the file is added to Emacs. (unless (fboundp 'load-gc) - (autoload 'widget-create "widget-edit") - (autoload 'widget-insert "widget-edit") - (autoload 'widget-browse "widget-browse" nil t) - (autoload 'widget-browse-at "widget-browse" nil t)) + (autoload 'widget-create "wid-edit") + (autoload 'widget-insert "wid-edit") + (autoload 'widget-browse "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.
--- a/lisp/gnus/gnus-cus.el Mon Aug 13 09:16:54 2007 +0200 +++ b/lisp/gnus/gnus-cus.el Mon Aug 13 09:17:26 2007 +0200 @@ -26,7 +26,7 @@ ;;; Code: -(require 'widget-edit) +(require 'wid-edit) (require 'gnus-score) ;;; Widgets:
--- a/lisp/gnus/gnus-load.el Mon Aug 13 09:16:54 2007 +0200 +++ b/lisp/gnus/gnus-load.el Mon Aug 13 09:17:26 2007 +0200 @@ -27,14 +27,14 @@ (put 'gnus-mail 'custom-loads '("nnmail")) (put 'message-interface 'custom-loads '("message")) (put 'gnus-edit-form 'custom-loads '("gnus-eform")) -(put 'emacs 'custom-loads '("custom" "widget-edit" "message" "gnus" "custom-opt")) +(put 'emacs 'custom-loads '("custom" "wid-edit" "message" "gnus" "custom-opt")) (put 'gnus-summary-mail 'custom-loads '("gnus-sum")) (put 'gnus-topic 'custom-loads '("gnus-topic")) (put 'gnus-summary-choose 'custom-loads '("gnus-sum")) (put 'message-headers 'custom-loads '("message")) (put 'message-forwarding 'custom-loads '("message")) (put 'gnus-duplicate 'custom-loads '("gnus-dup")) -(put 'widgets 'custom-loads '("widget-edit")) +(put 'widgets 'custom-loads '("wid-edit")) (put 'earcon 'custom-loads '("earcon")) (put 'gnus-summary-format 'custom-loads '("gnus-sum")) (put 'gnus-windows 'custom-loads '("gnus-win")) @@ -47,7 +47,7 @@ (put 'message-sending 'custom-loads '("message")) (put 'message-insertion 'custom-loads '("message")) (put 'gnus-summary-sort 'custom-loads '("gnus-sum")) -(put 'customize 'custom-loads '("custom" "custom-edit")) +(put 'customize 'custom-loads '("custom" "cus-edit")) (put 'gnus-asynchronous 'custom-loads '("gnus-async")) (put 'article-mime 'custom-loads '("gnus-sum")) (put 'gnus-extract 'custom-loads '("gnus-uu" "gnus-sum"))
--- a/lisp/gnus/gnus-sum.el Mon Aug 13 09:16:54 2007 +0200 +++ b/lisp/gnus/gnus-sum.el Mon Aug 13 09:17:26 2007 +0200 @@ -2074,7 +2074,7 @@ ;; Some summary mode macros. -(defun gnus-summary-article-number () +(defmacro gnus-summary-article-number () "The article number of the article on the current line. If there isn's an article number here, then we return the current article number."
--- a/lisp/prim/auto-autoloads.el Mon Aug 13 09:16:54 2007 +0200 +++ b/lisp/prim/auto-autoloads.el Mon Aug 13 09:17:26 2007 +0200 @@ -999,55 +999,73 @@ ;;;*** -;;;### (autoloads (custom-make-dependencies custom-menu-update custom-buffer-create customize-apropos customize-customized customize-face customize-variable customize) "custom-edit" "custom/custom-edit.el") - -(autoload 'customize "custom-edit" "\ +;;;### (autoloads (custom-make-dependencies custom-menu-update custom-buffer-create customize-apropos customize-customized customize-face customize-variable customize) "cus-edit" "custom/cus-edit.el") + +(autoload 'customize "cus-edit" "\ Customize SYMBOL, which must be a customization group." t nil) -(autoload 'customize-variable "custom-edit" "\ +(autoload 'customize-variable "cus-edit" "\ Customize SYMBOL, which must be a variable." t nil) -(autoload 'customize-face "custom-edit" "\ +(autoload 'customize-face "cus-edit" "\ Customize SYMBOL, which should be a face name or nil. If SYMBOL is nil, customize all faces." t nil) -(autoload 'customize-customized "custom-edit" "\ +(autoload 'customize-customized "cus-edit" "\ Customize all already customized user options." t nil) -(autoload 'customize-apropos "custom-edit" "\ +(autoload 'customize-apropos "cus-edit" "\ Customize all user options matching REGEXP. If ALL (e.g., started with a prefix key), include options which are not user-settable." t nil) -(autoload 'custom-buffer-create "custom-edit" "\ +(autoload 'custom-buffer-create "cus-edit" "\ 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." nil nil) -(autoload 'custom-menu-update "custom-edit" "\ +(autoload 'custom-menu-update "cus-edit" "\ Update customize menu." t nil) -(autoload 'custom-make-dependencies "custom-edit" "\ +(autoload 'custom-make-dependencies "cus-edit" "\ Batch function to extract custom dependencies from .el files. Usage: emacs -batch *.el -f custom-make-dependencies > deps.el" nil nil) ;;;*** -;;;### (autoloads (widget-browse-at) "widget-browse" "custom/widget-browse.el") - -(autoload 'widget-browse-at "widget-browse" "\ +;;;### (autoloads (custom-set-faces custom-declare-face) "cus-face" "custom/cus-face.el") + +(autoload 'custom-declare-face "cus-face" "\ +Like `defface', but FACE is evaluated as a normal argument." nil nil) + +(autoload 'custom-set-faces "cus-face" "\ +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." nil nil) + +;;;*** + +;;;### (autoloads (widget-browse-at) "wid-browse" "custom/wid-browse.el") + +(autoload 'widget-browse-at "wid-browse" "\ Browse the widget under point." t nil) ;;;*** -;;;### (autoloads (widget-delete widget-create) "widget-edit" "custom/widget-edit.el") - -(autoload 'widget-create "widget-edit" "\ +;;;### (autoloads (widget-delete widget-create) "wid-edit" "custom/wid-edit.el") + +(autoload 'widget-create "wid-edit" "\ Create widget of TYPE. The optional ARGS are additional keyword arguments." nil nil) -(autoload 'widget-delete "widget-edit" "\ +(autoload 'widget-delete "wid-edit" "\ Delete WIDGET." nil nil) ;;;*** @@ -3736,7 +3754,7 @@ ;;;### (autoloads (ksh-mode) "ksh-mode" "modes/ksh-mode.el") (autoload 'ksh-mode "ksh-mode" "\ -ksh-mode $Revision: 1.12 $ - Major mode for editing (Bourne, Korn or Bourne again) +ksh-mode $Revision: 1.13 $ - Major mode for editing (Bourne, Korn or Bourne again) shell scripts. Special key bindings and commands: \\{ksh-mode-map} @@ -5088,7 +5106,7 @@ (autoload 'vhdl-mode "vhdl-mode" "\ Major mode for editing VHDL code. -vhdl-mode $Revision: 1.12 $ +vhdl-mode $Revision: 1.13 $ To submit a problem report, enter `\\[vhdl-submit-bug-report]' from a vhdl-mode buffer. This automatically sets up a mail buffer with version information already added. You just need to add a description of the
--- a/lisp/prim/faces.el Mon Aug 13 09:16:54 2007 +0200 +++ b/lisp/prim/faces.el Mon Aug 13 09:17:26 2007 +0200 @@ -1067,52 +1067,68 @@ (font-proportional-p (face-font face) domain charset)) +(defvar init-face-from-resources t + "If non-nil, attempt to initialize faces from the reseource database.") + +(defun make-empty-face (name &optional doc-string temporary) + "Like `make-face', but doesn't query the reseource database." + (let ((init-face-from-resources nil)) + (make-face name doc-string temporary))) + (defun init-face-from-resources (face &optional locale) "Initialize FACE from the resource database. If LOCALE is specified, it should be a frame, device, or 'global, and the face will be resourced over that locale. Otherwise, the face will be resourced over all possible locales (i.e. all frames, all devices, and 'global)." - (if (not locale) - (progn - (init-face-from-resources face 'global) - (let ((devices (device-list))) - (while devices - (init-face-from-resources face (car devices)) - (setq devices (cdr devices)))) - (let ((frames (frame-list))) - (while frames - (init-face-from-resources face (car frames)) - (setq frames (cdr frames))))) - (let ((devtype (cond ((devicep locale) (device-type locale)) - ((framep locale) (frame-type locale)) - (t nil)))) - (cond ((or (and (not devtype) (featurep 'x)) (eq 'x devtype)) - (x-init-face-from-resources face locale)) - ((or (not devtype) (eq 'tty devtype)) - ;; Nothing to do for TTYs? - ))))) + (cond ((null init-face-from-resources) + ;; Do nothing. + ) + ((not locale) + ;; Global, set for all frames. + (progn + (init-face-from-resources face 'global) + (let ((devices (device-list))) + (while devices + (init-face-from-resources face (car devices)) + (setq devices (cdr devices)))) + (let ((frames (frame-list))) + (while frames + (init-face-from-resources face (car frames)) + (setq frames (cdr frames)))))) + (t + ;; Specific. + (let ((devtype (cond ((devicep locale) (device-type locale)) + ((framep locale) (frame-type locale)) + (t nil)))) + (cond ((or (and (not devtype) (featurep 'x)) (eq 'x devtype)) + (x-init-face-from-resources face locale)) + ((or (not devtype) (eq 'tty devtype)) + ;; Nothing to do for TTYs? + )))))) (defun init-device-faces (device) ;; First, add any device-local face resources. - (loop for face in (face-list) do - (init-face-from-resources face device)) - ;; Then do any device-specific initialization. - (cond ((eq 'x (device-type device)) - (x-init-device-faces device)) - ;; Nothing to do for TTYs? - ) - (init-other-random-faces device)) + (when init-face-from-resources + (loop for face in (face-list) do + (init-face-from-resources face device)) + ;; Then do any device-specific initialization. + (cond ((eq 'x (device-type device)) + (x-init-device-faces device)) + ;; Nothing to do for TTYs? + ) + (init-other-random-faces device))) (defun init-frame-faces (frame) - ;; First, add any frame-local face resources. - (loop for face in (face-list) do - (init-face-from-resources face frame)) - ;; Then do any frame-specific initialization. - (cond ((eq 'x (frame-type frame)) - (x-init-frame-faces frame)) - ;; Is there anything which should be done for TTY's? - )) + (when init-face-from-resources + ;; First, add any frame-local face resources. + (loop for face in (face-list) do + (init-face-from-resources face frame)) + ;; Then do any frame-specific initialization. + (cond ((eq 'x (frame-type frame)) + (x-init-frame-faces frame)) + ;; Is there anything which should be done for TTY's? + ))) ;; #### This is somewhat X-specific, and is called when the first ;; X device is created (even if there were TTY devices created
--- a/lisp/prim/loadup.el Mon Aug 13 09:16:54 2007 +0200 +++ b/lisp/prim/loadup.el Mon Aug 13 09:17:26 2007 +0200 @@ -110,7 +110,6 @@ ;;(load-gc (if (featurep 'sparcworks) "eos/loaddefs-eos" "loaddefs")) (load-gc "widget") (load-gc "custom") ; Before loaddefs so that defcustom exists - (load-gc "custom-xmas") (load-gc "loaddefs") ; <=== autoloads get put here (load-gc "misc") (load-gc "profile")
--- a/lisp/tm/gnus-mime.el Mon Aug 13 09:16:54 2007 +0200 +++ b/lisp/tm/gnus-mime.el Mon Aug 13 09:17:26 2007 +0200 @@ -4,7 +4,7 @@ ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> ;; Created: 1996/8/6 -;; Version: $Revision: 1.3 $ +;; Version: $Revision: 1.4 $ ;; Keywords: news, MIME, multimedia, multilingual, encoded-word ;; This file is not part of GNU Emacs yet. @@ -33,7 +33,7 @@ ;;; (defconst gnus-mime-RCS-ID - "$Id: gnus-mime.el,v 1.3 1997/02/15 22:21:26 steve Exp $") + "$Id: gnus-mime.el,v 1.4 1997/03/04 08:01:31 steve Exp $") (defconst gnus-mime-version (get-version-string gnus-mime-RCS-ID)) @@ -65,7 +65,7 @@ (require 'gnus) (require 'gnus-charset) - +(require 'gnus-sum) ;;; @ for tm-partial ;;;
--- a/lisp/version.el Mon Aug 13 09:16:54 2007 +0200 +++ b/lisp/version.el Mon Aug 13 09:17:26 2007 +0200 @@ -25,7 +25,7 @@ (defconst emacs-version "20.1" "Version numbers of this version of Emacs.") -(setq emacs-version (purecopy (concat emacs-version " XEmacs Lucid (beta4)"))) +(setq emacs-version (purecopy (concat emacs-version " XEmacs Lucid (beta5)"))) (defconst emacs-major-version (progn (or (string-match "^[0-9]+" emacs-version)
--- a/lisp/x11/x-faces.el Mon Aug 13 09:16:54 2007 +0200 +++ b/lisp/x11/x-faces.el Mon Aug 13 09:17:26 2007 +0200 @@ -372,7 +372,8 @@ ;;; state where signalling an error or entering the debugger would likely ;;; result in a crash. -(defun x-init-face-from-resources (face locale) +(defun x-init-face-from-resources (face &optional locale set-anyway) + ;; ;; These are things like "attributeForeground" instead of simply ;; "foreground" because people tend to do things like "*foreground", @@ -385,7 +386,8 @@ ;; "face.attributeForeground", but they're the way they are for ;; hysterical reasons. (jwz) - (let* ((face-sym (face-name face)) + (let* ((append (if set-anyway nil 'append)) + (face-sym (face-name face)) (name (symbol-name face-sym)) (fn (x-get-resource-and-maybe-bogosity-check (concat name ".attributeFont") @@ -460,30 +462,33 @@ ;; done when the instancing actually happens, but I'm not ;; sure how it should actually be dealt with. (if fn - (set-face-font face fn locale nil 'append)) + (set-face-font face fn locale nil append)) ;; Kludge-o-rooni. Set the foreground and background resources for ;; X devices only -- otherwise things tend to get all messed up ;; if you start up an X frame and then later create a TTY frame. (if fg - (set-face-foreground face fg locale 'x 'append)) + (set-face-foreground face fg locale 'x append)) (if bg - (set-face-background face bg locale 'x 'append)) + (set-face-background face bg locale 'x append)) (if bgp - (set-face-background-pixmap face bgp locale nil 'append)) + (set-face-background-pixmap face bgp locale nil append)) (if ulp - (set-face-underline-p face ulp locale nil 'append)) + (set-face-underline-p face ulp locale nil append)) (if stp - (set-face-strikethru-p face stp locale nil 'append)) + (set-face-strikethru-p face stp locale nil append)) (if hp - (set-face-highlight-p face hp locale nil 'append)) + (set-face-highlight-p face hp locale nil append)) (if dp - (set-face-dim-p face dp locale nil 'append)) + (set-face-dim-p face dp locale nil append)) (if bp - (set-face-blinking-p face bp locale nil 'append)) + (set-face-blinking-p face bp locale nil append)) (if rp - (set-face-reverse-p face rp locale nil 'append)) + (set-face-reverse-p face rp locale nil append)) )) +;; GNU Emacs compatibility. (move to obsolete.el?) +(defalias 'make-face-x-resource-internal 'x-init-face-from-resources) + ;;; x-init-global-faces is responsible for ensuring that the ;;; default face has some reasonable fallbacks if nothing else is ;;; specified.
--- a/man/custom.texi Mon Aug 13 09:16:54 2007 +0200 +++ b/man/custom.texi Mon Aug 13 09:17:26 2007 +0200 @@ -13,7 +13,7 @@ @comment node-name, next, previous, up @top The Customization Library -Version: 1.46 +Version: 1.50 @menu * Introduction:: @@ -638,9 +638,6 @@ customize buffer. @item -Support real specifiers under XEmacs. - -@item Integrate with @file{w3} so you can customization buffers with much better formatting. I'm thinking about adding a <custom>name</custom> tag. @@ -656,11 +653,6 @@ Make it possible to append to `choice', `radio', and `set' options. @item -There should be a way to exit the buffer. - -An @sc{open look} pushpin would do wonders. - -@item Ask whether set or modified variables should be saved in @code{kill-buffer-hook}.
--- a/man/widget.texi Mon Aug 13 09:16:54 2007 +0200 +++ b/man/widget.texi Mon Aug 13 09:17:26 2007 +0200 @@ -1,6 +1,6 @@ \input texinfo.tex -@c $Id: widget.texi,v 1.4 1997/02/27 06:08:38 steve Exp $ +@c $Id: widget.texi,v 1.5 1997/03/04 08:01:33 steve Exp $ @c %**start of header @setfilename widget @@ -15,7 +15,7 @@ @comment node-name, next, previous, up @top The Emacs Widget Library -Version: 1.46 +Version: 1.50 @menu * Introduction:: @@ -115,7 +115,7 @@ @item widget.el This will declare the user variables, define the function @code{widget-define}, and autoload the function @code{widget-create}. -@item widget-edit.el +@item wid-edit.el Everything else is here, there is no reason to load it explicitly, as it will be autoloaded when needed. @end table @@ -278,7 +278,7 @@ (require 'widget) (eval-when-compile - (require 'widget-edit)) + (require 'wid-edit)) (defvar widget-example-repeat)
--- a/src/ChangeLog Mon Aug 13 09:16:54 2007 +0200 +++ b/src/ChangeLog Mon Aug 13 09:17:26 2007 +0200 @@ -1,3 +1,7 @@ +Mon Mar 3 20:37:54 1997 Steven L Baur <steve@altair.xemacs.org> + + * Makefile.in.in (lisp): Remove custom-xmas.elc. + Sat Mar 1 01:20:39 1997 Steven L Baur <steve@altair.xemacs.org> * doc.c (weird_doc): Don't print `duplicate' messages as they are
--- a/src/Makefile.in.in Mon Aug 13 09:16:54 2007 +0200 +++ b/src/Makefile.in.in Mon Aug 13 09:17:26 2007 +0200 @@ -1273,7 +1273,7 @@ ${lispdir}prim/itimer.elc ${lispdir}prim/itimer-autosave.elc \ ${lispdir}ediff/ediff-hook.elc \ ${lispdir}custom/widget.elc \ - ${lispdir}custom/custom.elc ${lispdir}custom/custom-xmas.elc \ + ${lispdir}custom/custom.elc \ ${lispdir}packages/fontl-hooks.elc SCROLLBAR_LISP \ ${lispdir}prim/buffer.elc MENUBAR_LISP \ ${lispdir}packages/buff-menu.elc DIALOG_LISP MULE_LISP NOMULE_LISP \