# HG changeset patch # User cvs # Date 1186987915 -7200 # Node ID 1917ad0d78d7aebdb7fd2bdeb977b1a08a303286 # Parent 0a3286277d9beffbe61b00e2c72dab9de87bb2a7 Import from CVS: tag r19-15b97 diff -r 0a3286277d9b -r 1917ad0d78d7 CHANGES-beta --- a/CHANGES-beta Mon Aug 13 08:51:34 2007 +0200 +++ b/CHANGES-beta Mon Aug 13 08:51:55 2007 +0200 @@ -1,4 +1,11 @@ -*- indented-text -*- +to 19.15 beta97 +-- Gnus-5.4.17 +-- Freeze frame fixes Courtesy of Jan Vroonhof and Darrell Kindred [Mistakenly + left out of beta96] +-- mine.el (almost) fully ported to XEmacs +-- Miscellaneous bug fixes. + to 19.15 beta96 -- New XEmacs logo Courtesy of Jens Lautenbacher -- New default color coordination Courtesy of Hrvoje Niksic @@ -7,7 +14,6 @@ -- some historical files removed from etc for space -- id-select.el-1.4.5 -- M-: (eval-expression) is now enabled by default --- Freeze frame fixes Courtesy of Jan Vroonhof and Darrell Kindred -- PURESIZE is now a dynamic computation -- hyperbole-4.022 -- Customized edit-faces Courtesy of Jens Lautenbacher diff -r 0a3286277d9b -r 1917ad0d78d7 Makefile.in --- a/Makefile.in Mon Aug 13 08:51:34 2007 +0200 +++ b/Makefile.in Mon Aug 13 08:51:55 2007 +0200 @@ -281,7 +281,7 @@ .RECURSIVE: ${SUBDIR} -${SUBDIR}: ${SUBDIR_MAKEFILES} src/config.h FRC +${SUBDIR}: ${SUBDIR_MAKEFILES} src/config.h src/puresize_adjust.h FRC cd $@; $(MAKE) all $(MFLAGS) \ CC='${CC}' CFLAGS='${CFLAGS}' MAKE='${MAKE}' @@ -303,6 +303,12 @@ src/config.h: ${srcdir}/src/config.h.in ./config.status +src/puresize_adjust.h: ${srcdir}/src/puresize.h + @echo "Resetting \`src/puresize_adjust.h'." + @echo '/* This file is generated by XEmacs, DO NOT MODIFY!!! */' > src/puresize_adjust.h + @echo '#define PURESIZE_ADJUSTMENT 0' >> src/puresize_adjust.h + + # ==================== Installation ==================== ## If we let lib-src do its own installation, that means we @@ -490,8 +496,6 @@ (cd dynodump && $(MAKE) $(MFLAGS) distclean) -(cd man && $(MAKE) $(MFLAGS) distclean) -${top_distclean} - (echo "/* This file is generated by XEmacs, DO NOT MODIFY!!! */" > src/PURESIZE.h) - (echo "# define PURESIZE 1350000" >> src/PURESIZE.h) ### `realclean' ### Delete everything from the current directory that can be diff -r 0a3286277d9b -r 1917ad0d78d7 configure --- a/configure Mon Aug 13 08:51:34 2007 +0200 +++ b/configure Mon Aug 13 08:51:55 2007 +0200 @@ -902,7 +902,7 @@ eval "${opt}=\"${val}\"" ;; - ## Has the user specified a value for PURESIZE? + ## Has the user specified a value for RAW_PURESIZE? "puresize" ) ## If the value was omitted, get it from the next argument. if [ "${valomitted}" = "yes" ]; then @@ -1438,7 +1438,7 @@ #### have stuck the source on a read-only partition. Instead we'll #### create it as an actual directory later on if it doesn't already #### exist. -for dir in etc man info site-lisp +for dir in lisp etc man info site-lisp do if [ ! -d $dir ]; then echo Making symbolic link to ${srcdir}/$dir @@ -1446,20 +1446,6 @@ fi done -# lisp/ is special -if [ ! -d lisp ]; then - mkdir lisp - echo Making symbolic links to lisp libraries - ${LN_S} ${srcdir}/lisp/* ./lisp - rm -f ./lisp/*.el ./lisp/site-packages - cp ${srcdir}/lisp/*.el lisp - if [ -f ${srcdir}/lisp/site-packages ]; then - cp ${srcdir}/lisp/site-packages lisp - fi -fi - -cp ${srcdir}/lisp/version.el lisp - #### Make srcdir absolute, if it isn't already. It's important to #### avoid running the path through pwd unnecessary, since pwd can #### give you automounter prefixes, which can go away. @@ -7227,12 +7213,12 @@ { test -n "$verbose" && \ -echo " defining" PURESIZE to be "${puresize}" -echo "#define" PURESIZE "${puresize}" >> confdefs.h -DEFS="$DEFS -DPURESIZE=${puresize}" -ac_sed_defs="${ac_sed_defs}\${ac_dA}PURESIZE\${ac_dB}PURESIZE\${ac_dC}${puresize}\${ac_dD} -\${ac_uA}PURESIZE\${ac_uB}PURESIZE\${ac_uC}${puresize}\${ac_uD} -\${ac_eA}PURESIZE\${ac_eB}PURESIZE\${ac_eC}${puresize}\${ac_eD} +echo " defining" RAW_PURESIZE to be "${puresize}" +echo "#define" RAW_PURESIZE "${puresize}" >> confdefs.h +DEFS="$DEFS -DRAW_PURESIZE=${puresize}" +ac_sed_defs="${ac_sed_defs}\${ac_dA}RAW_PURESIZE\${ac_dB}RAW_PURESIZE\${ac_dC}${puresize}\${ac_dD} +\${ac_uA}RAW_PURESIZE\${ac_uB}RAW_PURESIZE\${ac_uC}${puresize}\${ac_uD} +\${ac_eA}RAW_PURESIZE\${ac_eB}RAW_PURESIZE\${ac_eC}${puresize}\${ac_eD} " } diff -r 0a3286277d9b -r 1917ad0d78d7 configure.in --- a/configure.in Mon Aug 13 08:51:34 2007 +0200 +++ b/configure.in Mon Aug 13 08:51:55 2007 +0200 @@ -918,7 +918,7 @@ eval "${opt}=\"${val}\"" ;; - ## Has the user specified a value for PURESIZE? + ## Has the user specified a value for RAW_PURESIZE? "puresize" ) ## If the value was omitted, get it from the next argument. if [ "${valomitted}" = "yes" ]; then @@ -1444,7 +1444,7 @@ #### have stuck the source on a read-only partition. Instead we'll #### create it as an actual directory later on if it doesn't already #### exist. -for dir in etc man info site-lisp +for dir in lisp etc man info site-lisp do if [ ! -d $dir ]; then echo Making symbolic link to ${srcdir}/$dir @@ -1452,20 +1452,6 @@ fi done -# lisp/ is special -if [ ! -d lisp ]; then - mkdir lisp - echo Making symbolic links to lisp libraries - ${LN_S} ${srcdir}/lisp/* ./lisp - rm -f ./lisp/*.el ./lisp/site-packages - cp ${srcdir}/lisp/*.el lisp - if [ -f ${srcdir}/lisp/site-packages ]; then - cp ${srcdir}/lisp/site-packages lisp - fi -fi - -cp ${srcdir}/lisp/version.el lisp - #### Make srcdir absolute, if it isn't already. It's important to #### avoid running the path through pwd unnecessary, since pwd can #### give you automounter prefixes, which can go away. @@ -4101,7 +4087,7 @@ # autodetection. if [ x"${puresize}" != x ] ; then - ] AC_DEFINE_UNQUOTED(PURESIZE, ${puresize}) [ + ] AC_DEFINE_UNQUOTED(RAW_PURESIZE, ${puresize}) [ fi if [ "${HAVE_X_WINDOWS}" = "yes" ] ; then ] AC_DEFINE(HAVE_X_WINDOWS) [ diff -r 0a3286277d9b -r 1917ad0d78d7 etc/mine/1_16_flat.gif Binary file etc/mine/1_16_flat.gif has changed diff -r 0a3286277d9b -r 1917ad0d78d7 etc/mine/2_16_flat.gif Binary file etc/mine/2_16_flat.gif has changed diff -r 0a3286277d9b -r 1917ad0d78d7 etc/mine/3_16_flat.gif Binary file etc/mine/3_16_flat.gif has changed diff -r 0a3286277d9b -r 1917ad0d78d7 etc/mine/4_16_flat.gif Binary file etc/mine/4_16_flat.gif has changed diff -r 0a3286277d9b -r 1917ad0d78d7 etc/mine/5_16_flat.gif Binary file etc/mine/5_16_flat.gif has changed diff -r 0a3286277d9b -r 1917ad0d78d7 etc/mine/6_16_flat.gif Binary file etc/mine/6_16_flat.gif has changed diff -r 0a3286277d9b -r 1917ad0d78d7 etc/mine/7_16_flat.gif Binary file etc/mine/7_16_flat.gif has changed diff -r 0a3286277d9b -r 1917ad0d78d7 etc/mine/8_16_flat.gif Binary file etc/mine/8_16_flat.gif has changed diff -r 0a3286277d9b -r 1917ad0d78d7 etc/mine/bomb_16_flat.gif Binary file etc/mine/bomb_16_flat.gif has changed diff -r 0a3286277d9b -r 1917ad0d78d7 etc/mine/bomb_trapped_16_flat.gif Binary file etc/mine/bomb_trapped_16_flat.gif has changed diff -r 0a3286277d9b -r 1917ad0d78d7 etc/mine/empty_16_down.gif Binary file etc/mine/empty_16_down.gif has changed diff -r 0a3286277d9b -r 1917ad0d78d7 etc/mine/empty_16_flat.gif Binary file etc/mine/empty_16_flat.gif has changed diff -r 0a3286277d9b -r 1917ad0d78d7 etc/mine/empty_16_up.gif Binary file etc/mine/empty_16_up.gif has changed diff -r 0a3286277d9b -r 1917ad0d78d7 etc/mine/flagged_16_up.gif Binary file etc/mine/flagged_16_up.gif has changed diff -r 0a3286277d9b -r 1917ad0d78d7 etc/mine/question_16_up.gif Binary file etc/mine/question_16_up.gif has changed diff -r 0a3286277d9b -r 1917ad0d78d7 etc/sample.Xdefaults --- a/etc/sample.Xdefaults Mon Aug 13 08:51:34 2007 +0200 +++ b/etc/sample.Xdefaults Mon Aug 13 08:51:55 2007 +0200 @@ -29,6 +29,13 @@ ! The valid color names on your system can be found by looking in the file ! `rgb.txt', usually found in /usr/lib/X11/ or /usr/openwin/lib/X11/. +! Set the foreground and background colors of the `default' face. +! The default face colors are the base for most of the other faces' +! colors. The default background is gray80, and the default foreground +! is black. +Emacs.default.attributeBackground: gray80 +Emacs.default.attributeForeground: black + ! Set the modeline colors. Emacs.modeline*attributeForeground: Black Emacs.modeline*attributeBackground: Gray75 diff -r 0a3286277d9b -r 1917ad0d78d7 etc/xemacs-white.xpm --- a/etc/xemacs-white.xpm Mon Aug 13 08:51:34 2007 +0200 +++ b/etc/xemacs-white.xpm Mon Aug 13 08:51:55 2007 +0200 @@ -14,7 +14,7 @@ "h c #363ACC", "i c #C7C8CF", "j c #282829", -"k c #F6F6F6", +"k c #FFFFFF", "l c #13154C", "m c #7074DF", "n c #D9D9DB", diff -r 0a3286277d9b -r 1917ad0d78d7 etc/xemacs.xpm --- a/etc/xemacs.xpm Mon Aug 13 08:51:34 2007 +0200 +++ b/etc/xemacs.xpm Mon Aug 13 08:51:55 2007 +0200 @@ -12,7 +12,7 @@ "`f c #363ACC", "`g c #E5E5E6", "`h c #5458B1", -"`i c #CDCDCB", +"`i s background c None", "`j c #5256DA", "`k c #282829", "`l c #D7D7D8", diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/custom/cus-edit.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/cus-edit.el Mon Aug 13 08:51:55 2007 +0200 @@ -0,0 +1,1861 @@ +;;; cus-edit.el --- Tools for customization Emacs. +;; +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen +;; 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 diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/custom/cus-face.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/cus-face.el Mon Aug 13 08:51:55 2007 +0200 @@ -0,0 +1,434 @@ +;;; cus-face.el -- XEmacs specific custom support. +;; +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen +;; 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 diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/custom/custom-edit.el --- a/lisp/custom/custom-edit.el Mon Aug 13 08:51:34 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 -;; 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 diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/custom/custom-xmas.el --- a/lisp/custom/custom-xmas.el Mon Aug 13 08:51:34 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 -;; 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 diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/custom/custom.el --- a/lisp/custom/custom.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/custom/custom.el Mon Aug 13 08:51:55 2007 +0200 @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen ;; 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 diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/custom/wid-browse.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/wid-browse.el Mon Aug 13 08:51:55 2007 +0200 @@ -0,0 +1,232 @@ +;;; wid-browse.el --- Functions for browsing widgets. +;; +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen +;; 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 diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/custom/wid-edit.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/wid-edit.el Mon Aug 13 08:51:55 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 +;; 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 diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/custom/widget-browse.el --- a/lisp/custom/widget-browse.el Mon Aug 13 08:51:34 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 -;; 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 diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/custom/widget-edit.el --- a/lisp/custom/widget-edit.el Mon Aug 13 08:51:34 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 -;; 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 diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/custom/widget-example.el --- a/lisp/custom/widget-example.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/custom/widget-example.el Mon Aug 13 08:51:55 2007 +0200 @@ -4,13 +4,13 @@ ;; ;; Author: Per Abrahamsen ;; 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) diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/custom/widget.el --- a/lisp/custom/widget.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/custom/widget.el Mon Aug 13 08:51:55 2007 +0200 @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen ;; 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. diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/epoch/epoch.el --- a/lisp/epoch/epoch.el Mon Aug 13 08:51:34 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,5 +0,0 @@ -;; -;; The lisp side of the Epoch functionality has not yet been written. -;; For information concerning the Epoch compatibility, contact -;; Chuck Thompson -;; diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/games/mine.el --- a/lisp/games/mine.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/games/mine.el Mon Aug 13 08:51:55 2007 +0200 @@ -38,7 +38,7 @@ ;; number decreases by one, even if you incorrectly mark a square. ;; To hit a square: Point to the square, and click the left button. -;; If the square is a mine, you loose. +;; If the square is a mine, you lose. ;; If the square isn't a mine, a number appears, which represents ;; the number of mines in the surrounding eight squares. @@ -93,8 +93,9 @@ (defvar mine-mines-% 16 "*Percentage (between 0 and 100) of mines in the mine field.") -(defvar mine-torus 't - "*Non-nil (the default) to play the game on a periodic board (a torus).") +(defvar mine-torus (not mine-xemacs-p) + "*Non-nil to play the game on a periodic board (a torus). +This is the default unless using graphics (XEmacs)") (defvar mine-nb-tiles-x 2 "*Number of duplications in the x direction, when `mine-torus' is non-nil. @@ -206,6 +207,32 @@ ;;; ================================================================ ;;; Internal variables: +;; XEmacs stuffs +(defvar mine-glyph-directory (concat data-directory "mine") + "Directory where mine glyphs are kept.") +(defun mine-make-glyph (file) + (when mine-xemacs-p + (make-glyph (list (cons 'x + (expand-file-name file mine-glyph-directory)))))) +(defvar mine-default-glyphs + `((mine-face-unmarked . ,(mine-make-glyph "empty_16_up.gif")) + (mine-face-marked . ,(mine-make-glyph "flagged_16_up.gif")) + (0 . ,(mine-make-glyph "empty_16_flat.gif")) + (1 . ,(mine-make-glyph "1_16_flat.gif")) + (2 . ,(mine-make-glyph "2_16_flat.gif")) + (3 . ,(mine-make-glyph "3_16_flat.gif")) + (4 . ,(mine-make-glyph "4_16_flat.gif")) + (5 . ,(mine-make-glyph "5_16_flat.gif")) + (6 . ,(mine-make-glyph "6_16_flat.gif")) + (7 . ,(mine-make-glyph "7_16_flat.gif")) + (8 . ,(mine-make-glyph "8_16_flat.gif")) + (mine-face-pad . ,(mine-make-glyph "empty_16_down.gif")) + (mine-face-not-found . ,(mine-make-glyph "bomb_16_flat.gif")) + (mine-face-bogus . ,(mine-make-glyph "question_16_up.gif")) + ) + "A-list of default graphics for various mine characters. Unless you +have an entire replacement set of graphics I wouldn't suggest changing it.") + (defvar mine-user-variables '("Size" mine-xmax mine-ymax mine-mines-% @@ -302,7 +329,7 @@ move the mouse over the square and press `\\[mine-mouse-hit]' or move the cursor with the usual keys and press `\\[mine-hit-curpoint]'. -If the square is a mine, you loose. +If the square is a mine, you lose. If the square isn't a mine, a number appears which represents the number of mines in the surrounding eight squares. @@ -486,7 +513,7 @@ ((mine-mine-at-point-p (point) 'slowp) (setq mine-nb-mines-hit (1+ mine-nb-mines-hit)) (mine-update-mines-hit) - (mine-message 'mine-msg-loose) + (mine-message 'mine-msg-lose) (mine-quit)) (t ;; the real job... (let* ((x.y (mine-top-left (mine-point-to-x.y (point)))) @@ -864,6 +891,10 @@ (defun mine-get-face (key) (cdr (assoc key mine-faces))) +(defun mine-get-glyph (key) + (if mine-xemacs-p + (cdr (assoc key mine-default-glyphs)) + nil)) ;;; ================================================================ ;;; Init board @@ -908,7 +939,9 @@ (t (min window-ymax-int (* mine-ymax mine-nb-tiles-y)))))))) (let ((buffer-read-only 'nil) (face-unmarked (mine-get-face 'mine-face-unmarked)) + (glyph-unmarked (mine-get-glyph 'mine-face-unmarked)) (face-pad (mine-get-face 'mine-face-pad)) + (glyph-pad (mine-get-glyph 'mine-face-pad)) row col) (erase-buffer) (mine-insert-copyright) @@ -919,16 +952,31 @@ (while (>= (setq row (1- row)) 0) (setq col (1- mine-width)) (insert mine-char-unmarked) - (when face-unmarked + (when (and (not glyph-unmarked) face-unmarked) (put-text-property (1- (point)) (point) 'face face-unmarked)) + (when glyph-unmarked + (let ((e)) + (setq e (make-extent (1- (point)) (point))) + (set-extent-property e 'invisible t) + (set-extent-property e 'end-open t) + (set-extent-property e 'start-open nil) + (set-extent-end-glyph e glyph-unmarked))) (while (>= (setq col (1- col)) 0) (when mine-char-pad (insert mine-char-pad) (when face-pad (put-text-property (1- (point)) (point) 'face face-pad))) (insert mine-char-unmarked) - (when face-unmarked - (put-text-property (1- (point)) (point) 'face face-unmarked))) + (when (and (not glyph-unmarked) face-unmarked) + (put-text-property (1- (point)) (point) 'face face-unmarked)) + (when glyph-unmarked + (let ((e)) + (setq e (make-extent (1- (point)) (point))) + (set-extent-property e 'invisible t) + (set-extent-property e 'end-open t) + (set-extent-property e 'start-open nil) + (set-extent-end-glyph e glyph-unmarked)))) + (insert ?\n)) (setq mine-point-max (1- (point))) (mine-update-remaining-mines) @@ -1000,24 +1048,32 @@ (defun mine-update-board (point c key) (let ((buffer-read-only 'nil) (face (mine-get-face key)) + (glyph (mine-get-glyph key)) (x.y (mine-top-left (mine-point-to-x.y point))) x y) (setq x (car x.y)) (while (<= x mine-width) (setq y (cdr x.y)) (while (<= y mine-height) - (mine-update-point (mine-xy-to-point x y) c face) + (mine-update-point (mine-xy-to-point x y) c face glyph) (setq y (+ y mine-ymax))) (setq x (+ x mine-xmax))) (mine-reach-level 1) ; redisplay point and its periodic images (set-buffer-modified-p 'nil))) -(defun mine-update-point (point c face) +(defun mine-update-point (point c face &optional glyph) (goto-char point) - (delete-char 1) - (insert c) - (when face + (if glyph + (progn + (insert c) + (delete-char 1)) + (delete-char 1) + (insert c)) + (when (and (not glyph) face) (put-text-property point (point) 'face face)) + (when glyph + ;; (set-extent-end-glyph (extent-at (point)) nil) + (set-extent-end-glyph (extent-at (point) nil 'end-glyph nil 'at) glyph)) (mine-reach-level 0)) ; redisplay point (defun mine-reach-level (level) @@ -1119,7 +1175,7 @@ (message "Point has already been hit.")) ((eq msg 'mine-msg-cannot-mark) (message "Can't (un)mark point...")) - ((eq msg 'mine-msg-loose) + ((eq msg 'mine-msg-lose) (message "Sorry... There's a mine here...") (sit-for 1) (message "Sorry... There's a mine here... You lost!")) diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/gnus/ChangeLog --- a/lisp/gnus/ChangeLog Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/gnus/ChangeLog Mon Aug 13 08:51:55 2007 +0200 @@ -1,3 +1,94 @@ +Sun Mar 2 04:40:48 1997 Lars Magne Ingebrigtsen + + * gnus.el: Gnus v5.4.17 is released. + +Sun Mar 2 04:01:29 1997 Lars Magne Ingebrigtsen + + * message.el (message-mail): Don't `list' other-headers. + +Sat Mar 1 22:46:37 1997 Per Abrahamsen + + * gnus.el: Added mail keyword. + (gnus): Add to mail and news customization groups. + (gnus-visual): Added to the faces customization group. + * message.el (message): Add to mail and news customization groups. + + * gnus-cus.el (wid-edit): Changed from widget-edit. + +Sun Mar 2 03:44:07 1997 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-respool-query): Use it. + + * gnus.el (gnus-narrow-to-body): New function. + + * nnfolder.el (nnfolder-active-number): Simplify. + +Sun Mar 2 03:26:57 1997 Joev Dubach + + * gnus-art.el (article-make-date-line): Add "Date: ". + +Sun Mar 2 02:54:13 1997 Lars Magne Ingebrigtsen + + * gnus-uu.el (gnus-quote-arg-for-sh-or-csh): Also escape {}. + + * gnus-srvr.el (gnus-server-prepare): Don't insert servers twice. + + * nnmail.el (nnmail-read-passwd): Conditionalize + `ange-ftp-read-passwd'. + +Sat Mar 1 17:53:05 1997 Hrvoje Niksic + + * gnus-xmas.el (gnus-xmas-read-event-char): Exit on button-press + event. + + * nnml.el (nnml-retrieve-headers): Make sure file is non-nil. + +Sun Mar 2 02:43:46 1997 Lars Magne Ingebrigtsen + + * nndoc.el (nndoc-type-alist): Have rfc934 separators handled + better. + + * nnmail.el (nnmail-move-inbox): Take heed of the return value + from movemail. + +Fri Feb 21 19:54:24 1997 Hrvoje Niksic + + * gnus-xmas.el (gnus-xmas-redefine): Use `region-active-p'. + (gnus-xmas-region-active-p): Removed. + +Sun Mar 2 02:16:38 1997 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-update-article-line): Only insert + Subject string when needed. + + * gnus-util.el (gnus-output-to-mail): Quote all "From " lines. + +Sun Mar 2 02:13:17 1997 David Martin + + * nndir.el (nndir): Use `nnml-close-group'. + +Sun Mar 2 01:51:21 1997 Lars Magne Ingebrigtsen + + * gnus-start.el (gnus-init-file): Changed default. + + * gnus-group.el (gnus-ephemeral-group-server): New server. + (gnus-group-read-ephemeral-group): Use it to use unique servers. + +Sat Mar 1 04:06:11 1997 Lars Magne Ingebrigtsen + + * gnus-art.el (gnus-article-mode): Made `gnus-button-marker-list' + buffer-local. + (gnus-article-add-buttons): Don't buttonize the same article + twice. + + * gnus-sum.el (gnus-set-mode-line): Chop better. + + * gnus-art.el (gnus-article-treat-html): Not a new function. + Uh-uh. No way. I don't even exist. + + * gnus-cite.el (gnus-article-fill-cited-article): Bind + filladapt-mode to nil. + Sat Mar 1 03:51:18 1997 Lars Magne Ingebrigtsen * gnus.el: Gnus v5.4.16 is released. diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/gnus/gnus-art.el --- a/lisp/gnus/gnus-art.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/gnus/gnus-art.el Mon Aug 13 08:51:55 2007 +0200 @@ -1083,6 +1083,34 @@ (goto-char cur) nil))) +(eval-and-compile + (autoload 'w3-parse-buffer "w3-parse")) + +(defun gnus-article-treat-html () + "Render HTML." + (interactive) + (let ((cbuf (current-buffer))) + (set-buffer gnus-article-buffer) + (let (buf buffer-read-only b e) + (goto-char (point-min)) + (narrow-to-region + (if (search-forward "\n\n" nil t) + (setq b (point)) + (point-max)) + (setq e (point-max))) + (nnheader-temp-write nil + (insert-buffer-substring gnus-article-buffer b e) + (save-window-excursion + (setq buf (car (w3-parse-buffer (current-buffer)))))) + (when buf + (delete-region (point-min) (point-max)) + (insert-buffer-substring buf) + (kill-buffer buf)) + (widen) + (goto-char (point-min)) + (set-window-start (get-buffer-window (current-buffer)) (point-min)) + (set-buffer cbuf)))) + (defun gnus-article-hidden-arg () "Return the current prefix arg as a number, or 0 if no prefix." (list (if current-prefix-arg @@ -1205,7 +1233,8 @@ (concat "Date: " date "\n")) ;; Let the user define the format. ((eq type 'user) - (concat + (concat + "Date: " (format-time-string gnus-article-time-format (ignore-errors (gnus-encode-date @@ -1285,7 +1314,8 @@ (article-date-ut 'lapsed highlight)) (defun article-date-user (&optional highlight) - "Convert the current article date to the user-defined format." + "Convert the current article date to the user-defined format. +This format is defined by the `gnus-article-time-format' variable." (interactive (list t)) (article-date-ut 'user highlight)) @@ -1749,6 +1779,7 @@ (use-local-map gnus-article-mode-map) (gnus-update-format-specifications nil 'article-mode) (set (make-local-variable 'page-delimiter) gnus-page-delimiter) + (set (make-local-variable 'gnus-button-marker-list) nil) (gnus-set-default-directory) (buffer-disable-undo (current-buffer)) (setq buffer-read-only t) @@ -2689,8 +2720,14 @@ (save-excursion (set-buffer gnus-article-buffer) ;; Remove all old markers. - (while gnus-button-marker-list - (set-marker (pop gnus-button-marker-list) nil)) + (let (marker entry) + (while (setq marker (pop gnus-button-marker-list)) + (goto-char marker) + (when (setq entry (gnus-button-entry)) + (put-text-property (match-beginning (nth 1 entry)) + (match-end (nth 1 entry)) + 'gnus-callback nil)) + (set-marker marker nil))) (let ((buffer-read-only nil) (inhibit-point-motion-hooks t) (case-fold-search t) @@ -2710,9 +2747,10 @@ (from (match-beginning 0))) (when (and (or (eq t (nth 1 entry)) (eval (nth 1 entry))) - (not (gnus-button-in-region-p from end 'gnus-callback))) + (not (gnus-button-in-region-p + start end 'gnus-callback))) ;; That optional form returned non-nil, so we add the - ;; button. + ;; button. (gnus-article-add-button start end 'gnus-button-push (car (push (set-marker (make-marker) from) diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/gnus/gnus-cite.el --- a/lisp/gnus/gnus-cite.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/gnus/gnus-cite.el Mon Aug 13 08:51:55 2007 +0200 @@ -419,6 +419,7 @@ (inhibit-point-motion-hooks t) (marks (gnus-dissect-cited-text)) (adaptive-fill-mode nil) + (filladapt-mode nil) (fill-column (if width (prefix-numeric-value width) fill-column))) (save-restriction (while (cdr marks) diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/gnus/gnus-cus.el --- a/lisp/gnus/gnus-cus.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/gnus/gnus-cus.el Mon Aug 13 08:51:55 2007 +0200 @@ -26,7 +26,7 @@ ;;; Code: -(require 'widget-edit) +(require 'wid-edit) (require 'gnus-score) ;;; Widgets: diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/gnus/gnus-group.el --- a/lisp/gnus/gnus-group.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/gnus/gnus-group.el Mon Aug 13 08:51:55 2007 +0200 @@ -1544,6 +1544,8 @@ (gnus)) (gnus-group-read-group nil nil group)) +(defvar gnus-ephemeral-group-server 0) + ;; Enter a group that is not in the group buffer. Non-nil is returned ;; if selection was successful. (defun gnus-group-read-ephemeral-group (group method &optional activate @@ -1555,6 +1557,13 @@ If REQUEST-ONLY, don't actually read the group; just request it. Return the name of the group is selection was successful." + ;; Transform the select method into a unique server. + (let ((saddr (intern (format "%s-address" (car method))))) + (setq method (gnus-copy-sequence method)) + (unless (assq saddr method) + (nconc method `((,saddr ,(cadr method))))) + (setf (cadr method) (format "%s-%d" (cadr method) + (incf gnus-ephemeral-group-server)))) (let ((group (if (gnus-group-foreign-p group) group (gnus-group-prefixed-name group method)))) (gnus-sethash diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/gnus/gnus-load.el --- a/lisp/gnus/gnus-load.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/gnus/gnus-load.el Mon Aug 13 08:51:55 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")) diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/gnus/gnus-srvr.el --- a/lisp/gnus/gnus-srvr.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/gnus/gnus-srvr.el Mon Aug 13 08:51:55 2007 +0200 @@ -207,16 +207,16 @@ (setq gnus-inserted-opened-servers nil) ;; First we do the real list of servers. (while alist - (unless (member (caar alist) done) - (push (caar alist) done) + (unless (member (cdar alist) done) + (push (cdar alist) done) (cdr (setq server (pop alist))) (when (and server (car server) (cdr server)) (gnus-server-insert-server-line (car server) (cdr server))))) ;; Then we insert the list of servers that have been opened in ;; this session. (while opened - (unless (member (cadaar opened) done) - (push (cadaar opened) done) + (unless (member (caar opened) done) + (push (caar opened) done) (gnus-server-insert-server-line (setq op-ser (format "%s:%s" (caaar opened) (nth 1 (caar opened)))) (caar opened)) diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/gnus/gnus-start.el --- a/lisp/gnus/gnus-start.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/gnus/gnus-start.el Mon Aug 13 08:51:55 2007 +0200 @@ -394,7 +394,7 @@ ;; Suggested by Brian Edmonds . (defvar gnus-init-inhibit nil) (defun gnus-read-init-file (&optional inhibit-next) - ;; Don't load .gnus if -q option was used. + ;; Don't load .gnus if the -q option was used. (when init-file-user (if gnus-init-inhibit (setq gnus-init-inhibit nil) diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/gnus/gnus-sum.el --- a/lisp/gnus/gnus-sum.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/gnus/gnus-sum.el Mon Aug 13 08:51:55 2007 +0200 @@ -1282,7 +1282,8 @@ "r" gnus-summary-caesar-message "t" gnus-article-hide-headers "v" gnus-summary-verbose-headers - "m" gnus-summary-toggle-mime) + "m" gnus-summary-toggle-mime + "h" gnus-article-treat-html) (gnus-define-keys (gnus-summary-wash-hide-map "W" gnus-summary-wash-map) "a" gnus-article-hide @@ -2913,7 +2914,19 @@ header level nil (gnus-article-mark article) (memq article gnus-newsgroup-replied) (memq article gnus-newsgroup-expirable) - (mail-header-subject header) + ;; Only insert the Subject string when it's different + ;; from the previous Subject string. + (unless (gnus-subject-equal + (condition-case () + (mail-header-subject + (gnus-data-header + (cadr + (gnus-data-find-list + article + (gnus-data-list t))))) + (error "")) + (mail-header-subject header)) + (mail-header-subject header)) nil (cdr (assq article gnus-newsgroup-scored)) (memq article gnus-newsgroup-processable)) (when length @@ -3868,15 +3881,21 @@ (gnus-mode-string-quote (mail-header-subject gnus-current-headers)) "")) - max-len + bufname-length max-len gnus-tmp-header);; passed as argument to any user-format-funcs (setq mode-string (eval mformat)) + (setq bufname-length (if (string-match "%b" mode-string) + (- (length + (buffer-name + (if (eq where 'summary) + nil + (get-buffer gnus-article-buffer)))) + 2) + 0)) (setq max-len (max 4 (if gnus-mode-non-string-length (- (window-width) gnus-mode-non-string-length - (if (string-match "%%b" mode-string) - (length (buffer-name)) - 0)) + bufname-length) (length mode-string)))) ;; We might have to chop a bit of the string off... (when (> (length mode-string) max-len) @@ -6974,9 +6993,7 @@ (save-excursion (set-buffer gnus-article-buffer) (save-restriction - (goto-char (point-min)) - (search-forward "\n\n") - (narrow-to-region (point-min) (point)) + (gnus-narrow-to-body) (message "This message would go to %s" (mapconcat 'car (nnmail-article-group 'identity) ", ")))))) diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/gnus/gnus-util.el --- a/lisp/gnus/gnus-util.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/gnus/gnus-util.el Mon Aug 13 08:51:55 2007 +0200 @@ -777,8 +777,13 @@ (erase-buffer) (insert-buffer-substring artbuf) (goto-char (point-min)) - (unless (looking-at "From ") + (if (looking-at "From ") + (forward-line 1) (insert "From nobody " (current-time-string) "\n")) + (let (case-fold-search) + (while (re-search-forward "^From " nil t) + (beginning-of-line) + (insert ">"))) ;; Decide whether to append to a file or to an Emacs buffer. (let ((outbuf (get-file-buffer filename))) (if (not outbuf) diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/gnus/gnus-uu.el --- a/lisp/gnus/gnus-uu.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/gnus/gnus-uu.el Mon Aug 13 08:51:55 2007 +0200 @@ -1695,7 +1695,7 @@ (defun gnus-quote-arg-for-sh-or-csh (arg) (let ((pos 0) new-pos accum) ;; *** bug: we don't handle newline characters properly - (while (setq new-pos (string-match "[!`\"$\\& \t]" arg pos)) + (while (setq new-pos (string-match "[!`\"$\\& \t{}]" arg pos)) (push (substring arg pos new-pos) accum) (push "\\" accum) (push (list (aref arg new-pos)) accum) diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/gnus/gnus-xmas.el --- a/lisp/gnus/gnus-xmas.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/gnus/gnus-xmas.el Mon Aug 13 08:51:55 2007 +0200 @@ -328,7 +328,9 @@ (let ((event (next-command-event))) (sit-for 0) ;; We junk all non-key events. Is this naughty? - (while (not (key-press-event-p event)) + (while (not (or (key-press-event-p event) + (button-press-event-p event))) + (dispatch-event event) (setq event (next-command-event))) (cons (and (key-press-event-p event) (event-to-character event)) @@ -437,10 +439,6 @@ (color-instance-rgb-components (make-color-instance color)))))) -(defun gnus-xmas-region-active-p () - (and (fboundp 'region-active-p) - (region-active-p))) - (defun gnus-xmas-redefine () "Redefine lots of Gnus functions for XEmacs." (fset 'gnus-summary-make-display-table 'ignore) @@ -461,7 +459,7 @@ (fset 'gnus-mode-line-buffer-identification 'gnus-xmas-mode-line-buffer-identification) (fset 'gnus-key-press-event-p 'key-press-event-p) - (fset 'gnus-region-active-p 'gnus-xmas-region-active-p) + (fset 'gnus-region-active-p 'region-active-p) (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add) (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add) diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/gnus/gnus.el --- a/lisp/gnus/gnus.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/gnus/gnus.el Mon Aug 13 08:51:55 2007 +0200 @@ -3,7 +3,7 @@ ;; Author: Masanobu UMEDA ;; Lars Magne Ingebrigtsen -;; Keywords: news +;; Keywords: news, mail ;; This file is part of GNU Emacs. @@ -33,7 +33,8 @@ (defgroup gnus nil "The coffee-brewing, all singing, all dancing, kitchen sink newsreader." - :group 'emacs) + :group 'news + :group 'mail) (defgroup gnus-start nil "Starting your favorite newsreader." @@ -184,7 +185,8 @@ ;; Other (defgroup gnus-visual nil "Options controling the visual fluff." - :group 'gnus) + :group 'gnus + :group 'faces) (defgroup gnus-files nil "Files used by Gnus." @@ -223,7 +225,7 @@ :link '(custom-manual "(gnus)Exiting Gnus") :group 'gnus) -(defconst gnus-version-number "5.4.16" +(defconst gnus-version-number "5.4.17" "Version number for this version of Gnus.") (defconst gnus-version (format "Gnus v%s" gnus-version-number) @@ -2308,6 +2310,15 @@ group nil))) name)) +(defun gnus-narrow-to-body () + "Narrow to the body of an article." + (narrow-to-region + (progn + (goto-char (point-min)) + (or (search-forward "\n\n" nil t) + (point-max))) + (point-max))) + ;;; ;;; Kill file handling. diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/gnus/message.el --- a/lisp/gnus/message.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/gnus/message.el Mon Aug 13 08:51:55 2007 +0200 @@ -45,7 +45,8 @@ (user-full-name custom-variable)) "Mail and news message composing." :link '(custom-manual "(message)Top") - :group 'emacs) + :group 'mail + :group 'news) (put 'user-mail-address 'custom-type 'string) (put 'user-full-name 'custom-type 'string) @@ -2234,7 +2235,9 @@ ".fsf"))) (defun message-number-base36 (num len) - (if (if (< len 0) (<= num 0) (= len 0)) + (if (if (< len 0) + (<= num 0) + (= len 0)) "" (concat (message-number-base36 (/ num 36) (1- len)) (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210" @@ -2789,7 +2792,7 @@ (message-setup (nconc `((To . ,(or to "")) (Subject . ,(or subject ""))) - (when other-headers (list other-headers)))))) + (when other-headers other-headers))))) ;;;###autoload (defun message-news (&optional newsgroups subject) diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/gnus/nndir.el --- a/lisp/gnus/nndir.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/gnus/nndir.el Mon Aug 13 08:51:55 2007 +0200 @@ -92,7 +92,7 @@ (nnml-retrieve-headers 0 nndir-current-group 0 0) (nnmh-request-article 0 nndir-current-group 0 0) (nnmh-request-group nndir-current-group 0 0) - (nnmh-close-group nndir-current-group 0) + (nnml-close-group nndir-current-group 0) (nnmh-request-list (nnoo-current-server 'nndir) nndir-directory) (nnmh-request-newsgroups (nnoo-current-server 'nndir) nndir-directory)) diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/gnus/nndoc.el --- a/lisp/gnus/nndoc.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/gnus/nndoc.el Mon Aug 13 08:51:55 2007 +0200 @@ -65,8 +65,8 @@ (body-end . "^-+ End of forwarded message -+$") (prepare-body-function . nndoc-unquote-dashes)) (rfc934 - (article-begin . "^-.*\n+") - (body-end . "^-.*$") + (article-begin . "^--.*\n+") + (body-end . "^--.*$") (prepare-body-function . nndoc-unquote-dashes)) (clari-briefs (article-begin . "^ \\*") diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/gnus/nnfolder.el --- a/lisp/gnus/nnfolder.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/gnus/nnfolder.el Mon Aug 13 08:51:55 2007 +0200 @@ -601,20 +601,16 @@ (nnmail-activate 'nnfolder))) (defun nnfolder-active-number (group) - (when group - (save-excursion - ;; Find the next article number in GROUP. - (prog1 - (let ((active (cadr (assoc group nnfolder-group-alist)))) - (if active - (setcdr active (1+ (cdr active))) - ;; This group is new, so we create a new entry for it. - ;; This might be a bit naughty... creating groups on the drop of - ;; a hat, but I don't know... - (push (list group (setq active (cons 1 1))) - nnfolder-group-alist)) - (cdr active)) - (nnfolder-possibly-activate-groups group))))) + ;; Find the next article number in GROUP. + (let ((active (cadr (assoc group nnfolder-group-alist)))) + (if active + (setcdr active (1+ (cdr active))) + ;; This group is new, so we create a new entry for it. + ;; This might be a bit naughty... creating groups on the drop of + ;; a hat, but I don't know... + (push (list group (setq active (cons 1 1))) + nnfolder-group-alist)) + (cdr active))) ;; This method has a problem if you've accidentally let the active list get diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/gnus/nnmail.el --- a/lisp/gnus/nnmail.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/gnus/nnmail.el Mon Aug 13 08:51:55 2007 +0200 @@ -532,7 +532,7 @@ (delete-file nnmail-crash-box)) (let ((inbox (file-truename (expand-file-name inbox))) (tofile (file-truename (expand-file-name nnmail-crash-box))) - movemail popmail errors) + movemail popmail errors result) (if (setq popmail (string-match "^po:" (file-name-nondirectory inbox))) (setq inbox (file-name-nondirectory inbox)) @@ -582,16 +582,18 @@ (let ((default-directory "/")) (if (nnheader-functionp nnmail-movemail-program) (funcall nnmail-movemail-program inbox tofile) - (apply - 'call-process - (append - (list - (expand-file-name - nnmail-movemail-program exec-directory) - nil errors nil inbox tofile) - (when nnmail-internal-password - (list nnmail-internal-password)))))) - (if (not (buffer-modified-p errors)) + (setq result + (apply + 'call-process + (append + (list + (expand-file-name + nnmail-movemail-program exec-directory) + nil errors nil inbox tofile) + (when nnmail-internal-password + (list nnmail-internal-password))))))) + (if (and (not (buffer-modified-p errors)) + (zerop result)) ;; No output => movemail won (progn (unless popmail @@ -617,8 +619,8 @@ (when (looking-at "movemail: ") (delete-region (point-min) (match-end 0))) (unless (yes-or-no-p - (format "movemail: %s. Continue? " - (buffer-string))) + (format "movemail: %s (%d return). Continue? " + (buffer-string) result)) (error "%s" (buffer-string))) (setq tofile nil))))))) (message "Getting mail from %s...done" inbox) @@ -1573,7 +1575,8 @@ (unless nnmail-read-passwd (if (load "passwd" t) (setq nnmail-read-passwd 'read-passwd) - (autoload 'ange-ftp-read-passwd "ange-ftp") + (unless (fboundp 'ange-ftp-read-passwd) + (autoload 'ange-ftp-read-passwd "ange-ftp")) (setq nnmail-read-passwd 'ange-ftp-read-passwd))) (funcall nnmail-read-passwd prompt))) diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/gnus/nnml.el --- a/lisp/gnus/nnml.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/gnus/nnml.el Mon Aug 13 08:51:55 2007 +0200 @@ -106,7 +106,8 @@ (while sequence (setq article (car sequence)) (setq file (nnml-article-to-file article)) - (when (and (file-exists-p file) + (when (and file + (file-exists-p file) (not (file-directory-p file))) (insert (format "221 %d Article retrieved.\n" article)) (setq beg (point)) diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/hm--html-menus/tmpl-minor-mode.el Binary file lisp/hm--html-menus/tmpl-minor-mode.el has changed diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/prim/auto-autoloads.el --- a/lisp/prim/auto-autoloads.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/prim/auto-autoloads.el Mon Aug 13 08:51:55 2007 +0200 @@ -899,55 +899,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) ;;;*** @@ -1863,7 +1881,7 @@ move the mouse over the square and press `\\[mine-mouse-hit]' or move the cursor with the usual keys and press `\\[mine-hit-curpoint]'. -If the square is a mine, you loose. +If the square is a mine, you lose. If the square isn't a mine, a number appears which represents the number of mines in the surrounding eight squares. @@ -3638,7 +3656,7 @@ ;;;### (autoloads (ksh-mode) "ksh-mode" "modes/ksh-mode.el") (autoload 'ksh-mode "ksh-mode" "\ -ksh-mode $Revision: 1.9 $ - Major mode for editing (Bourne, Korn or Bourne again) +ksh-mode $Revision: 1.10 $ - Major mode for editing (Bourne, Korn or Bourne again) shell scripts. Special key bindings and commands: \\{ksh-mode-map} @@ -4910,7 +4928,7 @@ (autoload 'vhdl-mode "vhdl-mode" "\ Major mode for editing VHDL code. -vhdl-mode $Revision: 1.9 $ +vhdl-mode $Revision: 1.10 $ 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 diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/prim/faces.el --- a/lisp/prim/faces.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/prim/faces.el Mon Aug 13 08:51:55 2007 +0200 @@ -1069,56 +1069,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. - (let ((faces (face-list))) - (while faces - (init-face-from-resources (car faces) device) - (setq faces (cdr faces)))) - ;; 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. - (let ((faces (face-list))) - (while faces - (init-face-from-resources (car faces) frame) - (setq faces (cdr faces)))) - ;; 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 diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/prim/loadup.el --- a/lisp/prim/loadup.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/prim/loadup.el Mon Aug 13 08:51:55 2007 +0200 @@ -108,7 +108,6 @@ ;; (load-gc "w3-sysdp") (load-gc "widget") (load-gc "custom") ; Before loaddefs so that defcustom exists. - (load-gc "custom-xmas") ;; If SparcWorks support is included some additional packages are ;; dumped which would normally have autoloads. To avoid ;; duplicate doc string warnings, SparcWorks uses a separate diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/prim/simple.el --- a/lisp/prim/simple.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/prim/simple.el Mon Aug 13 08:51:55 2007 +0200 @@ -73,6 +73,9 @@ (not (get-char-property (1- (point)) 'read-only)) ;; Make sure the newline before point isn't invisible. (not (get-char-property (1- (point)) 'invisible)) + ;; This should probably also test for the previous char + ;; being the *last* character too. + (not (get-char-property (1- (point)) 'end-open)) ;; Make sure the newline before point has the same ;; properties as the char before it (if any). (< (or (previous-extent-change (point)) -2) diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/site-load.el --- a/lisp/site-load.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/site-load.el Mon Aug 13 08:51:55 2007 +0200 @@ -29,7 +29,7 @@ ;; is still better than the way it used to be. ;;; Code: -(defvar site-load-package-file "../lisp/site-packages" +(defvar site-load-package-file "../site-packages" "File name containing the list of extra packages to dump with XEmacs.") (defvar site-load-packages nil "A list of .elc files that should be dumped with XEmacs. diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/tm/gnus-mime.el --- a/lisp/tm/gnus-mime.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/tm/gnus-mime.el Mon Aug 13 08:51:55 2007 +0200 @@ -4,7 +4,7 @@ ;; Author: MORIOKA Tomohiko ;; Created: 1996/8/6 -;; Version: $Revision: 1.4 $ +;; Version: $Revision: 1.5 $ ;; 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.4 1997/02/02 05:06:18 steve Exp $") + "$Id: gnus-mime.el,v 1.5 1997/03/04 08:45:01 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 ;;; diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/utils/mail-extr.el --- a/lisp/utils/mail-extr.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/utils/mail-extr.el Mon Aug 13 08:51:55 2007 +0200 @@ -1821,6 +1821,7 @@ ("gov" t "Government (U.S.A.)") ("gr" "Greece" "The Hellenic Republic (%s)") ("hk" "Hong Kong") + ("hr" "Croatia" "The Republic of %s") ("hu" "Hungary" "The Hungarian People's Republic") ;??? ("ie" "Ireland") ("il" "Israel" "The State of %s") diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/version.el --- a/lisp/version.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/version.el Mon Aug 13 08:51:55 2007 +0200 @@ -26,7 +26,7 @@ (defconst emacs-version "19.15" "\ Version numbers of this version of Emacs.") -(setq emacs-version (purecopy (concat emacs-version " XEmacs Lucid (beta96)"))) +(setq emacs-version (purecopy (concat emacs-version " XEmacs Lucid (beta97)"))) (defconst emacs-major-version (progn (or (string-match "^[0-9]+" emacs-version) diff -r 0a3286277d9b -r 1917ad0d78d7 lisp/x11/x-faces.el --- a/lisp/x11/x-faces.el Mon Aug 13 08:51:34 2007 +0200 +++ b/lisp/x11/x-faces.el Mon Aug 13 08:51:55 2007 +0200 @@ -371,7 +371,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", @@ -384,7 +385,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") @@ -459,30 +461,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. diff -r 0a3286277d9b -r 1917ad0d78d7 man/custom.texi --- a/man/custom.texi Mon Aug 13 08:51:34 2007 +0200 +++ b/man/custom.texi Mon Aug 13 08:51:55 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 name 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}. diff -r 0a3286277d9b -r 1917ad0d78d7 man/gnus.texi --- a/man/gnus.texi Mon Aug 13 08:51:34 2007 +0200 +++ b/man/gnus.texi Mon Aug 13 08:51:55 2007 +0200 @@ -854,10 +854,15 @@ @vindex gnus-init-file When Gnus starts, it will read the @code{gnus-site-init-file} -(@file{.../site-lisp/gnus.el} by default) and @code{gnus-init-file} -(@file{~/.gnus.el} by default) files. These are normal Emacs Lisp files -and can be used to avoid cluttering your @file{.emacs} and -@file{site-init} files with Gnus stuff. +(@file{.../site-lisp/gnus} by default) and @code{gnus-init-file} +(@file{~/.gnus} by default) files. These are normal Emacs Lisp files +and can be used to avoid cluttering your @file{~/.emacs} and +@file{site-init} files with Gnus stuff. Gnus will also check for files +with the same names as these, but with @file{.elc} and @file{.el} +suffixes. In other words, if you have set @code{gnus-init-file} to +@file{~/.gnus}, it will look for @file{~/.gnus.elc}, @file{~/.gnus.el}, +and finally @file{~/.gnus} (in this order). + @node Auto Save @@ -10957,7 +10962,7 @@ element}. This date says when the last time this score entry matched, which provides a mechanism for expiring the score entries. It this element is not present, the score entry is permanent. The date is -represented by the number of days since December 31, 1 ce. +represented by the number of days since December 31, 1 BCE. @item If the fourth element is present, it should be a symbol---the @dfn{type diff -r 0a3286277d9b -r 1917ad0d78d7 man/widget.texi --- a/man/widget.texi Mon Aug 13 08:51:34 2007 +0200 +++ b/man/widget.texi Mon Aug 13 08:51:55 2007 +0200 @@ -1,6 +1,6 @@ \input texinfo.tex -@c $Id: widget.texi,v 1.5 1997/03/02 03:44:16 steve Exp $ +@c $Id: widget.texi,v 1.6 1997/03/04 08:45:08 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) diff -r 0a3286277d9b -r 1917ad0d78d7 src/Makefile.in.in --- a/src/Makefile.in.in Mon Aug 13 08:51:34 2007 +0200 +++ b/src/Makefile.in.in Mon Aug 13 08:51:55 2007 +0200 @@ -1160,7 +1160,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 \ @@ -1218,18 +1218,18 @@ -if [ -w ${srcdir}/../lisp ]; then \ w=`pwd`; cd ${srcdir}; $${w}/temacs -nl -batch -l inc-vers; \ else true; fi - touch SATISFIED + @touch SATISFIED -$(DUMPENV) ./temacs -nl -batch -l loadup.el dump - if [ -f SATISFIED ]; then \ + @if [ -f SATISFIED ]; then \ $(MAKE) release; \ fi #else /* ! defined (HAVE_SHM) */ -if [ -w ${srcdir}/../lisp ]; then \ w=`pwd`; cd ${srcdir}; $${w}/temacs -batch -l inc-vers; \ else true; fi - touch SATISFIED + @touch SATISFIED -$(DUMPENV) ./temacs -batch -l loadup.el dump - if [ -f SATISFIED ]; then \ + @if [ -f SATISFIED ]; then \ $(MAKE) release; \ fi #endif /* ! defined (HAVE_SHM) */ @@ -1237,16 +1237,16 @@ #endif /* ! defined (CANNOT_DUMP) */ xemacs: temacs ${libsrc}DOC ${lisp} MOFILE OTHER_FILES - touch SATISFIED + @touch SATISFIED -$(DUMPENV) ./temacs -batch -l loadup.el dump - if [ -f SATISFIED ]; then \ + @if [ -f SATISFIED ]; then \ $(MAKE) xemacs; \ fi xemacs-no-site-file: temacs ${libsrc}DOC ${lisp} MOFILE OTHER_FILES - touch SATISFIED + @touch SATISFIED -$(DUMPENV) ./temacs -batch -l loadup.el dump no-site-file - if [ -f SATISFIED ]; then \ + @if [ -f SATISFIED ]; then \ $(MAKE) xemacs-no-site-file; \ fi @@ -1475,6 +1475,11 @@ @echo "Consult the file \`INSTALL' for instructions for building Emacs." exit 1 +puresize_adjust.h: ${srcdir}/puresize.h + @echo "The file puresize_adjust still needs to be generated." + @echo "Please run 'make' from the top-level." + exit 1 + paths.h: ${srcdir}/paths.h.in @echo "The file paths.h needs to be set up from paths.h.in." @echo "Consult the file \`INSTALL' for instructions for building Emacs." @@ -1576,7 +1581,7 @@ /**/# This is used in making a distribution. /**/# Do not use it on development directories! distclean: clean versionclean - rm -f config.h paths.h Emacs.ad.h Makefile Makefile.in .pure + rm -f config.h paths.h puresize_adjust.h Emacs.ad.h Makefile Makefile.in .pure realclean: distclean rm -f TAGS versionclean: @@ -1759,7 +1764,7 @@ alloc.o: frame.h alloc.o: frameslots.h alloc.o: glyphs.h -alloc.o: puresize.h PURESIZE.h +alloc.o: puresize.h puresize_adjust.h alloc.o: redisplay.h alloc.o: scrollbar.h alloc.o: specifier.h @@ -2904,7 +2909,7 @@ pure.o: blocktype.h pure.o: config.h pure.o: dynarr.h -pure.o: puresize.h PURESIZE.h +pure.o: puresize.h puresize_adjust.h ralloc.o: blocktype.h ralloc.o: config.h ralloc.o: dynarr.h diff -r 0a3286277d9b -r 1917ad0d78d7 src/alloc.c --- a/src/alloc.c Mon Aug 13 08:51:34 2007 +0200 +++ b/src/alloc.c Mon Aug 13 08:51:55 2007 +0200 @@ -2576,18 +2576,19 @@ PURESIZE_h(long int puresize) { int fd; - char *PURESIZE_h_file = "PURESIZE.h"; + char *PURESIZE_h_file = "puresize_adjust.h"; char *WARNING = "/* This file is generated by XEmacs, DO NOT MODIFY!!! */\n"; char define_PURESIZE[256]; - if ((fd = open(PURESIZE_h_file, O_WRONLY|O_CREAT)) < 0) { - report_file_error("Can't write PURESIZE", + if ((fd = open(PURESIZE_h_file, O_WRONLY|O_CREAT|O_TRUNC, 0666)) < 0) { + report_file_error("Can't write PURESIZE_ADJUSTMENT", Fcons(build_ext_string(PURESIZE_h_file, FORMAT_FILENAME), Qnil)); } write(fd, WARNING, strlen(WARNING)); - sprintf(define_PURESIZE, "# define PURESIZE %ld\n", puresize); + sprintf(define_PURESIZE, "# define PURESIZE_ADJUSTMENT %ld\n", + puresize - RAW_PURESIZE); write(fd, define_PURESIZE, strlen(define_PURESIZE)); close(fd); } diff -r 0a3286277d9b -r 1917ad0d78d7 src/config.h.in --- a/src/config.h.in Mon Aug 13 08:51:34 2007 +0200 +++ b/src/config.h.in Mon Aug 13 08:51:55 2007 +0200 @@ -346,7 +346,7 @@ /* Allow the user to override the default value of PURESIZE at configure time. This must come before we include the sys files in order for it to be able to override any changes in them. */ -#undef PURESIZE +#undef RAW_PURESIZE /* Define this if you want to use the Common Desktop Environment diff -r 0a3286277d9b -r 1917ad0d78d7 src/event-Xt.c --- a/src/event-Xt.c Mon Aug 13 08:51:34 2007 +0200 +++ b/src/event-Xt.c Mon Aug 13 08:51:55 2007 +0200 @@ -992,6 +992,37 @@ handle_focus_event_1 (f, event->type == FocusIn); } +/* both MapNotify and VisibilityNotify can cause this */ +static void +change_frame_visibility (struct frame *f, int is_visible) +{ + Lisp_Object frame = Qnil; + + XSETFRAME (frame, f); + + if (!FRAME_VISIBLE_P (f) && is_visible) + { + FRAME_VISIBLE_P (f) = 1; + /* This improves the double flicker when uniconifying a frame + some. A lot of it is not showing a buffer which has changed + while the frame was iconified. To fix it further requires + the good 'ol double redisplay structure. */ + MARK_FRAME_WINDOWS_STRUCTURE_CHANGED (f); + va_run_hook_with_args (Qmap_frame_hook, 1, frame); +#ifdef EPOCH + dispatch_epoch_event (f, event, Qx_map); +#endif + } + else if (FRAME_VISIBLE_P (f) && !is_visible) + { + FRAME_VISIBLE_P (f) = 0; + va_run_hook_with_args (Qunmap_frame_hook, 1, frame); +#ifdef EPOCH + dispatch_epoch_event (f, event, Qx_unmap); +#endif + } +} + static void handle_map_event (struct frame *f, XEvent *event) { @@ -1048,34 +1079,14 @@ rather than consulting some internal (and likely inaccurate) state flag. Therefore, ignoring the MapNotify is correct. */ - if (!f->visible && NILP (Fframe_iconified_p (frame))) + if (!FRAME_VISIBLE_P (f) && NILP (Fframe_iconified_p (frame))) #endif - if (!f->visible) - { - f->visible = 1; - /* This improves the double flicker when uniconifying a frame - some. A lot of it is not showing a buffer which has changed - while the frame was iconified. To fix it further requires - the good 'ol double redisplay structure. */ - MARK_FRAME_WINDOWS_STRUCTURE_CHANGED (f); - va_run_hook_with_args (Qmap_frame_hook, 1, frame); -#ifdef EPOCH - dispatch_epoch_event (f, event, Qx_map); -#endif - } + change_frame_visibility (f, 1); } else { FRAME_X_TOTALLY_VISIBLE_P (f) = 0; - if (f->visible) - { - f->visible = 0; - va_run_hook_with_args (Qunmap_frame_hook, 1, frame); -#ifdef EPOCH - dispatch_epoch_event (f, event, Qx_unmap); -#endif - } - + change_frame_visibility (f, 0); /* Calling Fframe_iconified_p is the only way we have to correctly update FRAME_ICONIFIED_P */ Fframe_iconified_p (frame); @@ -1221,19 +1232,20 @@ break; case VisibilityNotify: /* window visiblity has changed */ -#if 0 /* This causes all kinds of strange behavior I don't like. -sb */ + if (event->xvisibility.window == XtWindow (FRAME_X_SHELL_WIDGET (f))) { + FRAME_X_TOTALLY_VISIBLE_P (f) = + (event->xvisibility.state == VisibilityUnobscured); /* Note that the fvwm pager only sends VisibilityNotify when changing pages. Is this all we need to do ? JV */ - FRAME_VISIBLE_P (f) = - ( event->xvisibility.state != VisibilityFullyObscured); - FRAME_X_TOTALLY_VISIBLE_P (f) = - (event->xvisibility.state == VisibilityUnobscured); + /* Nope. We must at least trigger a redisplay here. + Since this case seems similar to MapNotify, I've + factored out some code to change_frame_visibility(). + This triggers the necessary redisplay and runs + (un)map-frame-hook. - dkindred@cs.cmu.edu */ + change_frame_visibility (f, (event->xvisibility.state + != VisibilityFullyObscured)); } -#else - FRAME_X_TOTALLY_VISIBLE_P (f) = - (event->xvisibility.state == VisibilityUnobscured); -#endif break; case ConfigureNotify: diff -r 0a3286277d9b -r 1917ad0d78d7 src/puresize.h --- a/src/puresize.h Mon Aug 13 08:51:34 2007 +0200 +++ b/src/puresize.h Mon Aug 13 08:51:55 2007 +0200 @@ -24,17 +24,17 @@ #ifndef PURESIZE_H #define PURESIZE_H -/* If PURESIZE is already defined then the user overrode it at +/* If RAW_PURESIZE is already defined then the user overrode it at configure time. */ -#ifndef PURESIZE -#if 0 +#ifndef RAW_PURESIZE + /* Basic amount of purespace to use, in the absence of extra things configured in. */ #if (LONGBITS == 64) # define BASE_PURESIZE 944000 #else -# define BASE_PURESIZE 584000 +# define BASE_PURESIZE 527000 #endif /* If any particular systems need to change the base puresize, they @@ -50,29 +50,57 @@ /* Extra amount of purespace needed for menubars. */ +#ifdef HAVE_DIALOGS +# if (LONGBITS == 64) +# define DIALOG_PURESIZE_EXTRA 43000 +# else +# define DIALOG_PURESIZE_EXTRA 1800 +# endif +#else +# define DIALOG_PURESIZE_EXTRA 0 +#endif + #ifdef HAVE_MENUBARS # if (LONGBITS == 64) # define MENUBAR_PURESIZE_EXTRA 43000 # else -# define MENUBAR_PURESIZE_EXTRA 35000 +# define MENUBAR_PURESIZE_EXTRA 36000 # endif #else # define MENUBAR_PURESIZE_EXTRA 0 #endif -/* Scrollbar purespace needed is only about 2K so there's no sense - worrying about it separately. */ +#ifdef HAVE_SCROLLBARS +# if (LONGBITS == 64) +# define SCROLLBAR_PURESIZE_EXTRA 4000 +# else +# define SCROLLBAR_PURESIZE_EXTRA 1800 +# endif +#else +# define SCROLLBAR_PURESIZE_EXTRA 0 +#endif -/* Extra amount of purespace needed for X11, separate from menubars. */ +#ifdef HAVE_TOOLBARS +# if (LONGBITS == 64) +# define TOOLBAR_PURESIZE_EXTRA 4000 +# else +# define TOOLBAR_PURESIZE_EXTRA 8400 +# endif +#else +# define TOOLBAR_PURESIZE_EXTRA 0 +#endif + +/* Extra amount of purespace needed for X11, separate from menubars + and scrollbars. */ #ifdef HAVE_X_WINDOWS # if (LONGBITS == 64) # define X11_PURESIZE_EXTRA 95000 # else -# define X11_PURESIZE_EXTRA 63000 +# define X11_PURESIZE_EXTRA 50000 # endif #else -# define X11_PURESIZE_EXTRA 10000 +# define X11_PURESIZE_EXTRA 0 #endif /* Extra amount of purespace needed for Mule. */ @@ -93,7 +121,7 @@ # if (LONGBITS == 64) # define TOOLTALK_PURESIZE_EXTRA 100000 # else -# define TOOLTALK_PURESIZE_EXTRA 69000 +# define TOOLTALK_PURESIZE_EXTRA 8300 # endif #else # define TOOLTALK_PURESIZE_EXTRA 0 @@ -115,16 +143,21 @@ # define SUNPRO_PURESIZE_EXTRA 0 #endif -#define PURESIZE ((BASE_PURESIZE) + (MENUBAR_PURESIZE_EXTRA) + \ - (X11_PURESIZE_EXTRA) + \ - (SYSTEM_PURESIZE_EXTRA) + (MULE_PURESIZE_EXTRA) + \ - (TOOLTALK_PURESIZE_EXTRA) + (ENERGIZE_PURESIZE_EXTRA) + \ - (SUNPRO_PURESIZE_EXTRA)) +#define RAW_PURESIZE ((BASE_PURESIZE) + \ + (DIALOG_PURESIZE_EXTRA) + \ + (MENUBAR_PURESIZE_EXTRA) + \ + (SCROLLBAR_PURESIZE_EXTRA) + \ + (TOOLBAR_PURESIZE_EXTRA) + \ + (X11_PURESIZE_EXTRA) + \ + (SYSTEM_PURESIZE_EXTRA) + \ + (MULE_PURESIZE_EXTRA) + \ + (TOOLTALK_PURESIZE_EXTRA) + \ + (ENERGIZE_PURESIZE_EXTRA) + \ + (SUNPRO_PURESIZE_EXTRA)) -#endif +#endif /* !RAW_PURESIZE */ -# include "PURESIZE.h" - -#endif /* !PURESIZE */ +#include "puresize_adjust.h" +#define PURESIZE ((RAW_PURESIZE) + (PURESIZE_ADJUSTMENT)) #endif /* PURESIZE_H */