git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/cus-edit.el

   1 ;;; cus-edit.el --- Tools for customizating Emacs and Lisp packages.
   2 ;;
   3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
   6 ;; Maintainer: Hrvoje Niksic <hniksic@srce.hr>
   7 ;; Keywords: help, faces
   8 ;; Version: 1.9960-x
   9 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
  10
  11 ;; This file is part of XEmacs.
  12
  13 ;; XEmacs is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; XEmacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with XEmacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;; Boston, MA 02111-1307, USA.
  27
  28 ;;; Commentary:
  29 ;;
  30 ;; This file implements the code to create and edit customize buffers.
  31 ;;
  32 ;; See `custom.el'.
  33
  34 ;; No commands should have names starting with `custom-' because
  35 ;; that interferes with completion.  Use `customize-' for commands
  36 ;; that the user will run with M-x, and `Custom-' for interactive commands.
  37
  38 ;; NOTE: In many places within this file we use `mapatoms', which is
  39 ;; very slow in an average XEmacs because of the large number of
  40 ;; symbols requiring a large number of funcalls -- XEmacs with Gnus
  41 ;; can grow to some 17000 symbols without ever doing anything fancy.
  42 ;; It would probably pay off to make a hash table of symbols known to
  43 ;; Custom, similar to custom-group-hash-table.
  44
  45 ;; This is not top priority, because none of the functions that do
  46 ;; mapatoms are speed-critical (the one that was now uses
  47 ;; custom-group-hash-table), but it would be nice to have.
  48
  49 \f
  50 ;;; Code:
  51
  52 (require 'cus-face)
  53 (require 'wid-edit)
  54 (require 'easymenu)
  55
  56 (require 'cus-load)
  57 (require 'cus-start)
  58
  59 ;; Huh?  This looks dirty!
  60 (put 'custom-define-hook 'custom-type 'hook)
  61 (put 'custom-define-hook 'standard-value '(nil))
  62 (custom-add-to-group 'customize 'custom-define-hook 'custom-variable)
  63
  64 ;;; Customization Groups.
  65
  66 (defgroup emacs nil
  67   "Customization of the One True Editor."
  68   :link '(custom-manual "(XEmacs)Top"))
  69
  70 ;; Most of these groups are stolen from `finder.el',
  71 (defgroup editing nil
  72   "Basic text editing facilities."
  73   :group 'emacs)
  74
  75 (defgroup matching nil
  76   "Various sorts of searching and matching."
  77   :group 'editing)
  78
  79 (defgroup emulations nil
  80   "Emulations of other editors."
  81   :group 'editing)
  82
  83 (defgroup outlines nil
  84   "Support for hierarchical outlining."
  85   :group 'editing)
  86
  87 (defgroup external nil
  88   "Interfacing to external utilities."
  89   :group 'emacs)
  90
  91 (defgroup bib nil
  92   "Code related to the `bib' bibliography processor."
  93   :tag "Bibliography"
  94   :group 'external)
  95
  96 (defgroup programming nil
  97   "Support for programming in other languages."
  98   :group 'emacs)
  99
 100 (defgroup languages nil
 101   "Specialized modes for editing programming languages."
 102   :group 'programming)
 103
 104 ;; #### This should be in cc-vars.el
 105 (defgroup c nil
 106   "Support for the C language and related languages."
 107   :group 'languages)
 108
 109 (defgroup tools nil
 110   "Programming tools."
 111   :group 'programming)
 112
 113 (defgroup oop nil
 114   "Support for object-oriented programming."
 115   :group 'programming)
 116
 117 (defgroup applications nil
 118   "Applications written in Emacs."
 119   :group 'emacs)
 120
 121 ;; #### This should be in calendar.el
 122 (defgroup calendar nil
 123   "Calendar and time management support."
 124   :group 'applications)
 125
 126 (defgroup mail nil
 127   "Modes for electronic-mail handling."
 128   :group 'applications)
 129
 130 (defgroup news nil
 131   "Support for netnews reading and posting."
 132   :group 'applications)
 133
 134 (defgroup games nil
 135   "Games, jokes and amusements."
 136   :group 'applications)
 137
 138 (defgroup development nil
 139   "Support for further development of Emacs."
 140   :group 'emacs)
 141
 142 (defgroup docs nil
 143   "Support for Emacs documentation."
 144   :group 'development)
 145
 146 (defgroup extensions nil
 147   "Emacs Lisp language extensions."
 148   :group 'development)
 149
 150 (defgroup internal nil
 151   "Code for Emacs internals, build process, defaults."
 152   :group 'development)
 153
 154 (defgroup maint nil
 155   "Maintenance aids for the Emacs development group."
 156   :tag "Maintenance"
 157   :group 'development)
 158
 159 (defgroup environment nil
 160   "Fitting Emacs with its environment."
 161   :group 'emacs)
 162
 163 (defgroup comm nil
 164   "Communications, networking, remote access to files."
 165   :tag "Communication"
 166   :group 'environment)
 167
 168 (defgroup hardware nil
 169   "Support for interfacing with exotic hardware."
 170   :group 'environment)
 171
 172 (defgroup terminals nil
 173   "Support for terminal types."
 174   :group 'environment)
 175
 176 (defgroup unix nil
 177   "Front-ends/assistants for, or emulators of, UNIX features."
 178   :group 'environment)
 179
 180 (defgroup i18n nil
 181   "Internationalization and alternate character-set support."
 182   :group 'environment
 183   :group 'editing)
 184
 185 (defgroup data nil
 186   "Support editing files of data."
 187   :group 'emacs)
 188
 189 (defgroup wp nil
 190   "Word processing."
 191   :group 'emacs)
 192
 193 (defgroup tex nil
 194   "Code related to the TeX formatter."
 195   :group 'wp)
 196
 197 (defgroup hypermedia nil
 198   "Support for links between text or other media types."
 199   :group 'emacs)
 200
 201 (defgroup local nil
 202   "Code local to your site."
 203   :group 'emacs)
 204
 205 (defgroup customize '((widgets custom-group))
 206   "Customization of the Customization support."
 207   :link '(custom-manual "(custom)Top")
 208   :link '(url-link :tag "Development Page"
 209                    "http://www.dina.kvl.dk/~abraham/custom/")
 210   :prefix "custom-"
 211   :group 'help)
 212
 213 (defgroup custom-faces nil
 214   "Faces used by customize."
 215   :group 'customize
 216   :group 'faces)
 217
 218 (defgroup custom-browse nil
 219   "Control customize browser."
 220   :prefix "custom-"
 221   :group 'customize)
 222
 223 (defgroup custom-buffer nil
 224   "Control customize buffers."
 225   :prefix "custom-"
 226   :group 'customize)
 227
 228 (defgroup custom-menu nil
 229   "Control customize menus."
 230   :prefix "custom-"
 231   :group 'customize)
 232
 233 (defgroup alloc nil
 234   "Storage allocation and gc for GNU Emacs Lisp interpreter."
 235   :tag "Storage Allocation"
 236   :group 'internal)
 237
 238 (defgroup undo nil
 239   "Undoing changes in buffers."
 240   :group 'editing)
 241
 242 (defgroup editing-basics nil
 243   "Most basic editing facilities."
 244   :group 'editing)
 245
 246 (defgroup display nil
 247   "How characters are displayed in buffers."
 248   :group 'environment)
 249
 250 (defgroup installation nil
 251   "The Emacs installation."
 252   :group 'environment)
 253
 254 (defgroup limits nil
 255   "Internal Emacs limits."
 256   :group 'internal)
 257
 258 (defgroup debug nil
 259   "Debugging Emacs itself."
 260   :group 'development)
 261
 262 (defgroup mule nil
 263   "Mule XEmacs internationalization."
 264   :group 'i18n)
 265
 266 \f
 267 ;;; Utilities.
 268
 269 (defun custom-quote (sexp)
 270   "Quote SEXP iff it is not self quoting."
 271   (if (or (memq sexp '(t nil))
 272           (keywordp sexp)
 273           (eq (car-safe sexp) 'lambda)
 274           (stringp sexp)
 275           (numberp sexp)
 276           (characterp sexp)
 277           (vectorp sexp)
 278           (bit-vector-p sexp))
 279       sexp
 280     (list 'quote sexp)))
 281
 282 (defun custom-split-regexp-maybe (regexp)
 283   "If REGEXP is a string, split it to a list at `\\|'.
 284 You can get the original back with from the result with:
 285   (mapconcat #'identity result \"\\|\")
 286
 287 IF REGEXP is not a string, return it unchanged."
 288   (if (stringp regexp)
 289       (split-string regexp "\\\\|")
 290     regexp))
 291
 292 (defun custom-variable-prompt ()
 293   ;; Code stolen from `help.el'.
 294   "Prompt for a variable, defaulting to the variable at point.
 295 Return a list suitable for use in `interactive'."
 296    (let ((v (variable-at-point))
 297          (enable-recursive-minibuffers t)
 298          val)
 299      (setq val (completing-read
 300                 (if (symbolp v)
 301                     (format "Customize variable: (default %s) " v)
 302                   "Customize variable: ")
 303                 obarray (lambda (symbol)
 304                           (and (boundp symbol)
 305                                (or (get symbol 'custom-type)
 306                                    (user-variable-p symbol)))) t))
 307      (list (if (equal val "")
 308                (if (symbolp v) v nil)
 309              (intern val)))))
 310
 311 ;; Here we take not only the actual groups, but the loads, too.
 312 (defun custom-group-prompt (prompt)
 313   "Read group from minibuffer."
 314   (let ((completion-ignore-case t))
 315     (list (completing-read
 316            prompt obarray
 317            (lambda (symbol)
 318              (or (get symbol 'custom-group)
 319                  (get symbol 'custom-loads)))
 320            t))))
 321
 322 (defun custom-menu-filter (menu widget)
 323   "Convert MENU to the form used by `widget-choose'.
 324 MENU should be in the same format as `custom-variable-menu'.
 325 WIDGET is the widget to apply the filter entries of MENU on."
 326   (let ((result nil)
 327         current name action filter)
 328     (while menu
 329       (setq current (car menu)
 330             name (nth 0 current)
 331             action (nth 1 current)
 332             filter (nth 2 current)
 333             menu (cdr menu))
 334       (if (or (null filter) (funcall filter widget))
 335           (push (cons name action) result)
 336         (push name result)))
 337     (nreverse result)))
 338
 339 \f
 340 ;;; Unlispify.
 341
 342 (defvar custom-prefix-list nil
 343   "List of prefixes that should be ignored by `custom-unlispify'")
 344
 345 (defcustom custom-unlispify-menu-entries t
 346   "Display menu entries as words instead of symbols if non nil."
 347   :group 'custom-menu
 348   :type 'boolean)
 349
 350 (defcustom custom-unlispify-remove-prefixes t
 351   "Non-nil means remove group prefixes from option names in buffers and menus.
 352 This only has an effect when `custom-unlispify-tag-names' or
 353 `custom-unlispify-menu-entries' is on."
 354   :group 'custom-menu
 355   :type 'boolean)
 356
 357 (defun custom-unlispify-menu-entry (symbol &optional no-suffix)
 358   "Convert symbol into a menu entry."
 359   (cond ((not custom-unlispify-menu-entries)
 360          (symbol-name symbol))
 361         ((get symbol 'custom-tag)
 362          (if no-suffix
 363              (get symbol 'custom-tag)
 364            (concat (get symbol 'custom-tag) "...")))
 365         (t
 366          (with-current-buffer (get-buffer-create " *Custom-Work*")
 367            (erase-buffer)
 368            (princ symbol (current-buffer))
 369            (goto-char (point-min))
 370            (when (and (eq (get symbol 'custom-type) 'boolean)
 371                       (re-search-forward "-p\\'" nil t))
 372              (replace-match "" t t)
 373              (goto-char (point-min)))
 374            (when custom-unlispify-remove-prefixes
 375              (let ((prefixes custom-prefix-list)
 376                    prefix)
 377                (while prefixes
 378                  (setq prefix (car prefixes))
 379                  (if (search-forward prefix (+ (point) (length prefix)) t)
 380                      (progn
 381                        (setq prefixes nil)
 382                        (delete-region (point-min) (point)))
 383                    (setq prefixes (cdr prefixes))))))
 384            (subst-char-in-region (point-min) (point-max) ?- ?\  t)
 385            (capitalize-region (point-min) (point-max))
 386            (unless no-suffix
 387              (goto-char (point-max))
 388              (insert "..."))
 389            (buffer-string)))))
 390
 391 (defcustom custom-unlispify-tag-names t
 392   "Display tag names as words instead of symbols if non nil."
 393   :group 'custom-buffer
 394   :type 'boolean)
 395
 396 (defun custom-unlispify-tag-name (symbol)
 397   "Convert symbol into a menu entry."
 398   (let ((custom-unlispify-menu-entries custom-unlispify-tag-names))
 399     (custom-unlispify-menu-entry symbol t)))
 400
 401 (defun custom-prefix-add (symbol prefixes)
 402   ;; Addd SYMBOL to list of ignored PREFIXES.
 403   (cons (or (get symbol 'custom-prefix)
 404             (concat (symbol-name symbol) "-"))
 405         prefixes))
 406
 407 \f
 408 ;;; Guess.
 409
 410 (defcustom custom-guess-name-alist
 411   '(("-p\\'" boolean)
 412     ("-hooks?\\'" hook)
 413     ("-face\\'" face)
 414     ("-file\\'" file)
 415     ("-function\\'" function)
 416     ("-functions\\'" (repeat function))
 417     ("-list\\'" (repeat sexp))
 418     ("-alist\\'" (repeat (cons sexp sexp))))
 419   "Alist of (MATCH TYPE).
 420
 421 MATCH should be a regexp matching the name of a symbol, and TYPE should
 422 be a widget suitable for editing the value of that symbol.  The TYPE
 423 of the first entry where MATCH matches the name of the symbol will be
 424 used.
 425
 426 This is used for guessing the type of variables not declared with
 427 customize."
 428   :type '(repeat (group (regexp :tag "Match") (sexp :tag "Type")))
 429   :group 'customize)
 430
 431 (defcustom custom-guess-doc-alist
 432   '(("\\`\\*?Non-nil " boolean))
 433   "Alist of (MATCH TYPE).
 434
 435 MATCH should be a regexp matching a documentation string, and TYPE
 436 should be a widget suitable for editing the value of a variable with
 437 that documentation string.  The TYPE of the first entry where MATCH
 438 matches the name of the symbol will be used.
 439
 440 This is used for guessing the type of variables not declared with
 441 customize."
 442   :type '(repeat (group (regexp :tag "Match") (sexp :tag "Type")))
 443   :group 'customize)
 444
 445 (defun custom-guess-type (symbol)
 446   "Guess a widget suitable for editing the value of SYMBOL.
 447 This is done by matching SYMBOL with `custom-guess-name-alist' and
 448 if that fails, the doc string with `custom-guess-doc-alist'."
 449   (let ((name (symbol-name symbol))
 450         (names custom-guess-name-alist)
 451         current found)
 452     (while names
 453       (setq current (car names)
 454             names (cdr names))
 455       (when (string-match (nth 0 current) name)
 456         (setq found (nth 1 current)
 457               names nil)))
 458     (unless found
 459       (let ((doc (documentation-property symbol 'variable-documentation))
 460             (docs custom-guess-doc-alist))
 461         (when doc
 462           (while docs
 463             (setq current (car docs)
 464                   docs (cdr docs))
 465             (when (string-match (nth 0 current) doc)
 466               (setq found (nth 1 current)
 467                     docs nil))))))
 468     found))
 469
 470 \f
 471 ;;; Sorting.
 472
 473 (defcustom custom-browse-sort-alphabetically nil
 474   "If non-nil, sort members of each customization group alphabetically."
 475   :type 'boolean
 476   :group 'custom-browse)
 477
 478 (defcustom custom-browse-order-groups nil
 479   "If non-nil, order group members within each customization group.
 480 If `first', order groups before non-groups.
 481 If `last', order groups after non-groups."
 482   :type '(choice (const first)
 483                  (const last)
 484                  (const :tag "none" nil))
 485   :group 'custom-browse)
 486
 487 (defcustom custom-browse-only-groups nil
 488   "If non-nil, show group members only within each customization group."
 489   :type 'boolean
 490   :group 'custom-browse)
 491
 492 (defcustom custom-buffer-sort-alphabetically nil
 493   "If non-nil, sort members of each customization group alphabetically."
 494   :type 'boolean
 495   :group 'custom-buffer)
 496
 497 (defcustom custom-buffer-order-groups 'last
 498   "If non-nil, order group members within each customization group.
 499 If `first', order groups before non-groups.
 500 If `last', order groups after non-groups."
 501   :type '(choice (const first)
 502                  (const last)
 503                  (const :tag "none" nil))
 504   :group 'custom-buffer)
 505
 506 (defcustom custom-menu-sort-alphabetically nil
 507   "If non-nil, sort members of each customization group alphabetically."
 508   :type 'boolean
 509   :group 'custom-menu)
 510
 511 (defcustom custom-menu-order-groups 'first
 512   "If non-nil, order group members within each customization group.
 513 If `first', order groups before non-groups.
 514 If `last', order groups after non-groups."
 515   :type '(choice (const first)
 516                  (const last)
 517                  (const :tag "none" nil))
 518   :group 'custom-menu)
 519
 520 (defun custom-sort-items (items sort-alphabetically order-groups)
 521   "Return a sorted copy of ITEMS.
 522 ITEMS should be a `custom-group' property.
 523 If SORT-ALPHABETICALLY non-nil, sort alphabetically.
 524 If ORDER-GROUPS is `first' order groups before non-groups, if `last' order
 525 groups after non-groups, if nil do not order groups at all."
 526   (sort (copy-sequence items)
 527    (lambda (a b)
 528      (let ((typea (nth 1 a)) (typeb (nth 1 b))
 529            (namea (symbol-name (nth 0 a))) (nameb (symbol-name (nth 0 b))))
 530        (cond ((not order-groups)
 531               ;; Since we don't care about A and B order, maybe sort.
 532               (when sort-alphabetically
 533                 (string-lessp namea nameb)))
 534              ((eq typea 'custom-group)
 535               ;; If B is also a group, maybe sort.  Otherwise, order A and B.
 536               (if (eq typeb 'custom-group)
 537                   (when sort-alphabetically
 538                     (string-lessp namea nameb))
 539                 (eq order-groups 'first)))
 540              ((eq typeb 'custom-group)
 541               ;; Since A cannot be a group, order A and B.
 542               (eq order-groups 'last))
 543              (sort-alphabetically
 544               ;; Since A and B cannot be groups, sort.
 545               (string-lessp namea nameb)))))))
 546
 547 \f
 548 ;;; Custom Mode Commands.
 549
 550 (defvar custom-options nil
 551   "Customization widgets in the current buffer.")
 552
 553 (defun Custom-set ()
 554   "Set changes in all modified options."
 555   (interactive)
 556   (let ((children custom-options))
 557     (mapc (lambda (child)
 558             (when (eq (widget-get child :custom-state) 'modified)
 559               (widget-apply child :custom-set)))
 560           children)))
 561
 562 (defun Custom-save ()
 563   "Set all modified group members and save them."
 564   (interactive)
 565   (let ((children custom-options))
 566     (mapc (lambda (child)
 567             (when (memq (widget-get child :custom-state) '(modified set))
 568               (widget-apply child :custom-save)))
 569           children))
 570   (custom-save-all))
 571
 572 (defvar custom-reset-menu
 573   '(("Current" . Custom-reset-current)
 574     ("Saved" . Custom-reset-saved)
 575     ("Standard Settings" . Custom-reset-standard))
 576   "Alist of actions for the `Reset' button.
 577 The key is a string containing the name of the action, the value is a
 578 lisp function taking the widget as an element which will be called
 579 when the action is chosen.")
 580
 581 (defun custom-reset (event)
 582   "Select item from reset menu."
 583   (let* ((completion-ignore-case t)
 584          (answer (widget-choose "Reset to"
 585                                 custom-reset-menu
 586                                 event)))
 587     (if answer
 588         (funcall answer))))
 589
 590 (defun Custom-reset-current (&rest ignore)
 591   "Reset all modified group members to their current value."
 592   (interactive)
 593   (let ((children custom-options))
 594     (mapc (lambda (child)
 595             (when (eq (widget-get child :custom-state) 'modified)
 596               (widget-apply child :custom-reset-current)))
 597           children)))
 598
 599 (defun Custom-reset-saved (&rest ignore)
 600   "Reset all modified or set group members to their saved value."
 601   (interactive)
 602   (let ((children custom-options))
 603     (mapc (lambda (child)
 604             (when (eq (widget-get child :custom-state) 'modified)
 605               (widget-apply child :custom-reset-saved)))
 606           children)))
 607
 608 (defun Custom-reset-standard (&rest ignore)
 609   "Reset all modified, set, or saved group members to their standard settings."
 610   (interactive)
 611   (let ((children custom-options))
 612     (mapc (lambda (child)
 613             (when (eq (widget-get child :custom-state) 'modified)
 614               (widget-apply child :custom-reset-standard)))
 615           children)))
 616
 617 \f
 618 ;;; The Customize Commands
 619
 620 (defun custom-prompt-variable (prompt-var prompt-val)
 621   "Prompt for a variable and a value and return them as a list.
 622 PROMPT-VAR is the prompt for the variable, and PROMPT-VAL is the
 623 prompt for the value.  The %s escape in PROMPT-VAL is replaced with
 624 the name of the variable.
 625
 626 If the variable has a `variable-interactive' property, that is used as if
 627 it were the arg to `interactive' (which see) to interactively read the value.
 628
 629 If the variable has a `custom-type' property, it must be a widget and the
 630 `:prompt-value' property of that widget will be used for reading the value."
 631   (let* ((var (read-variable prompt-var))
 632          (minibuffer-help-form '(describe-variable var)))
 633     (list var
 634           (let ((prop (get var 'variable-interactive))
 635                 (type (get var 'custom-type))
 636                 (prompt (format prompt-val var)))
 637             (unless (listp type)
 638               (setq type (list type)))
 639             (cond (prop
 640                    ;; Use VAR's `variable-interactive' property
 641                    ;; as an interactive spec for prompting.
 642                    (call-interactively (list 'lambda '(arg)
 643                                              (list 'interactive prop)
 644                                              'arg)))
 645                   (type
 646                    (widget-prompt-value type
 647                                         prompt
 648                                         (if (boundp var)
 649                                             (symbol-value var))
 650                                         (not (boundp var))))
 651                   (t
 652                    (eval-minibuffer prompt)))))))
 653
 654 ;;;###autoload
 655 (defun customize-set-value (var val)
 656   "Set VARIABLE to VALUE.  VALUE is a Lisp object.
 657
 658 If VARIABLE has a `variable-interactive' property, that is used as if
 659 it were the arg to `interactive' (which see) to interactively read the value.
 660
 661 If VARIABLE has a `custom-type' property, it must be a widget and the
 662 `:prompt-value' property of that widget will be used for reading the value."
 663   (interactive (custom-prompt-variable "Set variable: "
 664                                        "Set %s to value: "))
 665
 666   (set var val))
 667
 668 ;;;###autoload
 669 (defun customize-set-variable (var val)
 670   "Set the default for VARIABLE to VALUE.  VALUE is a Lisp object.
 671
 672 If VARIABLE has a `custom-set' property, that is used for setting
 673 VARIABLE, otherwise `set-default' is used.
 674
 675 The `customized-value' property of the VARIABLE will be set to a list
 676 with a quoted VALUE as its sole list member.
 677
 678 If VARIABLE has a `variable-interactive' property, that is used as if
 679 it were the arg to `interactive' (which see) to interactively read the value.
 680
 681 If VARIABLE has a `custom-type' property, it must be a widget and the
 682 `:prompt-value' property of that widget will be used for reading the value. "
 683   (interactive (custom-prompt-variable "Set variable: "
 684                                        "Set customized value for %s to: "))
 685   (funcall (or (get var 'custom-set) 'set-default) var val)
 686   (put var 'customized-value (list (custom-quote val))))
 687
 688 ;;;###autoload
 689 (defun customize-save-variable (var val)
 690   "Set the default for VARIABLE to VALUE, and save it for future sessions.
 691 If VARIABLE has a `custom-set' property, that is used for setting
 692 VARIABLE, otherwise `set-default' is used.
 693
 694 The `customized-value' property of the VARIABLE will be set to a list
 695 with a quoted VALUE as its sole list member.
 696
 697 If VARIABLE has a `variable-interactive' property, that is used as if
 698 it were the arg to `interactive' (which see) to interactively read the value.
 699
 700 If VARIABLE has a `custom-type' property, it must be a widget and the
 701 `:prompt-value' property of that widget will be used for reading the value. "
 702   (interactive (custom-prompt-variable "Set and ave variable: "
 703                                        "Set and save value for %s as: "))
 704   (funcall (or (get var 'custom-set) 'set-default) var val)
 705   (put var 'saved-value (list (custom-quote val)))
 706   (custom-save-all))
 707
 708 ;;;###autoload
 709 (defun customize (group)
 710   "Select a customization buffer which you can use to set user options.
 711 User options are structured into \"groups\".
 712 The default group is `Emacs'."
 713   (interactive (custom-group-prompt
 714                 "Customize group: (default emacs) "))
 715   (when (stringp group)
 716     (if (string-equal "" group)
 717         (setq group 'emacs)
 718       (setq group (intern group))))
 719   (let ((name (format "*Customize Group: %s*"
 720                       (custom-unlispify-tag-name group))))
 721     (if (get-buffer name)
 722         (switch-to-buffer name)
 723       (custom-buffer-create (list (list group 'custom-group))
 724                             name
 725                             (concat " for group "
 726                                     (custom-unlispify-tag-name group))))))
 727
 728 ;;;###autoload
 729 (defalias 'customize-group 'customize)
 730
 731 ;;;###autoload
 732 (defun customize-other-window (symbol)
 733   "Customize SYMBOL, which must be a customization group."
 734   (interactive (custom-group-prompt
 735                 "Customize group: (default emacs) "))
 736   (when (stringp symbol)
 737     (if (string-equal "" symbol)
 738         (setq symbol 'emacs)
 739       (setq symbol (intern symbol))))
 740   (custom-buffer-create-other-window
 741    (list (list symbol 'custom-group))
 742    (format "*Customize Group: %s*" (custom-unlispify-tag-name symbol))))
 743
 744 ;;;###autoload
 745 (defalias 'customize-group-other-window 'customize-other-window)
 746
 747 ;;;###autoload
 748 (defalias 'customize-option 'customize-variable)
 749
 750 ;;;###autoload
 751 (defun customize-variable (symbol)
 752   "Customize SYMBOL, which must be a user option variable."
 753   (interactive (custom-variable-prompt))
 754   (custom-buffer-create (list (list symbol 'custom-variable))
 755                         (format "*Customize Variable: %s*"
 756                                 (custom-unlispify-tag-name symbol))))
 757
 758 ;;;###autoload
 759 (defun customize-changed-options (since-version)
 760   "Customize all user option variables whose default values changed recently.
 761 This means, in other words, variables defined with a `:version' keyword."
 762   (interactive "sCustomize options changed, since version (default all versions): ")
 763   (if (equal since-version "")
 764       (setq since-version nil))
 765   (let ((found nil))
 766     (mapatoms (lambda (symbol)
 767                 (and (boundp symbol)
 768                      (let ((version (get symbol 'custom-version)))
 769                        (and version
 770                             (or (null since-version)
 771                                 (customize-version-lessp since-version version))))
 772                      (push (list symbol 'custom-variable) found))))
 773     (unless found
 774       (error "No user options have changed defaults %s"
 775              (if since-version
 776                  (format "since XEmacs %s" since-version)
 777                "in recent Emacs versions")))
 778     (custom-buffer-create (custom-sort-items found t nil)
 779                           "*Customize Changed Options*")))
 780
 781 (defun customize-version-lessp (version1 version2)
 782   (let (major1 major2 minor1 minor2)
 783     (string-match "\\([0-9]+\\)[.]\\([0-9]+\\)" version1)
 784     (setq major1 (read (match-string 1 version1)))
 785     (setq minor1 (read (match-string 2 version1)))
 786     (string-match "\\([0-9]+\\)[.]\\([0-9]+\\)" version2)
 787     (setq major2 (read (match-string 1 version2)))
 788     (setq minor2 (read (match-string 2 version2)))
 789     (or (< major1 major2)
 790         (and (= major1 major2)
 791              (< minor1 minor2)))))
 792
 793 ;;;###autoload
 794 (defalias 'customize-variable-other-window 'customize-option-other-window)
 795
 796 ;;;###autoload
 797 (defun customize-option-other-window (symbol)
 798   "Customize SYMBOL, which must be a user option variable.
 799 Show the buffer in another window, but don't select it."
 800   (interactive (custom-variable-prompt))
 801   (custom-buffer-create-other-window
 802    (list (list symbol 'custom-variable))
 803    (format "*Customize Option: %s*" (custom-unlispify-tag-name symbol))))
 804
 805 ;;;###autoload
 806 (defun customize-face (&optional symbol)
 807   "Customize SYMBOL, which should be a face name or nil.
 808 If SYMBOL is nil, customize all faces."
 809   (interactive (list (completing-read "Customize face: (default all) "
 810                                       obarray 'find-face)))
 811   (if (or (null symbol) (and (stringp symbol) (zerop (length symbol))))
 812       (custom-buffer-create (custom-sort-items
 813                              (mapcar (lambda (symbol)
 814                                        (list symbol 'custom-face))
 815                                      (face-list))
 816                              t nil)
 817                             "*Customize Faces*")
 818     (when (stringp symbol)
 819       (setq symbol (intern symbol)))
 820     (check-argument-type 'symbolp symbol)
 821     (custom-buffer-create (list (list symbol 'custom-face))
 822                           (format "*Customize Face: %s*"
 823                                   (custom-unlispify-tag-name symbol)))))
 824
 825 ;;;###autoload
 826 (defun customize-face-other-window (&optional symbol)
 827   "Show customization buffer for FACE in other window."
 828   (interactive (list (completing-read "Customize face: "
 829                                       obarray 'find-face)))
 830   (if (or (null symbol) (and (stringp symbol) (zerop (length symbol))))
 831       ()
 832     (if (stringp symbol)
 833         (setq symbol (intern symbol)))
 834     (check-argument-type 'symbolp symbol)
 835     (custom-buffer-create-other-window
 836      (list (list symbol 'custom-face))
 837      (format "*Customize Face: %s*" (custom-unlispify-tag-name symbol)))))
 838
 839 ;;;###autoload
 840 (defun customize-customized ()
 841   "Customize all user options set since the last save in this session."
 842   (interactive)
 843   (let ((found nil))
 844     (mapatoms (lambda (symbol)
 845                 (and (get symbol 'customized-face)
 846                      (find-face symbol)
 847                      (push (list symbol 'custom-face) found))
 848                 (and (get symbol 'customized-value)
 849                      (boundp symbol)
 850                      (push (list symbol 'custom-variable) found))))
 851     (if (not found)
 852         (error "No customized user options")
 853       (custom-buffer-create (custom-sort-items found t nil)
 854                             "*Customize Customized*"))))
 855
 856 ;;;###autoload
 857 (defun customize-saved ()
 858   "Customize all already saved user options."
 859   (interactive)
 860   (let ((found nil))
 861     (mapatoms (lambda (symbol)
 862                 (and (get symbol 'saved-face)
 863                      (find-face symbol)
 864                      (push (list symbol 'custom-face) found))
 865                 (and (get symbol 'saved-value)
 866                      (boundp symbol)
 867                      (push (list symbol 'custom-variable) found))))
 868     (if (not found )
 869         (error "No saved user options")
 870       (custom-buffer-create (custom-sort-items found t nil)
 871                             "*Customize Saved*"))))
 872
 873 ;;;###autoload
 874 (defun customize-apropos (regexp &optional all)
 875   "Customize all user options matching REGEXP.
 876 If ALL is `options', include only options.
 877 If ALL is `faces', include only faces.
 878 If ALL is `groups', include only groups.
 879 If ALL is t (interactively, with prefix arg), include options which are not
 880 user-settable, as well as faces and groups."
 881   (interactive "sCustomize regexp: \nP")
 882   (let ((found nil))
 883     (mapatoms (lambda (symbol)
 884                 (when (string-match regexp (symbol-name symbol))
 885                   (when (and (not (memq all '(faces options)))
 886                              (get symbol 'custom-group))
 887                     (push (list symbol 'custom-group) found))
 888                   (when (and (not (memq all '(options groups)))
 889                              (find-face symbol))
 890                     (push (list symbol 'custom-face) found))
 891                   (when (and (not (memq all '(groups faces)))
 892                              (boundp symbol)
 893                              (or (get symbol 'saved-value)
 894                                  (get symbol 'standard-value)
 895                                  (if (memq all '(nil options))
 896                                      (user-variable-p symbol)
 897                                    (get symbol 'variable-documentation))))
 898                     (push (list symbol 'custom-variable) found)))))
 899     (if (not found)
 900         (error "No matches")
 901       (custom-buffer-create (custom-sort-items found t
 902                                                custom-buffer-order-groups)
 903                             "*Customize Apropos*"))))
 904
 905 ;;;###autoload
 906 (defun customize-apropos-options (regexp &optional arg)
 907   "Customize all user options matching REGEXP.
 908 With prefix arg, include options which are not user-settable."
 909   (interactive "sCustomize regexp: \nP")
 910   (customize-apropos regexp (or arg 'options)))
 911
 912 ;;;###autoload
 913 (defun customize-apropos-faces (regexp)
 914   "Customize all user faces matching REGEXP."
 915   (interactive "sCustomize regexp: \n")
 916   (customize-apropos regexp 'faces))
 917
 918 ;;;###autoload
 919 (defun customize-apropos-groups (regexp)
 920   "Customize all user groups matching REGEXP."
 921   (interactive "sCustomize regexp: \n")
 922   (customize-apropos regexp 'groups))
 923
 924 \f
 925 ;;; Buffer.
 926
 927 (defcustom custom-buffer-style 'links
 928   "*Control the presentation style for customization buffers.
 929 The value should be a symbol, one of:
 930
 931 brackets: groups nest within each other with big horizontal brackets.
 932 links: groups have links to subgroups."
 933   :type '(radio (const :tag "brackets: Groups nest within each others" brackets)
 934                 (const :tag "links: Group have links to subgroups" links))
 935   :group 'custom-buffer)
 936
 937 (defcustom custom-buffer-done-function 'kill-buffer
 938   "*Function to be used to remove the buffer when the user is done with it.
 939 Choices include `kill-buffer' (the default) and `bury-buffer'.
 940 The function will be called with one argument, the buffer to remove."
 941   :type '(radio (function-item kill-buffer)
 942                 (function-item bury-buffer)
 943                 (function :tag "Other" nil))
 944   :group 'custom-buffer)
 945
 946 (defcustom custom-buffer-indent 3
 947   "Number of spaces to indent nested groups."
 948   :type 'integer
 949   :group 'custom-buffer)
 950
 951 ;;;###autoload
 952 (defun custom-buffer-create (options &optional name description)
 953   "Create a buffer containing OPTIONS.
 954 Optional NAME is the name of the buffer.
 955 OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where
 956 SYMBOL is a customization option, and WIDGET is a widget for editing
 957 that option."
 958   (unless name (setq name "*Customization*"))
 959   (kill-buffer (get-buffer-create name))
 960   (switch-to-buffer (get-buffer-create name))
 961   (custom-buffer-create-internal options description))
 962
 963 ;;;###autoload
 964 (defun custom-buffer-create-other-window (options &optional name description)
 965   "Create a buffer containing OPTIONS.
 966 Optional NAME is the name of the buffer.
 967 OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where
 968 SYMBOL is a customization option, and WIDGET is a widget for editing
 969 that option."
 970   (unless name (setq name "*Customization*"))
 971   (kill-buffer (get-buffer-create name))
 972   (let ((window (selected-window)))
 973     (switch-to-buffer-other-window (get-buffer-create name))
 974     (custom-buffer-create-internal options description)
 975     (select-window window)))
 976
 977 (defcustom custom-reset-button-menu t
 978   "If non-nil, only show a single reset button in customize buffers.
 979 This button will have a menu with all three reset operations."
 980   :type 'boolean
 981   :group 'custom-buffer)
 982
 983 (defconst custom-skip-messages 5)
 984
 985 (defun Custom-buffer-done ()
 986   "Remove current buffer.
 987 This works by calling the function specified by
 988  `custom-buffer-done-function'."
 989   (interactive)
 990   (funcall custom-buffer-done-function (current-buffer)))
 991
 992 (defun custom-buffer-create-buttons ()
 993   (message "Creating customization buttons...")
 994   (widget-insert "\nOperate on everything in this buffer:\n ")
 995   (widget-create 'push-button
 996                  :tag "Set"
 997                  :tag-glyph '("set-up" "set-down")
 998                  :help-echo "\
 999 Make your editing in this buffer take effect for this session"
1000                  :action (lambda (widget &optional event)
1001                            (Custom-set)))
1002   (widget-insert " ")
1003   (widget-create 'push-button
1004                  :tag "Save"
1005                  :tag-glyph '("save-up" "save-down")
1006                  :help-echo "\
1007 Make your editing in this buffer take effect for future Emacs sessions"
1008                  :action (lambda (widget &optional event)
1009                            (Custom-save)))
1010   (if custom-reset-button-menu
1011       (progn
1012         (widget-insert " ")
1013         (widget-create 'push-button
1014                        :tag "Reset"
1015                        :tag-glyph '("reset-up" "reset-down")
1016                        :help-echo "Show a menu with reset operations"
1017                        :mouse-down-action (lambda (&rest junk) t)
1018                        :action (lambda (widget &optional event)
1019                                  (custom-reset event))))
1020     (widget-insert " ")
1021     (widget-create 'push-button
1022                    :tag "Reset"
1023                    :help-echo "\
1024 Reset all edited text in this buffer to reflect current values"
1025                    :action 'Custom-reset-current)
1026     (widget-insert " ")
1027     (widget-create 'push-button
1028                    :tag "Reset to Saved"
1029                    :help-echo "\
1030 Reset all values in this buffer to their saved settings"
1031                    :action 'Custom-reset-saved)
1032     (widget-insert " ")
1033     (widget-create 'push-button
1034                    :tag "Reset to Standard"
1035                    :help-echo "\
1036 Reset all values in this buffer to their standard settings"
1037                    :action 'Custom-reset-standard))
1038   (widget-insert "  ")
1039   (widget-create 'push-button
1040                  :tag "Done"
1041                  :tag-glyph '("done-up" "done-down")
1042                  :help-echo "Remove the buffer"
1043                  :action (lambda (widget &optional event)
1044                            (Custom-buffer-done)))
1045   (widget-insert "\n"))
1046
1047 (defcustom custom-novice t
1048   "If non-nil, show help message at top of customize buffers."
1049   :type 'boolean
1050   :group 'custom-buffer)
1051
1052 (defcustom custom-display-global-buttons 'top
1053   "If `nil' don't display the global buttons.  If `top' display at the
1054 beginning of custom buffers.  If `bottom', display at the end."
1055   :type '(choice (const top)
1056                  (const bottom)
1057                  (const :tag "don't" nil))
1058   :group 'custom-buffer)
1059
1060 (defun custom-buffer-create-internal (options &optional description)
1061   (message "Creating customization buffer...")
1062   (custom-mode)
1063   (widget-insert "This is a customization buffer")
1064   (if description
1065       (widget-insert description))
1066   (when custom-novice
1067       (widget-insert ".\n\
1068 Type RET or click button2 on an active field to invoke its action.
1069 Invoke ")
1070       (widget-create 'info-link
1071                      :tag "Help"
1072                      :help-echo "Read the online help"
1073                      "(XEmacs)Easy Customization")
1074       (widget-insert " for more information."))
1075   (widget-insert "\n")
1076   (if (equal custom-display-global-buttons 'top)
1077       (custom-buffer-create-buttons))
1078   (widget-insert "\n")
1079   (message "Creating customization items...")
1080   (setq custom-options
1081         (if (= (length options) 1)
1082             (mapcar (lambda (entry)
1083                       (widget-create (nth 1 entry)
1084                                      :documentation-shown t
1085                                      :custom-state 'unknown
1086                                      :tag (custom-unlispify-tag-name
1087                                            (nth 0 entry))
1088                                      :value (nth 0 entry)))
1089                     options)
1090           (let ((count 0)
1091                 (length (length options)))
1092             (mapcar (lambda (entry)
1093                       (prog2
1094                           (display-message
1095                            'progress
1096                            (format "Creating customization items %2d%%..."
1097                                    (/ (* 100.0 count) length)))
1098                           (widget-create (nth 1 entry)
1099                                          :tag (custom-unlispify-tag-name
1100                                                (nth 0 entry))
1101                                          :value (nth 0 entry))
1102                         (incf count)
1103                         (unless (eq (preceding-char) ?\n)
1104                           (widget-insert "\n"))
1105                         (widget-insert "\n")))
1106                     options))))
1107   (unless (eq (preceding-char) ?\n)
1108     (widget-insert "\n"))
1109   (if (equal custom-display-global-buttons 'bottom)
1110       (custom-buffer-create-buttons))
1111   (display-message 'progress
1112                    (format
1113                     "Creating customization items %2d%%...done" 100))
1114   (unless (eq custom-buffer-style 'tree)
1115     (mapc 'custom-magic-reset custom-options))
1116   (message "Creating customization setup...")
1117   (widget-setup)
1118   (goto-char (point-min))
1119   (message "Creating customization buffer...done"))
1120
1121 \f
1122 ;;; The Tree Browser.
1123
1124 ;;;###autoload
1125 (defun customize-browse (&optional group)
1126   "Create a tree browser for the customize hierarchy."
1127   (interactive)
1128   (unless group
1129     (setq group 'emacs))
1130   (let ((name "*Customize Browser*"))
1131     (kill-buffer (get-buffer-create name))
1132     (switch-to-buffer (get-buffer-create name)))
1133   (custom-mode)
1134   (widget-insert "\
1135 Square brackets show active fields; type RET or click button2
1136 on an active field to invoke its action.
1137 Invoke [+] below to expand a group, and [-] to collapse an expanded group.\n")
1138   (if custom-browse-only-groups
1139       (widget-insert "\
1140 Invoke the [Group] button below to edit that item in another window.\n\n")
1141     (widget-insert "Invoke the ")
1142     (widget-create 'item
1143                    :format "%t"
1144                    :tag "[Group]"
1145                    :tag-glyph "folder")
1146     (widget-insert ", ")
1147     (widget-create 'item
1148                    :format "%t"
1149                    :tag "[Face]"
1150                    :tag-glyph "face")
1151     (widget-insert ", and ")
1152     (widget-create 'item
1153                    :format "%t"
1154                    :tag "[Option]"
1155                    :tag-glyph "option")
1156     (widget-insert " buttons below to edit that
1157 item in another window.\n\n"))
1158   (let ((custom-buffer-style 'tree))
1159     (widget-create 'custom-group
1160                    :custom-last t
1161                    :custom-state 'unknown
1162                    :tag (custom-unlispify-tag-name group)
1163                    :value group))
1164   (widget-add-change)
1165   (goto-char (point-min)))
1166
1167 (define-widget 'custom-browse-visibility 'item
1168   "Control visibility of of items in the customize tree browser."
1169   :format "%[[%t]%]"
1170   :action 'custom-browse-visibility-action)
1171
1172 (defun custom-browse-visibility-action (widget &rest ignore)
1173   (let ((custom-buffer-style 'tree))
1174     (custom-toggle-parent widget)))
1175
1176 (define-widget 'custom-browse-group-tag 'push-button
1177   "Show parent in other window when activated."
1178   :tag "Group"
1179   :tag-glyph "folder"
1180   :action 'custom-browse-group-tag-action)
1181
1182 (defun custom-browse-group-tag-action (widget &rest ignore)
1183   (let ((parent (widget-get widget :parent)))
1184     (customize-group-other-window (widget-value parent))))
1185
1186 (define-widget 'custom-browse-variable-tag 'push-button
1187   "Show parent in other window when activated."
1188   :tag "Option"
1189   :tag-glyph "option"
1190   :action 'custom-browse-variable-tag-action)
1191
1192 (defun custom-browse-variable-tag-action (widget &rest ignore)
1193   (let ((parent (widget-get widget :parent)))
1194     (customize-variable-other-window (widget-value parent))))
1195
1196 (define-widget 'custom-browse-face-tag 'push-button
1197   "Show parent in other window when activated."
1198   :tag "Face"
1199   :tag-glyph "face"
1200   :action 'custom-browse-face-tag-action)
1201
1202 (defun custom-browse-face-tag-action (widget &rest ignore)
1203   (let ((parent (widget-get widget :parent)))
1204     (customize-face-other-window (widget-value parent))))
1205
1206 (defconst custom-browse-alist '(("   " "space")
1207                                 (" | " "vertical")
1208                                 ("-\\ " "top")
1209                                 (" |-" "middle")
1210                                 (" `-" "bottom")))
1211
1212 (defun custom-browse-insert-prefix (prefix)
1213   "Insert PREFIX.  On XEmacs convert it to line graphics."
1214   ;; ### Unfinished.
1215   (if nil ; (string-match "XEmacs" emacs-version)
1216       (progn
1217         (insert "*")
1218         (while (not (string-equal prefix ""))
1219           (let ((entry (substring prefix 0 3)))
1220             (setq prefix (substring prefix 3))
1221             (let ((overlay (make-overlay (1- (point)) (point) nil t nil))
1222                   (name (nth 1 (assoc entry custom-browse-alist))))
1223               (overlay-put overlay 'end-glyph (widget-glyph-find name entry))
1224               (overlay-put overlay 'start-open t)
1225               (overlay-put overlay 'end-open t)))))
1226     (insert prefix)))
1227
1228 \f
1229 ;;; Modification of Basic Widgets.
1230 ;;
1231 ;; We add extra properties to the basic widgets needed here.  This is
1232 ;; fine, as long as we are careful to stay within out own namespace.
1233 ;;
1234 ;; We want simple widgets to be displayed by default, but complex
1235 ;; widgets to be hidden.
1236
1237 (widget-put (get 'item 'widget-type) :custom-show t)
1238 (widget-put (get 'editable-field 'widget-type)
1239             :custom-show (lambda (widget value)
1240                            ;; This used to call pp-to-string
1241                            (let ((pp (widget-prettyprint-to-string value)))
1242                              (cond ((string-match "\n" pp)
1243                                     nil)
1244                                    ((> (length pp) 40)
1245                                     nil)
1246                                    (t t)))))
1247 (widget-put (get 'menu-choice 'widget-type) :custom-show t)
1248
1249 ;;; The `custom-manual' Widget.
1250
1251 (define-widget 'custom-manual 'info-link
1252   "Link to the manual entry for this customization option."
1253   :tag "Manual")
1254
1255 ;;; The `custom-magic' Widget.
1256
1257 (defgroup custom-magic-faces nil
1258   "Faces used by the magic button."
1259   :group 'custom-faces
1260   :group 'custom-buffer)
1261
1262 (defface custom-invalid-face '((((class color))
1263                                 (:foreground "yellow" :background "red"))
1264                                (t
1265                                 (:bold t :italic t :underline t)))
1266   "Face used when the customize item is invalid."
1267   :group 'custom-magic-faces)
1268
1269 (defface custom-rogue-face '((((class color))
1270                               (:foreground "pink" :background "black"))
1271                              (t
1272                               (:underline t)))
1273   "Face used when the customize item is not defined for customization."
1274   :group 'custom-magic-faces)
1275
1276 (defface custom-modified-face '((((class color))
1277                                  (:foreground "white" :background "blue"))
1278                                 (t
1279                                  (:italic t :bold)))
1280   "Face used when the customize item has been modified."
1281   :group 'custom-magic-faces)
1282
1283 (defface custom-set-face '((((class color))
1284                                 (:foreground "blue" :background "white"))
1285                                (t
1286                                 (:italic t)))
1287   "Face used when the customize item has been set."
1288   :group 'custom-magic-faces)
1289
1290 (defface custom-changed-face '((((class color))
1291                                 (:foreground "white" :background "blue"))
1292                                (t
1293                                 (:italic t)))
1294   "Face used when the customize item has been changed."
1295   :group 'custom-magic-faces)
1296
1297 (defface custom-saved-face '((t (:underline t)))
1298   "Face used when the customize item has been saved."
1299   :group 'custom-magic-faces)
1300
1301 (defconst custom-magic-alist '((nil "#" underline "\
1302 uninitialized, you should not see this.")
1303                                (unknown "?" italic "\
1304 unknown, you should not see this.")
1305                                (hidden "-" default "\
1306 hidden, invoke \"Show\" button in the previous line to show." "\
1307 group now hidden, invoke the above \"Show\" button to show contents.")
1308                                (invalid "x" custom-invalid-face "\
1309 the value displayed for this %c is invalid and cannot be set.")
1310                                (modified "*" custom-modified-face "\
1311 you have edited the value as text, but you have not set the %c." "\
1312 you have edited something in this group, but not set it.")
1313                                (set "+" custom-set-face "\
1314 you have set this %c, but not saved it for future sessions." "\
1315 something in this group has been set, but not saved.")
1316                                (changed ":" custom-changed-face "\
1317 this %c has been changed outside the customize buffer." "\
1318 something in this group has been changed outside customize.")
1319                                (saved "!" custom-saved-face "\
1320 this %c has been set and saved." "\
1321 something in this group has been set and saved.")
1322                                (rogue "@" custom-rogue-face "\
1323 this %c has not been changed with customize." "\
1324 something in this group is not prepared for customization.")
1325                                (standard " " nil "\
1326 this %c is unchanged from its standard setting." "\
1327 visible group members are all at standard settings."))
1328   "Alist of customize option states.
1329 Each entry is of the form (STATE MAGIC FACE ITEM-DESC [ GROUP-DESC ]), where
1330
1331 STATE is one of the following symbols:
1332
1333 `nil'
1334    For internal use, should never occur.
1335 `unknown'
1336    For internal use, should never occur.
1337 `hidden'
1338    This item is not being displayed.
1339 `invalid'
1340    This item is modified, but has an invalid form.
1341 `modified'
1342    This item is modified, and has a valid form.
1343 `set'
1344    This item has been set but not saved.
1345 `changed'
1346    The current value of this item has been changed temporarily.
1347 `saved'
1348    This item is marked for saving.
1349 `rogue'
1350    This item has no customization information.
1351 `standard'
1352    This item is unchanged from the standard setting.
1353
1354 MAGIC is a string used to present that state.
1355
1356 FACE is a face used to present the state.
1357
1358 ITEM-DESC is a string describing the state for options.
1359
1360 GROUP-DESC is a string describing the state for groups.  If this is
1361 left out, ITEM-DESC will be used.
1362
1363 The string %c in either description will be replaced with the
1364 category of the item.  These are `group'. `option', and `face'.
1365
1366 The list should be sorted most significant first.")
1367
1368 (defcustom custom-magic-show 'long
1369   "If non-nil, show textual description of the state.
1370 If `long', show a full-line description, not just one word."
1371   :type '(choice (const :tag "no" nil)
1372                  (const short)
1373                  (const long))
1374   :group 'custom-buffer)
1375
1376 (defcustom custom-magic-show-hidden '(option face)
1377   "Control whether the State button is shown for hidden items.
1378 The value should be a list with the custom categories where the State
1379 button should be visible.  Possible categories are `group', `option',
1380 and `face'."
1381   :type '(set (const group) (const option) (const face))
1382   :group 'custom-buffer)
1383
1384 (defcustom custom-magic-show-button nil
1385   "Show a \"magic\" button indicating the state of each customization option."
1386   :type 'boolean
1387   :group 'custom-buffer)
1388
1389 (define-widget 'custom-magic 'default
1390   "Show and manipulate state for a customization option."
1391   :format "%v"
1392   :action 'widget-parent-action
1393   :notify 'ignore
1394   :value-get 'ignore
1395   :value-create 'custom-magic-value-create
1396   :value-delete 'widget-children-value-delete)
1397
1398 (defun widget-magic-mouse-down-action (widget &optional event)
1399   ;; Non-nil unless hidden.
1400   (not (eq (widget-get (widget-get (widget-get widget :parent) :parent)
1401                        :custom-state)
1402            'hidden)))
1403
1404 (defun custom-magic-value-create (widget)
1405   ;; Create compact status report for WIDGET.
1406   (let* ((parent (widget-get widget :parent))
1407          (state (widget-get parent :custom-state))
1408          (hidden (eq state 'hidden))
1409          (entry (assq state custom-magic-alist))
1410          (magic (nth 1 entry))
1411          (face (nth 2 entry))
1412          (category (widget-get parent :custom-category))
1413          (text (or (and (eq category 'group)
1414                         (nth 4 entry))
1415                    (nth 3 entry)))
1416          (form (widget-get parent :custom-form))
1417          children)
1418     (while (string-match "\\`\\(.*\\)%c\\(.*\\)\\'" text)
1419       (setq text (concat (match-string 1 text)
1420                          (symbol-name category)
1421                          (match-string 2 text))))
1422     (when (and custom-magic-show
1423                (or (not hidden)
1424                    (memq category custom-magic-show-hidden)))
1425       (insert "   ")
1426       (when (and (eq category 'group)
1427                  (not (and (eq custom-buffer-style 'links)
1428                            (> (widget-get parent :custom-level) 1))))
1429         (insert-char ?\  (* custom-buffer-indent
1430                             (widget-get parent :custom-level))))
1431       (push (widget-create-child-and-convert
1432              widget 'choice-item
1433              :help-echo "Change the state of this item"
1434              :format (if hidden "%t" "%[%t%]")
1435              :button-prefix 'widget-push-button-prefix
1436              :button-suffix 'widget-push-button-suffix
1437              :mouse-down-action 'widget-magic-mouse-down-action
1438              :tag "State"
1439              ;;:tag-glyph (or hidden '("state-up" "state-down"))
1440              )
1441             children)
1442       (insert ": ")
1443       (let ((start (point)))
1444         (if (eq custom-magic-show 'long)
1445             (insert text)
1446           (insert (symbol-name state)))
1447         (cond ((eq form 'lisp)
1448                (insert " (lisp)"))
1449               ((eq form 'mismatch)
1450                (insert " (mismatch)")))
1451         (put-text-property start (point) 'face 'custom-state-face))
1452       (insert "\n"))
1453     (when (and (eq category 'group)
1454                (not (and (eq custom-buffer-style 'links)
1455                          (> (widget-get parent :custom-level) 1))))
1456       (insert-char ?\  (* custom-buffer-indent
1457                           (widget-get parent :custom-level))))
1458     (when custom-magic-show-button
1459       (when custom-magic-show
1460         (let ((indent (widget-get parent :indent)))
1461           (when indent
1462             (insert-char ?\  indent))))
1463       (push (widget-create-child-and-convert
1464              widget 'choice-item
1465              :mouse-down-action 'widget-magic-mouse-down-action
1466              :button-face face
1467              :button-prefix ""
1468              :button-suffix ""
1469              :help-echo "Change the state"
1470              :format (if hidden "%t" "%[%t%]")
1471              :tag (if (memq form '(lisp mismatch))
1472                       (concat "(" magic ")")
1473                     (concat "[" magic "]")))
1474             children)
1475       (insert " "))
1476     (widget-put widget :children children)))
1477
1478 (defun custom-magic-reset (widget)
1479   "Redraw the :custom-magic property of WIDGET."
1480   (let ((magic (widget-get widget :custom-magic)))
1481     (widget-value-set magic (widget-value magic))))
1482
1483 ;;; The `custom' Widget.
1484
1485 (defface custom-button-face '((t (:bold t)))
1486   "Face used for buttons in customization buffers."
1487   :group 'custom-faces)
1488
1489 (defface custom-documentation-face nil
1490   "Face used for documentation strings in customization buffers."
1491   :group 'custom-faces)
1492
1493 (defface custom-state-face '((((class color)
1494                                (background dark))
1495                               (:foreground "lime green"))
1496                              (((class color)
1497                                (background light))
1498                               (:foreground "dark green"))
1499                              (t nil))
1500   "Face used for State descriptions in the customize buffer."
1501   :group 'custom-faces)
1502
1503 (define-widget 'custom 'default
1504   "Customize a user option."
1505   :format "%v"
1506   :convert-widget 'custom-convert-widget
1507   :notify 'custom-notify
1508   :custom-prefix ""
1509   :custom-level 1
1510   :custom-state 'hidden
1511   :documentation-property 'widget-subclass-responsibility
1512   :value-create 'widget-subclass-responsibility
1513   :value-delete 'widget-children-value-delete
1514   :value-get 'widget-value-value-get
1515   :validate 'widget-children-validate
1516   :match (lambda (widget value) (symbolp value)))
1517
1518 (defun custom-convert-widget (widget)
1519   ;; Initialize :value and :tag from :args in WIDGET.
1520   (let ((args (widget-get widget :args)))
1521     (when args
1522       (widget-put widget :value (widget-apply widget
1523                                               :value-to-internal (car args)))
1524       (widget-put widget :tag (custom-unlispify-tag-name (car args)))
1525       (widget-put widget :args nil)))
1526   widget)
1527
1528 (defun custom-notify (widget &rest args)
1529   "Keep track of changes."
1530   (let ((state (widget-get widget :custom-state)))
1531     (unless (eq state 'modified)
1532       (unless (memq state '(nil unknown hidden))
1533         (widget-put widget :custom-state 'modified))
1534       (custom-magic-reset widget)
1535       (apply 'widget-default-notify widget args))))
1536
1537 (defun custom-redraw (widget)
1538   "Redraw WIDGET with current settings."
1539   (let ((line (count-lines (point-min) (point)))
1540         (column (current-column))
1541         (pos (point))
1542         (from (marker-position (widget-get widget :from)))
1543         (to (marker-position (widget-get widget :to))))
1544     (save-excursion
1545       (widget-value-set widget (widget-value widget))
1546       (custom-redraw-magic widget))
1547     (when (and (>= pos from) (<= pos to))
1548       (condition-case nil
1549           (progn
1550             (if (> column 0)
1551                 (goto-line line)
1552               (goto-line (1+ line)))
1553             (move-to-column column))
1554         (error nil)))))
1555
1556 (defun custom-redraw-magic (widget)
1557   "Redraw WIDGET state with current settings."
1558   (while widget
1559     (let ((magic (widget-get widget :custom-magic)))
1560       (cond (magic
1561              (widget-value-set magic (widget-value magic))
1562              (when (setq widget (widget-get widget :group))
1563                (custom-group-state-update widget)))
1564             (t
1565              (setq widget nil)))))
1566   (widget-setup))
1567
1568 (defun custom-show (widget value)
1569   "Non-nil if WIDGET should be shown with VALUE by default."
1570   (let ((show (widget-get widget :custom-show)))
1571     (cond ((null show)
1572            nil)
1573           ((eq t show)
1574            t)
1575           (t
1576            (funcall show widget value)))))
1577
1578 (defvar custom-load-recursion nil
1579   "Hack to avoid recursive dependencies.")
1580
1581 (defun custom-load-symbol (symbol)
1582   "Load all dependencies for SYMBOL."
1583   (unless custom-load-recursion
1584     (let ((custom-load-recursion t)
1585           (loads (get symbol 'custom-loads))
1586           load)
1587       (while loads
1588         (setq load (car loads)
1589               loads (cdr loads))
1590         (cond ((symbolp load)
1591                (condition-case nil
1592                    (require load)
1593                  (error nil)))
1594               ;; Don't reload a file already loaded.
1595               ((and (boundp 'preloaded-file-list)
1596                     (member load preloaded-file-list)))
1597               ((assoc load load-history))
1598               ((assoc (locate-library load) load-history))
1599               (t
1600                (condition-case nil
1601                    ;; Without this, we would load cus-edit recursively.
1602                    ;; We are still loading it when we call this,
1603                    ;; and it is not in load-history yet.
1604                    (or (equal load "cus-edit")
1605                        (load-library load))
1606                  (error nil))))))))
1607
1608 (defun custom-load-widget (widget)
1609   "Load all dependencies for WIDGET."
1610   (custom-load-symbol (widget-value widget)))
1611
1612 (defun custom-unloaded-symbol-p (symbol)
1613   "Return non-nil if the dependencies of SYMBOL has not yet been loaded."
1614   (let ((found nil)
1615         (loads (get symbol 'custom-loads))
1616         load)
1617     (while loads
1618       (setq load (car loads)
1619             loads (cdr loads))
1620       (cond ((symbolp load)
1621              (unless (featurep load)
1622                (setq found t)))
1623             ((assoc load load-history))
1624             ((assoc (locate-library load) load-history)
1625              ;; #### WTF???
1626              (message nil))
1627             (t
1628              (setq found t))))
1629     found))
1630
1631 (defun custom-unloaded-widget-p (widget)
1632   "Return non-nil if the dependencies of WIDGET has not yet been loaded."
1633   (custom-unloaded-symbol-p (widget-value widget)))
1634
1635 (defun custom-toggle-hide (widget)
1636   "Toggle visibility of WIDGET."
1637   (custom-load-widget widget)
1638   (let ((state (widget-get widget :custom-state)))
1639     (cond ((memq state '(invalid modified))
1640            (error "There are unset changes"))
1641           ((eq state 'hidden)
1642            (widget-put widget :custom-state 'unknown))
1643           (t
1644            (widget-put widget :documentation-shown nil)
1645            (widget-put widget :custom-state 'hidden)))
1646     (custom-redraw widget)
1647     (widget-setup)))
1648
1649 (defun custom-toggle-parent (widget &rest ignore)
1650   "Toggle visibility of parent of WIDGET."
1651   (custom-toggle-hide (widget-get widget :parent)))
1652
1653 (defun custom-add-see-also (widget &optional prefix)
1654   "Add `See also ...' to WIDGET if there are any links.
1655 Insert PREFIX first if non-nil."
1656   (let* ((symbol (widget-get widget :value))
1657          (links (get symbol 'custom-links))
1658          (many (> (length links) 2))
1659          (buttons (widget-get widget :buttons))
1660          (indent (widget-get widget :indent)))
1661     (when links
1662       (when indent
1663         (insert-char ?\  indent))
1664       (when prefix
1665         (insert prefix))
1666       (insert "See also ")
1667       (while links
1668         (push (widget-create-child-and-convert widget (car links))
1669               buttons)
1670         (setq links (cdr links))
1671         (cond ((null links)
1672                (insert ".\n"))
1673               ((null (cdr links))
1674                (if many
1675                    (insert ", and ")
1676                  (insert " and ")))
1677               (t
1678                (insert ", "))))
1679       (widget-put widget :buttons buttons))))
1680
1681 (defun custom-add-parent-links (widget &optional initial-string)
1682   "Add \"Parent groups: ...\" to WIDGET if the group has parents.
1683 The value if non-nil if any parents were found.
1684 If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"."
1685   (let ((name (widget-value widget))
1686         (type (widget-type widget))
1687         (buttons (widget-get widget :buttons))
1688         (start (point))
1689         found)
1690     (insert (or initial-string "Parent groups:"))
1691     (maphash (lambda (group ignore)
1692                (let ((entry (assq name (get group 'custom-group))))
1693                  (when (eq (nth 1 entry) type)
1694                    (insert " ")
1695                    (push (widget-create-child-and-convert
1696                           widget 'custom-group-link
1697                           :tag (custom-unlispify-tag-name group)
1698                           group)
1699                          buttons)
1700                    (setq found t))))
1701              custom-group-hash-table)
1702     (widget-put widget :buttons buttons)
1703     (if found
1704         (insert "\n")
1705       (delete-region start (point)))
1706     found))
1707
1708 ;;; The `custom-variable' Widget.
1709
1710 (defface custom-variable-tag-face '((((class color)
1711                                       (background dark))
1712                                      (:foreground "light blue" :underline t))
1713                                     (((class color)
1714                                       (background light))
1715                                      (:foreground "blue" :underline t))
1716                                     (t (:underline t)))
1717   "Face used for unpushable variable tags."
1718   :group 'custom-faces)
1719
1720 (defface custom-variable-button-face '((t (:underline t :bold t)))
1721   "Face used for pushable variable tags."
1722   :group 'custom-faces)
1723
1724 (defcustom custom-variable-default-form 'edit
1725   "Default form of displaying variable values."
1726   :type '(choice (const edit)
1727                  (const lisp))
1728   :group 'custom-buffer)
1729
1730 (define-widget 'custom-variable 'custom
1731   "Customize variable."
1732   :format "%v"
1733   :help-echo "Set or reset this variable"
1734   :documentation-property 'variable-documentation
1735   :custom-category 'option
1736   :custom-state nil
1737   :custom-menu 'custom-variable-menu-create
1738   :custom-form nil ; defaults to value of `custom-variable-default-form'
1739   :value-create 'custom-variable-value-create
1740   :action 'custom-variable-action
1741   :custom-set 'custom-variable-set
1742   :custom-save 'custom-variable-save
1743   :custom-reset-current 'custom-redraw
1744   :custom-reset-saved 'custom-variable-reset-saved
1745   :custom-reset-standard 'custom-variable-reset-standard)
1746
1747 (defun custom-variable-type (symbol)
1748   "Return a widget suitable for editing the value of SYMBOL.
1749 If SYMBOL has a `custom-type' property, use that.
1750 Otherwise, look up symbol in `custom-guess-type-alist'."
1751   (let* ((type (or (get symbol 'custom-type)
1752                    (and (not (get symbol 'standard-value))
1753                         (custom-guess-type symbol))
1754                    'sexp))
1755          (options (get symbol 'custom-options))
1756          (tmp (if (listp type)
1757                   (copy-sequence type)
1758                 (list type))))
1759     (when options
1760       (widget-put tmp :options options))
1761     tmp))
1762
1763 (defun custom-variable-value-create (widget)
1764   "Here is where you edit the variables value."
1765   (custom-load-widget widget)
1766   (unless (widget-get widget :custom-form)
1767     (widget-put widget :custom-form custom-variable-default-form))
1768   (let* ((buttons (widget-get widget :buttons))
1769          (children (widget-get widget :children))
1770          (form (widget-get widget :custom-form))
1771          (state (widget-get widget :custom-state))
1772          (symbol (widget-get widget :value))
1773          (tag (widget-get widget :tag))
1774          (type (custom-variable-type symbol))
1775          (conv (widget-convert type))
1776          (get (or (get symbol 'custom-get) 'default-value))
1777          (prefix (widget-get widget :custom-prefix))
1778          (last (widget-get widget :custom-last))
1779          (value (if (default-boundp symbol)
1780                     (funcall get symbol)
1781                   (widget-get conv :value))))
1782     ;; If the widget is new, the child determine whether it is hidden.
1783     (cond (state)
1784           ((custom-show type value)
1785            (setq state 'unknown))
1786           (t
1787            (setq state 'hidden)))
1788     ;; If we don't know the state, see if we need to edit it in lisp form.
1789     (when (eq state 'unknown)
1790       (unless (widget-apply conv :match value)
1791         ;; (widget-apply (widget-convert type) :match value)
1792         (setq form 'mismatch)))
1793     ;; Now we can create the child widget.
1794     (cond ((eq custom-buffer-style 'tree)
1795            (insert prefix (if last " `--- " " |--- "))
1796            (push (widget-create-child-and-convert
1797                   widget 'custom-browse-variable-tag)
1798                  buttons)
1799            (insert " " tag "\n")
1800            (widget-put widget :buttons buttons))
1801           ((eq state 'hidden)
1802            ;; Indicate hidden value.
1803            (push (widget-create-child-and-convert
1804                   widget 'item
1805                   :format "%{%t%}: "
1806                   :sample-face 'custom-variable-tag-face
1807                   :tag tag
1808                   :parent widget)
1809                  buttons)
1810            (push (widget-create-child-and-convert
1811                   widget 'visibility
1812                   :help-echo "Show the value of this option"
1813                   :action 'custom-toggle-parent
1814                   nil)
1815                  buttons))
1816           ((memq form '(lisp mismatch))
1817            ;; In lisp mode edit the saved value when possible.
1818            (let* ((value (cond ((get symbol 'saved-value)
1819                                 (car (get symbol 'saved-value)))
1820                                ((get symbol 'standard-value)
1821                                 (car (get symbol 'standard-value)))
1822                                ((default-boundp symbol)
1823                                 (custom-quote (funcall get symbol)))
1824                                (t
1825                                 (custom-quote (widget-get conv :value))))))
1826              (insert (symbol-name symbol) ": ")
1827              (push (widget-create-child-and-convert
1828                     widget 'visibility
1829                     :help-echo "Hide the value of this option"
1830                     :action 'custom-toggle-parent
1831                     t)
1832                    buttons)
1833              (insert " ")
1834              (push (widget-create-child-and-convert
1835                     widget 'sexp
1836                     :button-face 'custom-variable-button-face
1837                     :format "%v"
1838                     :tag (symbol-name symbol)
1839                     :parent widget
1840                     :value value)
1841                    children)))
1842           (t
1843            ;; Edit mode.
1844            (let* ((format (widget-get type :format))
1845                   tag-format value-format)
1846              (while (not (string-match ":" format))
1847                (setq format (signal 'error (list "Bad format" format))))
1848              (setq tag-format (substring format 0 (match-end 0)))
1849              (setq value-format (substring format (match-end 0)))
1850              (push (widget-create-child-and-convert
1851                     widget 'item
1852                     :format tag-format
1853                     :action 'custom-tag-action
1854                     :help-echo "Change value of this option"
1855                     :mouse-down-action 'custom-tag-mouse-down-action
1856                     :button-face 'custom-variable-button-face
1857                     :sample-face 'custom-variable-tag-face
1858                     tag)
1859                    buttons)
1860              (insert " ")
1861              (push (widget-create-child-and-convert
1862                   widget 'visibility
1863                   :help-echo "Hide the value of this option"
1864                   :action 'custom-toggle-parent
1865                   t)
1866                  buttons)
1867              (push (widget-create-child-and-convert
1868                     widget type
1869                     :format value-format
1870                     :value value)
1871                    children))))
1872     (unless (eq custom-buffer-style 'tree)
1873       ;; Now update the state.
1874       (unless (eq (preceding-char) ?\n)
1875         (widget-insert "\n"))
1876       (if (eq state 'hidden)
1877           (widget-put widget :custom-state state)
1878         (custom-variable-state-set widget))
1879       ;; Create the magic button.
1880       (let ((magic (widget-create-child-and-convert
1881                     widget 'custom-magic nil)))
1882         (widget-put widget :custom-magic magic)
1883         (push magic buttons))
1884       ;; Update properties.
1885       (widget-put widget :custom-form form)
1886       (widget-put widget :buttons buttons)
1887       (widget-put widget :children children)
1888       ;; Insert documentation.
1889       (widget-default-format-handler widget ?h)
1890       ;; See also.
1891       (unless (eq state 'hidden)
1892         (when (eq (widget-get widget :custom-level) 1)
1893           (custom-add-parent-links widget))
1894         (custom-add-see-also widget)))))
1895
1896 (defun custom-tag-action (widget &rest args)
1897   "Pass :action to first child of WIDGET's parent."
1898   (apply 'widget-apply (car (widget-get (widget-get widget :parent) :children))
1899          :action args))
1900
1901 (defun custom-tag-mouse-down-action (widget &rest args)
1902   "Pass :mouse-down-action to first child of WIDGET's parent."
1903   (apply 'widget-apply (car (widget-get (widget-get widget :parent) :children))
1904          :mouse-down-action args))
1905
1906 (defun custom-variable-state-set (widget)
1907   "Set the state of WIDGET."
1908   (let* ((symbol (widget-value widget))
1909          (get (or (get symbol 'custom-get) 'default-value))
1910          (value (if (default-boundp symbol)
1911                     (funcall get symbol)
1912                   (widget-get widget :value)))
1913          tmp
1914          (state (cond ((setq tmp (get symbol 'customized-value))
1915                        (if (condition-case nil
1916                                (equal value (eval (car tmp)))
1917                              (error nil))
1918                            'set
1919                          'changed))
1920                       ((setq tmp (get symbol 'saved-value))
1921                        (if (condition-case nil
1922                                (equal value (eval (car tmp)))
1923                              (error nil))
1924                            'saved
1925                          'changed))
1926                       ((setq tmp (get symbol 'standard-value))
1927                        (if (condition-case nil
1928                                (equal value (eval (car tmp)))
1929                              (error nil))
1930                            'standard
1931                          'changed))
1932                       (t 'rogue))))
1933     (widget-put widget :custom-state state)))
1934
1935 (defvar custom-variable-menu
1936   '(("Set for Current Session" custom-variable-set
1937      (lambda (widget)
1938        (eq (widget-get widget :custom-state) 'modified)))
1939     ("Save for Future Sessions" custom-variable-save
1940      (lambda (widget)
1941        (memq (widget-get widget :custom-state) '(modified set changed rogue))))
1942     ("Reset to Current" custom-redraw
1943      (lambda (widget)
1944        (and (default-boundp (widget-value widget))
1945             (memq (widget-get widget :custom-state) '(modified changed)))))
1946     ("Reset to Saved" custom-variable-reset-saved
1947      (lambda (widget)
1948        (and (get (widget-value widget) 'saved-value)
1949             (memq (widget-get widget :custom-state)
1950                   '(modified set changed rogue)))))
1951     ("Reset to Standard Settings" custom-variable-reset-standard
1952      (lambda (widget)
1953        (and (get (widget-value widget) 'standard-value)
1954             (memq (widget-get widget :custom-state)
1955                   '(modified set changed saved rogue)))))
1956     ("---" ignore ignore)
1957     ("Don't show as Lisp expression" custom-variable-edit
1958      (lambda (widget)
1959        (eq (widget-get widget :custom-form) 'lisp)))
1960     ("Show as Lisp expression" custom-variable-edit-lisp
1961      (lambda (widget)
1962        (eq (widget-get widget :custom-form) 'edit))))
1963   "Alist of actions for the `custom-variable' widget.
1964 Each entry has the form (NAME ACTION FILTER) where NAME is the name of
1965 the menu entry, ACTION is the function to call on the widget when the
1966 menu is selected, and FILTER is a predicate which takes a `custom-variable'
1967 widget as an argument, and returns non-nil if ACTION is valid on that
1968 widget. If FILTER is nil, ACTION is always valid.")
1969
1970 (defun custom-variable-action (widget &optional event)
1971   "Show the menu for `custom-variable' WIDGET.
1972 Optional EVENT is the location for the menu."
1973   (if (eq (widget-get widget :custom-state) 'hidden)
1974       (custom-toggle-hide widget)
1975     (unless (eq (widget-get widget :custom-state) 'modified)
1976       (custom-variable-state-set widget))
1977     ;; Redrawing magic also depresses the state glyph.
1978     ;(custom-redraw-magic widget)
1979     (let* ((completion-ignore-case t)
1980            (answer (widget-choose (concat "Operation on "
1981                                           (custom-unlispify-tag-name
1982                                            (widget-get widget :value)))
1983                                   (custom-menu-filter custom-variable-menu
1984                                                       widget)
1985                                   event)))
1986       (if answer
1987           (funcall answer widget)))))
1988
1989 (defun custom-variable-edit (widget)
1990   "Edit value of WIDGET."
1991   (widget-put widget :custom-state 'unknown)
1992   (widget-put widget :custom-form 'edit)
1993   (custom-redraw widget))
1994
1995 (defun custom-variable-edit-lisp (widget)
1996   "Edit the lisp representation of the value of WIDGET."
1997   (widget-put widget :custom-state 'unknown)
1998   (widget-put widget :custom-form 'lisp)
1999   (custom-redraw widget))
2000
2001 (defun custom-variable-set (widget)
2002   "Set the current value for the variable being edited by WIDGET."
2003   (let* ((form (widget-get widget :custom-form))
2004          (state (widget-get widget :custom-state))
2005          (child (car (widget-get widget :children)))
2006          (symbol (widget-value widget))
2007          (set (or (get symbol 'custom-set) 'set-default))
2008           val)
2009     (cond ((eq state 'hidden)
2010            (error "Cannot set hidden variable"))
2011           ((setq val (widget-apply child :validate))
2012            (goto-char (widget-get val :from))
2013            (error "%s" (widget-get val :error)))
2014           ((memq form '(lisp mismatch))
2015            (funcall set symbol (eval (setq val (widget-value child))))
2016            (put symbol 'customized-value (list val)))
2017           (t
2018            (funcall set symbol (setq val (widget-value child)))
2019            (put symbol 'customized-value (list (custom-quote val)))))
2020     (custom-variable-state-set widget)
2021     (custom-redraw-magic widget)))
2022
2023 (defun custom-variable-save (widget)
2024   "Set and save the value for the variable being edited by WIDGET."
2025   (let* ((form (widget-get widget :custom-form))
2026          (state (widget-get widget :custom-state))
2027          (child (car (widget-get widget :children)))
2028          (symbol (widget-value widget))
2029          (set (or (get symbol 'custom-set) 'set-default))
2030          val)
2031     (cond ((eq state 'hidden)
2032            (error "Cannot set hidden variable"))
2033           ((setq val (widget-apply child :validate))
2034            (goto-char (widget-get val :from))
2035            (error "%s" (widget-get val :error)))
2036           ((memq form '(lisp mismatch))
2037            (put symbol 'saved-value (list (widget-value child)))
2038            (funcall set symbol (eval (widget-value child))))
2039           (t
2040            (put symbol
2041                 'saved-value (list (custom-quote (widget-value
2042                                                   child))))
2043            (funcall set symbol (widget-value child))))
2044     (put symbol 'customized-value nil)
2045     (custom-save-all)
2046     (custom-variable-state-set widget)
2047     (custom-redraw-magic widget)))
2048
2049 (defun custom-variable-reset-saved (widget)
2050   "Restore the saved value for the variable being edited by WIDGET."
2051   (let* ((symbol (widget-value widget))
2052          (set (or (get symbol 'custom-set) 'set-default)))
2053     (if (get symbol 'saved-value)
2054         (condition-case nil
2055             (funcall set symbol (eval (car (get symbol 'saved-value))))
2056           (error nil))
2057       (signal 'error (list "No saved value for variable" symbol)))
2058     (put symbol 'customized-value nil)
2059     (widget-put widget :custom-state 'unknown)
2060     (custom-redraw widget)))
2061
2062 (defun custom-variable-reset-standard (widget)
2063   "Restore the standard setting for the variable being edited by WIDGET."
2064   (let* ((symbol (widget-value widget))
2065          (set (or (get symbol 'custom-set) 'set-default)))
2066     (if (get symbol 'standard-value)
2067         (funcall set symbol (eval (car (get symbol 'standard-value))))
2068       (signal 'error (list "No standard setting known for variable" symbol)))
2069     (put symbol 'customized-value nil)
2070     (when (get symbol 'saved-value)
2071       (put symbol 'saved-value nil)
2072       (custom-save-all))
2073     (widget-put widget :custom-state 'unknown)
2074     (custom-redraw widget)))
2075
2076 ;;; The `custom-face-edit' Widget.
2077
2078 (define-widget 'custom-face-edit 'checklist
2079   "Edit face attributes."
2080   :format "%t: %v"
2081   :tag "Attributes"
2082   :extra-offset 12
2083   :button-args '(:help-echo "Control whether this attribute have any effect")
2084   :args (mapcar (lambda (att)
2085                   (list 'group
2086                         :inline t
2087                         :sibling-args (widget-get (nth 1 att) :sibling-args)
2088                         (list 'const :format "" :value (nth 0 att))
2089                         (nth 1 att)))
2090                 custom-face-attributes))
2091
2092 ;;; The `custom-display' Widget.
2093
2094 (define-widget 'custom-display 'menu-choice
2095   "Select a display type."
2096   :tag "Display"
2097   :value t
2098   :help-echo "Specify frames where the face attributes should be used"
2099   :args '((const :tag "all" t)
2100           (checklist
2101            :offset 0
2102            :extra-offset 9
2103            :args ((group :sibling-args (:help-echo "\
2104 Only match the specified window systems")
2105                          (const :format "Type: "
2106                                 type)
2107                          (checklist :inline t
2108                                     :offset 0
2109                                     (const :format "X "
2110                                            :sibling-args (:help-echo "\
2111 The X11 Window System")
2112                                            x)
2113                                     (const :format "PM "
2114                                            :sibling-args (:help-echo "\
2115 OS/2 Presentation Manager")
2116                                            pm)
2117                                     (const :format "MSWindows "
2118                                            :sibling-args (:help-echo "\
2119 Windows NT/95/97")
2120                                            mswindows)
2121                                     (const :format "DOS "
2122                                            :sibling-args (:help-echo "\
2123 Plain MS-DOS")
2124                                            pc)
2125                                     (const :format "TTY%n"
2126                                            :sibling-args (:help-echo "\
2127 Plain text terminals")
2128                                            tty)))
2129                   (group :sibling-args (:help-echo "\
2130 Only match the frames with the specified color support")
2131                          (const :format "Class: "
2132                                 class)
2133                          (checklist :inline t
2134                                     :offset 0
2135                                     (const :format "Color "
2136                                            :sibling-args (:help-echo "\
2137 Match color frames")
2138                                            color)
2139                                     (const :format "Grayscale "
2140                                            :sibling-args (:help-echo "\
2141 Match grayscale frames")
2142                                            grayscale)
2143                                     (const :format "Monochrome%n"
2144                                            :sibling-args (:help-echo "\
2145 Match frames with no color support")
2146                                            mono)))
2147                   (group :sibling-args (:help-echo "\
2148 Only match frames with the specified intensity")
2149                          (const :format "\
2150 Background brightness: "
2151                                 background)
2152                          (checklist :inline t
2153                                     :offset 0
2154                                     (const :format "Light "
2155                                            :sibling-args (:help-echo "\
2156 Match frames with light backgrounds")
2157                                            light)
2158                                     (const :format "Dark\n"
2159                                            :sibling-args (:help-echo "\
2160 Match frames with dark backgrounds")
2161                                            dark)))))))
2162
2163 ;;; The `custom-face' Widget.
2164
2165 (defface custom-face-tag-face '((t (:underline t)))
2166   "Face used for face tags."
2167   :group 'custom-faces)
2168
2169 (defcustom custom-face-default-form 'selected
2170   "Default form of displaying face definition."
2171   :type '(choice (const all)
2172                  (const selected)
2173                  (const lisp))
2174   :group 'custom-buffer)
2175
2176 (define-widget 'custom-face 'custom
2177   "Customize face."
2178   :sample-face 'custom-face-tag-face
2179   :help-echo "Set or reset this face"
2180   :documentation-property '(lambda (face)
2181                              (face-doc-string face))
2182   :value-create 'custom-face-value-create
2183   :action 'custom-face-action
2184   :custom-category 'face
2185   :custom-form nil ; defaults to value of `custom-face-default-form'
2186   :custom-set 'custom-face-set
2187   :custom-save 'custom-face-save
2188   :custom-reset-current 'custom-redraw
2189   :custom-reset-saved 'custom-face-reset-saved
2190   :custom-reset-standard 'custom-face-reset-standard
2191   :custom-menu 'custom-face-menu-create)
2192
2193 (define-widget 'custom-face-all 'editable-list
2194   "An editable list of display specifications and attributes."
2195   :entry-format "%i %d %v"
2196   :insert-button-args '(:help-echo "Insert new display specification here")
2197   :append-button-args '(:help-echo "Append new display specification here")
2198   :delete-button-args '(:help-echo "Delete this display specification")
2199   :args '((group :format "%v" custom-display custom-face-edit)))
2200
2201 (defconst custom-face-all (widget-convert 'custom-face-all)
2202   "Converted version of the `custom-face-all' widget.")
2203
2204 (define-widget 'custom-display-unselected 'item
2205   "A display specification that doesn't match the selected display."
2206   :match 'custom-display-unselected-match)
2207
2208 (defun custom-display-unselected-match (widget value)
2209   "Non-nil if VALUE is an unselected display specification."
2210   (not (face-spec-set-match-display value (selected-frame))))
2211
2212 (define-widget 'custom-face-selected 'group
2213   "Edit the attributes of the selected display in a face specification."
2214   :args '((repeat :format ""
2215                   :inline t
2216                   (group custom-display-unselected sexp))
2217           (group (sexp :format "") custom-face-edit)
2218           (repeat :format ""
2219                   :inline t
2220                   sexp)))
2221
2222 (defconst custom-face-selected (widget-convert 'custom-face-selected)
2223   "Converted version of the `custom-face-selected' widget.")
2224
2225 (defun custom-face-value-create (widget)
2226   "Create a list of the display specifications for WIDGET."
2227   (let ((buttons (widget-get widget :buttons))
2228         (symbol (widget-get widget :value))
2229         (tag (widget-get widget :tag))
2230         (state (widget-get widget :custom-state))
2231         (begin (point))
2232         (is-last (widget-get widget :custom-last))
2233         (prefix (widget-get widget :custom-prefix)))
2234     (unless tag
2235       (setq tag (prin1-to-string symbol)))
2236     (cond ((eq custom-buffer-style 'tree)
2237            (insert prefix (if is-last " `--- " " |--- "))
2238            (push (widget-create-child-and-convert
2239                   widget 'custom-browse-face-tag)
2240                  buttons)
2241            (insert " " tag "\n")
2242            (widget-put widget :buttons buttons))
2243           (t
2244            ;; Create tag.
2245            (insert tag)
2246            (if (eq custom-buffer-style 'face)
2247                (insert " ")
2248              (widget-specify-sample widget begin (point))
2249              (insert ": "))
2250            ;; Sample.
2251            (and (not (find-face symbol))
2252                 ;; XEmacs cannot display uninitialized faces.
2253                 (make-face symbol))
2254            (push (widget-create-child-and-convert widget 'item
2255                                                   :format "(%{%t%})"
2256                                                   :sample-face symbol
2257                                                   :tag "sample")
2258                  buttons)
2259            ;; Visibility.
2260            (insert " ")
2261            (push (widget-create-child-and-convert
2262                   widget 'visibility
2263                   :help-echo "Hide or show this face"
2264                   :action 'custom-toggle-parent
2265                   (not (eq state 'hidden)))
2266                  buttons)
2267            ;; Magic.
2268            (insert "\n")
2269            (let ((magic (widget-create-child-and-convert
2270                          widget 'custom-magic nil)))
2271              (widget-put widget :custom-magic magic)
2272              (push magic buttons))
2273            ;; Update buttons.
2274            (widget-put widget :buttons buttons)
2275            ;; Insert documentation.
2276            (widget-default-format-handler widget ?h)
2277            ;; See also.
2278            (unless (eq state 'hidden)
2279              (when (eq (widget-get widget :custom-level) 1)
2280                (custom-add-parent-links widget))
2281              (custom-add-see-also widget))
2282            ;; Editor.
2283            (unless (eq (preceding-char) ?\n)
2284              (insert "\n"))
2285            (unless (eq state 'hidden)
2286              (message "Creating face editor...")
2287              (custom-load-widget widget)
2288              (unless (widget-get widget :custom-form)
2289                  (widget-put widget :custom-form custom-face-default-form))
2290              (let* ((symbol (widget-value widget))
2291                     (spec (or (get symbol 'customized-face)
2292                               (get symbol 'saved-face)
2293                               (get symbol 'face-defface-spec)
2294                               ;; Attempt to construct it.
2295                               (list (list t (face-custom-attributes-get
2296                                              symbol (selected-frame))))))
2297                     (form (widget-get widget :custom-form))
2298                     (indent (widget-get widget :indent))
2299                     (edit (widget-create-child-and-convert
2300                            widget
2301                            (cond ((and (eq form 'selected)
2302                                        (widget-apply custom-face-selected
2303                                                      :match spec))
2304                                   (when indent (insert-char ?\  indent))
2305                                   'custom-face-selected)
2306                                  ((and (not (eq form 'lisp))
2307                                        (widget-apply custom-face-all
2308                                                      :match spec))
2309                                   'custom-face-all)
2310                                  (t
2311                                   (when indent (insert-char ?\  indent))
2312                                   'sexp))
2313                            :value spec)))
2314                (custom-face-state-set widget)
2315                (widget-put widget :children (list edit)))
2316              (message "Creating face editor...done"))))))
2317
2318 (defvar custom-face-menu
2319   '(("Set for Current Session" custom-face-set)
2320     ("Save for Future Sessions" custom-face-save)
2321     ("Reset to Saved" custom-face-reset-saved
2322      (lambda (widget)
2323        (get (widget-value widget) 'saved-face)))
2324     ("Reset to Standard Setting" custom-face-reset-standard
2325      (lambda (widget)
2326        (get (widget-value widget) 'face-defface-spec)))
2327     ("---" ignore ignore)
2328     ("Show all display specs" custom-face-edit-all
2329      (lambda (widget)
2330        (not (eq (widget-get widget :custom-form) 'all))))
2331     ("Just current attributes" custom-face-edit-selected
2332      (lambda (widget)
2333        (not (eq (widget-get widget :custom-form) 'selected))))
2334     ("Show as Lisp expression" custom-face-edit-lisp
2335      (lambda (widget)
2336        (not (eq (widget-get widget :custom-form) 'lisp)))))
2337   "Alist of actions for the `custom-face' widget.
2338 Each entry has the form (NAME ACTION FILTER) where NAME is the name of
2339 the menu entry, ACTION is the function to call on the widget when the
2340 menu is selected, and FILTER is a predicate which takes a `custom-face'
2341 widget as an argument, and returns non-nil if ACTION is valid on that
2342 widget. If FILTER is nil, ACTION is always valid.")
2343
2344 (defun custom-face-edit-selected (widget)
2345   "Edit selected attributes of the value of WIDGET."
2346   (widget-put widget :custom-state 'unknown)
2347   (widget-put widget :custom-form 'selected)
2348   (custom-redraw widget))
2349
2350 (defun custom-face-edit-all (widget)
2351   "Edit all attributes of the value of WIDGET."
2352   (widget-put widget :custom-state 'unknown)
2353   (widget-put widget :custom-form 'all)
2354   (custom-redraw widget))
2355
2356 (defun custom-face-edit-lisp (widget)
2357   "Edit the lisp representation of the value of WIDGET."
2358   (widget-put widget :custom-state 'unknown)
2359   (widget-put widget :custom-form 'lisp)
2360   (custom-redraw widget))
2361
2362 (defun custom-face-state-set (widget)
2363   "Set the state of WIDGET."
2364   (let ((symbol (widget-value widget)))
2365     (widget-put widget :custom-state (cond ((get symbol 'customized-face)
2366                                             'set)
2367                                            ((get symbol 'saved-face)
2368                                             'saved)
2369                                            ((get symbol 'face-defface-spec)
2370                                             'standard)
2371                                            (t
2372                                             'rogue)))))
2373
2374 (defun custom-face-action (widget &optional event)
2375   "Show the menu for `custom-face' WIDGET.
2376 Optional EVENT is the location for the menu."
2377   (if (eq (widget-get widget :custom-state) 'hidden)
2378       (custom-toggle-hide widget)
2379     (let* ((completion-ignore-case t)
2380            (symbol (widget-get widget :value))
2381            (answer (widget-choose (concat "Operation on "
2382                                           (custom-unlispify-tag-name symbol))
2383                                   (custom-menu-filter custom-face-menu
2384                                                       widget)
2385                                   event)))
2386       (if answer
2387           (funcall answer widget)))))
2388
2389 (defun custom-face-set (widget)
2390   "Make the face attributes in WIDGET take effect."
2391   (let* ((symbol (widget-value widget))
2392          (child (car (widget-get widget :children)))
2393          (value (widget-value child)))
2394     (put symbol 'customized-face value)
2395     (face-spec-set symbol value)
2396     (custom-face-state-set widget)
2397     (custom-redraw-magic widget)))
2398
2399 (defun custom-face-save (widget)
2400   "Make the face attributes in WIDGET default."
2401   (let* ((symbol (widget-value widget))
2402          (child (car (widget-get widget :children)))
2403          (value (widget-value child)))
2404     (face-spec-set symbol value)
2405     (put symbol 'saved-face value)
2406     (put symbol 'customized-face nil)
2407     (custom-save-all)
2408     (custom-face-state-set widget)
2409     (custom-redraw-magic widget)))
2410
2411 (defun custom-face-reset-saved (widget)
2412   "Restore WIDGET to the face's default attributes."
2413   (let* ((symbol (widget-value widget))
2414          (child (car (widget-get widget :children)))
2415          (value (get symbol 'saved-face)))
2416     (unless value
2417       (signal 'error (list "No saved value for this face" symbol)))
2418     (put symbol 'customized-face nil)
2419     (face-spec-set symbol value)
2420     (widget-value-set child value)
2421     (custom-face-state-set widget)
2422     (custom-redraw-magic widget)))
2423
2424 (defun custom-face-reset-standard (widget)
2425   "Restore WIDGET to the face's standard settings."
2426   (let* ((symbol (widget-value widget))
2427          (child (car (widget-get widget :children)))
2428          (value (get symbol 'face-defface-spec)))
2429     (unless value
2430       (signal 'error (list "No standard setting for this face" symbol)))
2431     (put symbol 'customized-face nil)
2432     (when (get symbol 'saved-face)
2433       (put symbol 'saved-face nil)
2434       (custom-save-all))
2435     (face-spec-set symbol value)
2436     (widget-value-set child value)
2437     (custom-face-state-set widget)
2438     (custom-redraw-magic widget)))
2439
2440 ;;; The `face' Widget.
2441
2442 (define-widget 'face 'default
2443   "Select and customize a face."
2444   :convert-widget 'widget-value-convert-widget
2445   :button-prefix 'widget-push-button-prefix
2446   :button-suffix 'widget-push-button-suffix
2447   :format "%t: %[select face%] %v"
2448   :tag "Face"
2449   :value 'default
2450   :value-create 'widget-face-value-create
2451   :value-delete 'widget-face-value-delete
2452   :value-get 'widget-value-value-get
2453   :validate 'widget-children-validate
2454   :action 'widget-face-action
2455   :match (lambda (widget value) (symbolp value)))
2456
2457 (defun widget-face-value-create (widget)
2458   ;; Create a `custom-face' child.
2459   (let* ((symbol (widget-value widget))
2460          (custom-buffer-style 'face)
2461          (child (widget-create-child-and-convert
2462                  widget 'custom-face
2463                  :custom-level nil
2464                  :value symbol)))
2465     (custom-magic-reset child)
2466     (setq custom-options (cons child custom-options))
2467     (widget-put widget :children (list child))))
2468
2469 (defun widget-face-value-delete (widget)
2470   ;; Remove the child from the options.
2471   (let ((child (car (widget-get widget :children))))
2472     (setq custom-options (delq child custom-options))
2473     (widget-children-value-delete widget)))
2474
2475 (defvar face-history nil
2476   "History of entered face names.")
2477
2478 (defun widget-face-action (widget &optional event)
2479   "Prompt for a face."
2480   (let ((answer (completing-read "Face: "
2481                                  (mapcar (lambda (face)
2482                                            (list (symbol-name face)))
2483                                          (face-list))
2484                                  nil nil nil
2485                                  'face-history)))
2486     (unless (zerop (length answer))
2487       (widget-value-set widget (intern answer))
2488       (widget-apply widget :notify widget event)
2489       (widget-setup))))
2490
2491 ;;; The `hook' Widget.
2492
2493 (define-widget 'hook 'list
2494   "A emacs lisp hook"
2495   :value-to-internal (lambda (widget value)
2496                        (if (symbolp value)
2497                            (list value)
2498                          value))
2499   :match (lambda (widget value)
2500            (or (symbolp value)
2501                (widget-group-match widget value)))
2502   :convert-widget 'custom-hook-convert-widget
2503   :tag "Hook")
2504
2505 (defun custom-hook-convert-widget (widget)
2506   ;; Handle `:custom-options'.
2507   (let* ((options (widget-get widget :options))
2508          (other `(editable-list :inline t
2509                                 :entry-format "%i %d%v"
2510                                 (function :format " %v")))
2511          (args (if options
2512                    (list `(checklist :inline t
2513                                      ,@(mapcar (lambda (entry)
2514                                                  `(function-item ,entry))
2515                                                options))
2516                          other)
2517                  (list other))))
2518     (widget-put widget :args args)
2519     widget))
2520
2521 ;;; The `plist' Widget.
2522
2523 (define-widget 'plist 'list
2524   "A property list."
2525   :match (lambda (widget value)
2526            (valid-plist-p value))
2527   :convert-widget 'custom-plist-convert-widget
2528   :tag "Property List")
2529
2530 ;; #### Should handle options better.
2531 (defun custom-plist-convert-widget (widget)
2532   (let* ((options (widget-get widget :options))
2533          (other `(editable-list :inline t
2534                                 (group :inline t
2535                                        (symbol :format "%t: %v "
2536                                                :size 10
2537                                                :tag "Property")
2538                                        (sexp :tag "Value"))))
2539          (args
2540           (if options
2541               `((checklist :inline t
2542                            ,@(mapcar 'custom-plist-process-option options))
2543                 ,other)
2544             (list other))))
2545     (widget-put widget :args args)
2546     widget))
2547
2548 (defun custom-plist-process-option (entry)
2549   `(group :inline t
2550           (const :tag "Property"
2551                  :format "%t: %v "
2552                  :size 10
2553                  ,entry)
2554           (sexp :tag "Value")))
2555
2556 ;;; The `custom-group-link' Widget.
2557
2558 (define-widget 'custom-group-link 'link
2559   "Show parent in other window when activated."
2560   :help-echo 'custom-group-link-help-echo
2561   :action 'custom-group-link-action)
2562
2563 (defun custom-group-link-help-echo (widget)
2564   (concat "Create customization buffer for the `"
2565           (custom-unlispify-tag-name (widget-value widget))
2566           "' group"))
2567
2568 (defun custom-group-link-action (widget &rest ignore)
2569   (customize-group (widget-value widget)))
2570
2571 ;;; The `custom-group' Widget.
2572
2573 (defcustom custom-group-tag-faces nil
2574   ;; In XEmacs, this ought to play games with font size.
2575   "Face used for group tags.
2576 The first member is used for level 1 groups, the second for level 2,
2577 and so forth.  The remaining group tags are shown with
2578 `custom-group-tag-face'."
2579   :type '(repeat face)
2580   :group 'custom-faces)
2581
2582 (defface custom-group-tag-face-1 '((((class color)
2583                                      (background dark))
2584                                     (:foreground "pink" :underline t))
2585                                    (((class color)
2586                                      (background light))
2587                                     (:foreground "red" :underline t))
2588                                    (t (:underline t)))
2589   "Face used for group tags.")
2590
2591 (defface custom-group-tag-face '((((class color)
2592                                    (background dark))
2593                                   (:foreground "light blue" :underline t))
2594                                  (((class color)
2595                                    (background light))
2596                                   (:foreground "blue" :underline t))
2597                                  (t (:underline t)))
2598   "Face used for low level group tags."
2599   :group 'custom-faces)
2600
2601 (define-widget 'custom-group 'custom
2602   "Customize group."
2603   :format "%v"
2604   :sample-face-get 'custom-group-sample-face-get
2605   :documentation-property 'group-documentation
2606   :help-echo "Set or reset all members of this group"
2607   :value-create 'custom-group-value-create
2608   :action 'custom-group-action
2609   :custom-category 'group
2610   :custom-set 'custom-group-set
2611   :custom-save 'custom-group-save
2612   :custom-reset-current 'custom-group-reset-current
2613   :custom-reset-saved 'custom-group-reset-saved
2614   :custom-reset-standard 'custom-group-reset-standard
2615   :custom-menu 'custom-group-menu-create)
2616
2617 (defun custom-group-sample-face-get (widget)
2618   ;; Use :sample-face.
2619   (or (nth (1- (widget-get widget :custom-level)) custom-group-tag-faces)
2620       'custom-group-tag-face))
2621
2622 (define-widget 'custom-group-visibility 'visibility
2623   "An indicator and manipulator for hidden group contents."
2624   :create 'custom-group-visibility-create)
2625
2626 (defun custom-group-visibility-create (widget)
2627   (let ((visible (widget-value widget)))
2628     (if visible
2629         (insert "--------")))
2630   (widget-default-create widget))
2631
2632 (defun custom-group-members (symbol groups-only)
2633   "Return SYMBOL's custom group members.
2634 If GROUPS-ONLY non-nil, return only those members that are groups."
2635   (if (not groups-only)
2636       (get symbol 'custom-group)
2637     (let (members)
2638       (dolist (entry (get symbol 'custom-group) (nreverse members))
2639         (when (eq (nth 1 entry) 'custom-group)
2640           (push entry members))))))
2641
2642 (defun custom-group-value-create (widget)
2643   "Insert a customize group for WIDGET in the current buffer."
2644   (let* ((state (widget-get widget :custom-state))
2645          (level (widget-get widget :custom-level))
2646          ;; (indent (widget-get widget :indent))
2647          (prefix (widget-get widget :custom-prefix))
2648          (buttons (widget-get widget :buttons))
2649          (tag (widget-get widget :tag))
2650          (symbol (widget-value widget))
2651          (members (custom-group-members symbol
2652                                         (and (eq custom-buffer-style 'tree)
2653                                              custom-browse-only-groups))))
2654     (cond ((and (eq custom-buffer-style 'tree)
2655                 (eq state 'hidden)
2656                 (or members (custom-unloaded-widget-p widget)))
2657            (custom-browse-insert-prefix prefix)
2658            (push (widget-create-child-and-convert
2659                   widget 'custom-browse-visibility
2660                   ;; :tag-glyph "plus"
2661                   :tag "+")
2662                  buttons)
2663            (insert "-- ")
2664            ;; (widget-glyph-insert nil "-- " "horizontal")
2665            (push (widget-create-child-and-convert
2666                   widget 'custom-browse-group-tag)
2667                  buttons)
2668            (insert " " tag "\n")
2669            (widget-put widget :buttons buttons))
2670           ((and (eq custom-buffer-style 'tree)
2671                 (zerop (length members)))
2672            (custom-browse-insert-prefix prefix)
2673            (insert "[ ]-- ")
2674            ;; (widget-glyph-insert nil "[ ]" "empty")
2675            ;; (widget-glyph-insert nil "-- " "horizontal")
2676            (push (widget-create-child-and-convert
2677                   widget 'custom-browse-group-tag)
2678                  buttons)
2679            (insert " " tag "\n")
2680            (widget-put widget :buttons buttons))
2681           ((eq custom-buffer-style 'tree)
2682            (custom-browse-insert-prefix prefix)
2683            (custom-load-widget widget)
2684            (if (zerop (length members))
2685                (progn
2686                  (custom-browse-insert-prefix prefix)
2687                  (insert "[ ]-- ")
2688                  ;; (widget-glyph-insert nil "[ ]" "empty")
2689                  ;; (widget-glyph-insert nil "-- " "horizontal")
2690                  (push (widget-create-child-and-convert
2691                         widget 'custom-browse-group-tag)
2692                        buttons)
2693                  (insert " " tag "\n")
2694                  (widget-put widget :buttons buttons))
2695              (push (widget-create-child-and-convert
2696                     widget 'custom-browse-visibility
2697                     ;; :tag-glyph "minus"
2698                     :tag "-")
2699                    buttons)
2700              (insert "-\\ ")
2701              ;; (widget-glyph-insert nil "-\\ " "top")
2702              (push (widget-create-child-and-convert
2703                     widget 'custom-browse-group-tag)
2704                    buttons)
2705              (insert " " tag "\n")
2706              (widget-put widget :buttons buttons)
2707              (message "Creating group...")
2708              (let* ((members (custom-sort-items members
2709                               custom-browse-sort-alphabetically
2710                               custom-browse-order-groups))
2711                     (prefixes (widget-get widget :custom-prefixes))
2712                     (custom-prefix-list (custom-prefix-add symbol prefixes))
2713                     (extra-prefix (if (widget-get widget :custom-last)
2714                                       "   "
2715                                     " | "))
2716                     (prefix (concat prefix extra-prefix))
2717                     children entry)
2718                (while members
2719                  (setq entry (car members)
2720                        members (cdr members))
2721                  (push (widget-create-child-and-convert
2722                         widget (nth 1 entry)
2723                         :group widget
2724                         :tag (custom-unlispify-tag-name (nth 0 entry))
2725                         :custom-prefixes custom-prefix-list
2726                         :custom-level (1+ level)
2727                         :custom-last (null members)
2728                         :value (nth 0 entry)
2729                         :custom-prefix prefix)
2730                        children))
2731                (widget-put widget :children (reverse children)))
2732              (message "Creating group...done")))
2733           ;; Nested style.
2734           ((eq state 'hidden)
2735            ;; Create level indicator.
2736            (unless (eq custom-buffer-style 'links)
2737              (insert-char ?\  (* custom-buffer-indent (1- level)))
2738              (insert "-- "))
2739            ;; Create link indicator.
2740            (when (eq custom-buffer-style 'links)
2741              (insert " ")
2742              (push (widget-create-child-and-convert
2743                     widget 'custom-group-link
2744                     :tag "Open"
2745                     :tag-glyph '("open-up" "open-down")
2746                     symbol)
2747                    buttons)
2748              (insert " "))
2749            ;; Create tag.
2750            (let ((begin (point)))
2751              (insert tag)
2752              (widget-specify-sample widget begin (point)))
2753            (insert " group")
2754            ;; Create visibility indicator.
2755            (unless (eq custom-buffer-style 'links)
2756              (insert ": ")
2757              (push (widget-create-child-and-convert
2758                     widget 'custom-group-visibility
2759                     :help-echo "Show members of this group"
2760                     :action 'custom-toggle-parent
2761                     (not (eq state 'hidden)))
2762                    buttons))
2763            (insert " \n")
2764            ;; Create magic button.
2765            (let ((magic (widget-create-child-and-convert
2766                          widget 'custom-magic nil)))
2767              (widget-put widget :custom-magic magic)
2768              (push magic buttons))
2769            ;; Update buttons.
2770            (widget-put widget :buttons buttons)
2771            ;; Insert documentation.
2772            (if (and (eq custom-buffer-style 'links) (> level 1))
2773                (widget-put widget :documentation-indent 0))
2774            (widget-default-format-handler widget ?h))
2775           ;; Nested style.
2776           (t                            ;Visible.
2777            (custom-load-widget widget)
2778            ;; Update members
2779            (setq members (custom-group-members
2780                           symbol (and (eq custom-buffer-style 'tree)
2781                                       custom-browse-only-groups)))
2782            ;; Add parent groups references above the group.
2783            (if t    ;;; This should test that the buffer
2784                     ;;; was made to display a group.
2785                (when (eq level 1)
2786                  (if (custom-add-parent-links widget
2787                                               "Go to parent group:")
2788                      (insert "\n"))))
2789            ;; Create level indicator.
2790            (insert-char ?\  (* custom-buffer-indent (1- level)))
2791            (insert "/- ")
2792            ;; Create tag.
2793            (let ((start (point)))
2794              (insert tag)
2795              (widget-specify-sample widget start (point)))
2796            (insert " group: ")
2797            ;; Create visibility indicator.
2798            (unless (eq custom-buffer-style 'links)
2799              (insert "--------")
2800              (push (widget-create-child-and-convert
2801                     widget 'visibility
2802                     :help-echo "Hide members of this group"
2803                     :action 'custom-toggle-parent
2804                     (not (eq state 'hidden)))
2805                    buttons)
2806              (insert " "))
2807            ;; Create more dashes.
2808            ;; Use 76 instead of 75 to compensate for the temporary "<"
2809            ;; added by `widget-insert'.
2810            (insert-char ?- (- 76 (current-column)
2811                               (* custom-buffer-indent level)))
2812            (insert "\\\n")
2813            ;; Create magic button.
2814            (let ((magic (widget-create-child-and-convert
2815                          widget 'custom-magic
2816                          :indent 0
2817                          nil)))
2818              (widget-put widget :custom-magic magic)
2819              (push magic buttons))
2820            ;; Update buttons.
2821            (widget-put widget :buttons buttons)
2822            ;; Insert documentation.
2823            (widget-default-format-handler widget ?h)
2824            ;; Parent groups.
2825            (if nil  ;;; This should test that the buffer
2826                     ;;; was not made to display a group.
2827                (when (eq level 1)
2828                  (insert-char ?\  custom-buffer-indent)
2829                  (custom-add-parent-links widget)))
2830            (custom-add-see-also widget
2831                                 (make-string (* custom-buffer-indent level)
2832                                              ?\ ))
2833            ;; Members.
2834            (message "Creating group...")
2835            (let* ((members (custom-sort-items members
2836                                               custom-buffer-sort-alphabetically
2837                                               custom-buffer-order-groups))
2838                   (prefixes (widget-get widget :custom-prefixes))
2839                   (custom-prefix-list (custom-prefix-add symbol prefixes))
2840                   (length (length members))
2841                   (count 0)
2842                   (children (mapcar
2843                              (lambda (entry)
2844                                (widget-insert "\n")
2845                                (when (zerop (% count custom-skip-messages))
2846                                  (display-message
2847                                   'progress
2848                                   (format "\
2849 Creating group members... %2d%%"
2850                                           (/ (* 100.0 count) length))))
2851                                (incf count)
2852                                (prog1
2853                                    (widget-create-child-and-convert
2854                                     widget (nth 1 entry)
2855                                     :group widget
2856                                     :tag (custom-unlispify-tag-name
2857                                           (nth 0 entry))
2858                                     :custom-prefixes custom-prefix-list
2859                                     :custom-level (1+ level)
2860                                     :value (nth 0 entry))
2861                                  (unless (eq (preceding-char) ?\n)
2862                                    (widget-insert "\n"))))
2863                              members)))
2864              (message "Creating group magic...")
2865              (mapc 'custom-magic-reset children)
2866              (message "Creating group state...")
2867              (widget-put widget :children children)
2868              (custom-group-state-update widget)
2869              (message "Creating group... done"))
2870            ;; End line
2871            (insert "\n")
2872            (insert-char ?\  (* custom-buffer-indent (1- level)))
2873            (insert "\\- " (widget-get widget :tag) " group end ")
2874            (insert-char ?- (- 75 (current-column) (* custom-buffer-indent level)))
2875            (insert "/\n")))))
2876
2877 (defvar custom-group-menu
2878   '(("Set for Current Session" custom-group-set
2879      (lambda (widget)
2880        (eq (widget-get widget :custom-state) 'modified)))
2881     ("Save for Future Sessions" custom-group-save
2882      (lambda (widget)
2883        (memq (widget-get widget :custom-state) '(modified set))))
2884     ("Reset to Current" custom-group-reset-current
2885      (lambda (widget)
2886        (memq (widget-get widget :custom-state) '(modified))))
2887     ("Reset to Saved" custom-group-reset-saved
2888      (lambda (widget)
2889        (memq (widget-get widget :custom-state) '(modified set))))
2890     ("Reset to standard setting" custom-group-reset-standard
2891      (lambda (widget)
2892        (memq (widget-get widget :custom-state) '(modified set saved)))))
2893   "Alist of actions for the `custom-group' widget.
2894 Each entry has the form (NAME ACTION FILTER) where NAME is the name of
2895 the menu entry, ACTION is the function to call on the widget when the
2896 menu is selected, and FILTER is a predicate which takes a `custom-group'
2897 widget as an argument, and returns non-nil if ACTION is valid on that
2898 widget. If FILTER is nil, ACTION is always valid.")
2899
2900 (defun custom-group-action (widget &optional event)
2901   "Show the menu for `custom-group' WIDGET.
2902 Optional EVENT is the location for the menu."
2903   (if (eq (widget-get widget :custom-state) 'hidden)
2904       (custom-toggle-hide widget)
2905     (let* ((completion-ignore-case t)
2906            (answer (widget-choose (concat "Operation on "
2907                                           (custom-unlispify-tag-name
2908                                            (widget-get widget :value)))
2909                                   (custom-menu-filter custom-group-menu
2910                                                       widget)
2911                                   event)))
2912       (if answer
2913           (funcall answer widget)))))
2914
2915 (defun custom-group-set (widget)
2916   "Set changes in all modified group members."
2917   (let ((children (widget-get widget :children)))
2918     (mapc (lambda (child)
2919             (when (eq (widget-get child :custom-state) 'modified)
2920               (widget-apply child :custom-set)))
2921           children)))
2922
2923 (defun custom-group-save (widget)
2924   "Save all modified group members."
2925   (let ((children (widget-get widget :children)))
2926     (mapc (lambda (child)
2927             (when (memq (widget-get child :custom-state) '(modified set))
2928               (widget-apply child :custom-save)))
2929           children)))
2930
2931 (defun custom-group-reset-current (widget)
2932   "Reset all modified group members."
2933   (let ((children (widget-get widget :children)))
2934     (mapc (lambda (child)
2935             (when (eq (widget-get child :custom-state) 'modified)
2936               (widget-apply child :custom-reset-current)))
2937           children)))
2938
2939 (defun custom-group-reset-saved (widget)
2940   "Reset all modified or set group members."
2941   (let ((children (widget-get widget :children)))
2942     (mapc (lambda (child)
2943             (when (memq (widget-get child :custom-state) '(modified set))
2944               (widget-apply child :custom-reset-saved)))
2945           children)))
2946
2947 (defun custom-group-reset-standard (widget)
2948   "Reset all modified, set, or saved group members."
2949   (let ((children (widget-get widget :children)))
2950     (mapc (lambda (child)
2951             (when (memq (widget-get child :custom-state)
2952                         '(modified set saved))
2953               (widget-apply child :custom-reset-standard)))
2954           children)))
2955
2956 (defun custom-group-state-update (widget)
2957   "Update magic."
2958   (unless (eq (widget-get widget :custom-state) 'hidden)
2959     (let* ((children (widget-get widget :children))
2960            (states (mapcar (lambda (child)
2961                              (widget-get child :custom-state))
2962                            children))
2963            (magics custom-magic-alist)
2964            (found 'standard))
2965       (while magics
2966         (let ((magic (car (car magics))))
2967           (if (and (not (eq magic 'hidden))
2968                    (memq magic states))
2969               (setq found magic
2970                     magics nil)
2971             (setq magics (cdr magics)))))
2972       (widget-put widget :custom-state found)))
2973   (custom-magic-reset widget))
2974
2975 ;;; The `custom-save-all' Function.
2976 ;;;###autoload
2977 (defcustom custom-file "~/.emacs"
2978   "File used for storing customization information.
2979 If you change this from the default \"~/.emacs\" you need to
2980 explicitly load that file for the settings to take effect."
2981   :type 'file
2982   :group 'customize)
2983
2984 (defun custom-save-delete (symbol)
2985   "Delete the call to SYMBOL form `custom-file'.
2986 Leave point at the location of the call, or after the last expression."
2987   (let ((find-file-hooks nil)
2988         (auto-mode-alist nil))
2989     (set-buffer (find-file-noselect custom-file)))
2990   (goto-char (point-min))
2991   (catch 'found
2992     (while t
2993       (let ((sexp (condition-case nil
2994                       (read (current-buffer))
2995                     (end-of-file (throw 'found nil)))))
2996         (when (and (listp sexp)
2997                    (eq (car sexp) symbol))
2998           (delete-region (save-excursion
2999                            (backward-sexp)
3000                            (point))
3001                          (point))
3002           (throw 'found nil))))))
3003
3004 (defun custom-save-variables ()
3005   "Save all customized variables in `custom-file'."
3006   (save-excursion
3007     (custom-save-delete 'custom-set-variables)
3008     (let ((standard-output (current-buffer)))
3009       (unless (bolp)
3010         (princ "\n"))
3011       (princ "(custom-set-variables")
3012       (mapatoms (lambda (symbol)
3013                   (let ((value (get symbol 'saved-value))
3014                         (requests (get symbol 'custom-requests))
3015                         (now (not (or (get symbol 'standard-value)
3016                                       (and (not (boundp symbol))
3017                                            (not (get symbol 'force-value)))))))
3018                     (when value
3019                       (princ "\n '(")
3020                       (prin1 symbol)
3021                       (princ " ")
3022                       (prin1 (car value))
3023                       (cond (requests
3024                              (if now
3025                                  (princ " t ")
3026                                (princ " nil "))
3027                              (prin1 requests)
3028                              (princ ")"))
3029                             (now
3030                              (princ " t)"))
3031                             (t
3032                              (princ ")")))))))
3033       (princ ")")
3034       (unless (looking-at "\n")
3035         (princ "\n")))))
3036
3037 (defun custom-save-faces ()
3038   "Save all customized faces in `custom-file'."
3039   (save-excursion
3040     (custom-save-delete 'custom-set-faces)
3041     (let ((standard-output (current-buffer)))
3042       (unless (bolp)
3043         (princ "\n"))
3044       (princ "(custom-set-faces")
3045       (let ((value (get 'default 'saved-face)))
3046         ;; The default face must be first, since it affects the others.
3047         (when value
3048           (princ "\n '(default ")
3049           (prin1 value)
3050           (if (or (get 'default 'face-defface-spec)
3051                   (and (not (find-face 'default))
3052                        (not (get 'default 'force-face))))
3053               (princ ")")
3054             (princ " t)"))))
3055       (mapatoms (lambda (symbol)
3056                   (let ((value (get symbol 'saved-face)))
3057                     (when (and (not (eq symbol 'default))
3058                                ;; Don't print default face here.
3059                                value)
3060                       (princ "\n '(")
3061                       (prin1 symbol)
3062                       (princ " ")
3063                       (prin1 value)
3064                       (if (or (get symbol 'face-defface-spec)
3065                               (and (not (find-face symbol))
3066                                    (not (get symbol 'force-face))))
3067                           (princ ")")
3068                         (princ " t)"))))))
3069       (princ ")")
3070       (unless (looking-at "\n")
3071         (princ "\n")))))
3072
3073 ;;;###autoload
3074 (defun customize-save-customized ()
3075   "Save all user options which have been set in this session."
3076   (interactive)
3077   (mapatoms (lambda (symbol)
3078               (let ((face (get symbol 'customized-face))
3079                     (value (get symbol 'customized-value)))
3080                 (when face
3081                   (put symbol 'saved-face face)
3082                   (put symbol 'customized-face nil))
3083                 (when value
3084                   (put symbol 'saved-value value)
3085                   (put symbol 'customized-value nil)))))
3086   ;; We really should update all custom buffers here.
3087   (custom-save-all))
3088
3089 ;;;###autoload
3090 (defun custom-save-all ()
3091   "Save all customizations in `custom-file'."
3092   (let ((inhibit-read-only t))
3093     (custom-save-variables)
3094     (custom-save-faces)
3095     (let ((find-file-hooks nil)
3096           (auto-mode-alist))
3097       (with-current-buffer (find-file-noselect custom-file)
3098         (save-buffer)))))
3099
3100 \f
3101 ;;; The Customize Menu.
3102
3103 ;;; Menu support
3104
3105 (defun custom-face-menu-create (widget symbol)
3106   "Ignoring WIDGET, create a menu entry for customization face SYMBOL."
3107   (vector (custom-unlispify-menu-entry symbol)
3108           `(customize-face ',symbol)
3109           t))
3110
3111 (defun custom-variable-menu-create (widget symbol)
3112   "Ignoring WIDGET, create a menu entry for customization variable SYMBOL."
3113   (let ((type (get symbol 'custom-type)))
3114     (unless (listp type)
3115       (setq type (list type)))
3116     (if (and type (widget-get type :custom-menu))
3117         (widget-apply type :custom-menu symbol)
3118       (vector (custom-unlispify-menu-entry symbol)
3119               `(customize-variable ',symbol)
3120               t))))
3121
3122 ;; Add checkboxes to boolean variable entries.
3123 (widget-put (get 'boolean 'widget-type)
3124             :custom-menu (lambda (widget symbol)
3125                            `[,(custom-unlispify-menu-entry symbol)
3126                              (customize-variable ',symbol)
3127                              :style toggle
3128                              :selected ,symbol]))
3129
3130 ;; XEmacs can create menus dynamically.
3131 (defun custom-group-menu-create (widget symbol)
3132   "Ignoring WIDGET, create a menu entry for customization group SYMBOL."
3133   `( ,(custom-unlispify-menu-entry symbol t)
3134      :filter (lambda (&rest junk)
3135                (let ((item (custom-menu-create ',symbol)))
3136                  (if (listp item)
3137                      (cdr item)
3138                    (list item))))))
3139
3140 ;;;###autoload
3141 (defun custom-menu-create (symbol)
3142   "Create menu for customization group SYMBOL.
3143 The menu is in a format applicable to `easy-menu-define'."
3144   (let* ((item (vector (custom-unlispify-menu-entry symbol)
3145                        `(customize-group ',symbol)
3146                        t)))
3147     ;; Item is the entry for creating a menu buffer for SYMBOL.
3148     ;; We may nest, if the menu is not too big.
3149     (custom-load-symbol symbol)
3150     (if (< (length (get symbol 'custom-group)) widget-menu-max-size)
3151         ;; The menu is not too big.
3152         (let ((custom-prefix-list (custom-prefix-add symbol
3153                                                      custom-prefix-list))
3154               (members (custom-sort-items (get symbol 'custom-group)
3155                                           custom-menu-sort-alphabetically
3156                                           custom-menu-order-groups)))
3157           ;; Create the menu.
3158           `(,(custom-unlispify-menu-entry symbol t)
3159             ,item
3160             "--"
3161             ,@(mapcar (lambda (entry)
3162                         (widget-apply (if (listp (nth 1 entry))
3163                                           (nth 1 entry)
3164                                         (list (nth 1 entry)))
3165                                       :custom-menu (nth 0 entry)))
3166                       members)))
3167       ;; The menu was too big.
3168       item)))
3169
3170 ;;;###autoload
3171 (defun customize-menu-create (symbol &optional name)
3172   "Return a customize menu for customization group SYMBOL.
3173 If optional NAME is given, use that as the name of the menu.
3174 Otherwise the menu will be named `Customize'.
3175 The format is suitable for use with `easy-menu-define'."
3176   (unless name
3177     (setq name "Customize"))
3178   `(,name
3179     :filter (lambda (&rest junk)
3180               (cdr (custom-menu-create ',symbol)))))
3181
3182 ;;; The Custom Mode.
3183
3184 (defvar custom-mode-map nil
3185   "Keymap for `custom-mode'.")
3186
3187 (unless custom-mode-map
3188   (setq custom-mode-map (make-sparse-keymap))
3189   (set-keymap-parents custom-mode-map widget-keymap)
3190   (suppress-keymap custom-mode-map)
3191   (define-key custom-mode-map " " 'scroll-up)
3192   (define-key custom-mode-map [delete] 'scroll-down)
3193   (define-key custom-mode-map "q" 'Custom-buffer-done)
3194   (define-key custom-mode-map "u" 'Custom-goto-parent)
3195   (define-key custom-mode-map "n" 'widget-forward)
3196   (define-key custom-mode-map "p" 'widget-backward))
3197
3198 (easy-menu-define Custom-mode-menu
3199     custom-mode-map
3200   "Menu used in customization buffers."
3201   `("Custom"
3202     ,(customize-menu-create 'customize)
3203     ["Set" Custom-set t]
3204     ["Save" Custom-save t]
3205     ["Reset to Current" Custom-reset-current t]
3206     ["Reset to Saved" Custom-reset-saved t]
3207     ["Reset to Standard Settings" Custom-reset-standard t]
3208     ["Info" (Info-goto-node "(xemacs)Easy Customization") t]))
3209
3210 (defun Custom-goto-parent ()
3211   "Go to the parent group listed at the top of this buffer.
3212 If several parents are listed, go to the first of them."
3213   (interactive)
3214   (save-excursion
3215     (goto-char (point-min))
3216     (if (search-forward "\nGo to parent group: " nil t)
3217         (let* ((button (get-char-property (point) 'button))
3218                (parent (downcase (widget-get  button :tag))))
3219           (customize-group parent)))))
3220
3221 (defcustom custom-mode-hook nil
3222   "Hook called when entering custom-mode."
3223   :type 'hook
3224   :group 'custom-buffer )
3225
3226 (defun custom-state-buffer-message (widget)
3227   (if (eq (widget-get (widget-get widget :parent) :custom-state) 'modified)
3228       (message
3229        "To install your edits, invoke [State] and choose the Set operation")))
3230
3231 (defun custom-mode ()
3232   "Major mode for editing customization buffers.
3233
3234 The following commands are available:
3235
3236 Move to next button or editable field.     \\[widget-forward]
3237 Move to previous button or editable field. \\[widget-backward]
3238 \\<widget-field-keymap>\
3239 Complete content of editable text field.   \\[widget-complete]
3240 \\<custom-mode-map>\
3241 Invoke button under point.                 \\[widget-button-press]
3242 Set all modifications.                     \\[Custom-set]
3243 Make all modifications default.            \\[Custom-save]
3244 Reset all modified options.                \\[Custom-reset-current]
3245 Reset all modified or set options.         \\[Custom-reset-saved]
3246 Reset all options.                         \\[Custom-reset-standard]
3247
3248 Entry to this mode calls the value of `custom-mode-hook'
3249 if that value is non-nil."
3250   (kill-all-local-variables)
3251   (setq major-mode 'custom-mode
3252         mode-name "Custom")
3253   (use-local-map custom-mode-map)
3254   (easy-menu-add Custom-mode-menu)
3255   (make-local-variable 'custom-options)
3256   (make-local-variable 'widget-documentation-face)
3257   (setq widget-documentation-face 'custom-documentation-face)
3258   (make-local-variable 'widget-button-face)
3259   (setq widget-button-face 'custom-button-face)
3260   (make-local-hook 'widget-edit-functions)
3261   (add-hook 'widget-edit-functions 'custom-state-buffer-message nil t)
3262   (run-hooks 'custom-mode-hook))
3263
3264 \f
3265 ;;; The End.
3266
3267 (provide 'cus-edit)
3268
3269 ;; cus-edit.el ends here