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