cgit.sxemacs.org Git - gnus/blob - lisp/cus-edit.el

   1 ;;; cus-edit.el --- Tools for customization Emacs.
   2 ;;
   3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
   6 ;; Keywords: help, faces
   7 ;; Version: 1.82
   8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
   9
  10 ;;; Commentary:
  11 ;;
  12 ;; See `custom.el'.
  13
  14 ;;; Code:
  15
  16 (require 'cus-face)
  17 (require 'wid-edit)
  18 (require 'easymenu)
  19
  20 (define-widget-keywords :custom-prefixes :custom-menu :custom-show
  21   :custom-magic :custom-state :custom-level :custom-form
  22   :custom-set :custom-save :custom-reset-current :custom-reset-saved
  23   :custom-reset-factory)
  24
  25 (put 'custom-define-hook 'custom-type 'hook)
  26 (put 'custom-define-hook 'factory-value '(nil))
  27 (custom-add-to-group 'customize 'custom-define-hook 'custom-variable)
  28
  29 ;;; Customization Groups.
  30
  31 (defgroup emacs nil
  32   "Customization of the One True Editor."
  33   :link '(custom-manual "(emacs)Top"))
  34
  35 ;; Most of these groups are stolen from `finder.el',
  36 (defgroup editing nil
  37   "Basic text editing facilities."
  38   :group 'emacs)
  39
  40 (defgroup abbrev nil
  41   "Abbreviation handling, typing shortcuts, macros."
  42   :tag "Abbreviations"
  43   :group 'editing)
  44
  45 (defgroup matching nil
  46   "Various sorts of searching and matching."
  47   :group 'editing)
  48
  49 (defgroup emulations nil
  50   "Emulations of other editors."
  51   :group 'editing)
  52
  53 (defgroup mouse nil
  54   "Mouse support."
  55   :group 'editing)
  56
  57 (defgroup outlines nil
  58   "Support for hierarchical outlining."
  59   :group 'editing)
  60
  61 (defgroup external nil
  62   "Interfacing to external utilities."
  63   :group 'emacs)
  64
  65 (defgroup bib nil
  66   "Code related to the `bib' bibliography processor."
  67   :tag "Bibliography"
  68   :group 'external)
  69
  70 (defgroup processes nil
  71   "Process, subshell, compilation, and job control support."
  72   :group 'external
  73   :group 'development)
  74
  75 (defgroup programming nil
  76   "Support for programming in other languages."
  77   :group 'emacs)
  78
  79 (defgroup languages nil
  80   "Specialized modes for editing programming languages."
  81   :group 'programming)
  82
  83 (defgroup lisp nil
  84   "Lisp support, including Emacs Lisp."
  85   :group 'languages
  86   :group 'development)
  87
  88 (defgroup c nil
  89   "Support for the C language and related languages."
  90   :group 'languages)
  91
  92 (defgroup tools nil
  93   "Programming tools."
  94   :group 'programming)
  95
  96 (defgroup oop nil
  97   "Support for object-oriented programming."
  98   :group 'programming)
  99
 100 (defgroup applications nil
 101   "Applications written in Emacs."
 102   :group 'emacs)
 103
 104 (defgroup calendar nil
 105   "Calendar and time management support."
 106   :group 'applications)
 107
 108 (defgroup mail nil
 109   "Modes for electronic-mail handling."
 110   :group 'applications)
 111
 112 (defgroup news nil
 113   "Support for netnews reading and posting."
 114   :group 'applications)
 115
 116 (defgroup games nil
 117   "Games, jokes and amusements."
 118   :group 'applications)
 119
 120 (defgroup development nil
 121   "Support for further development of Emacs."
 122   :group 'emacs)
 123
 124 (defgroup docs nil
 125   "Support for Emacs documentation."
 126   :group 'development)
 127
 128 (defgroup extensions nil
 129   "Emacs Lisp language extensions."
 130   :group 'development)
 131
 132 (defgroup internal nil
 133   "Code for Emacs internals, build process, defaults."
 134   :group 'development)
 135
 136 (defgroup maint nil
 137   "Maintenance aids for the Emacs development group."
 138   :tag "Maintenance"
 139   :group 'development)
 140
 141 (defgroup environment nil
 142   "Fitting Emacs with its environment."
 143   :group 'emacs)
 144
 145 (defgroup comm nil
 146   "Communications, networking, remote access to files."
 147   :tag "Communication"
 148   :group 'environment)
 149
 150 (defgroup hardware nil
 151   "Support for interfacing with exotic hardware."
 152   :group 'environment)
 153
 154 (defgroup terminals nil
 155   "Support for terminal types."
 156   :group 'environment)
 157
 158 (defgroup unix nil
 159   "Front-ends/assistants for, or emulators of, UNIX features."
 160   :group 'environment)
 161
 162 (defgroup vms nil
 163   "Support code for vms."
 164   :group 'environment)
 165
 166 (defgroup i18n nil
 167   "Internationalization and alternate character-set support."
 168   :group 'environment
 169   :group 'editing)
 170
 171 (defgroup frames nil
 172   "Support for Emacs frames and window systems."
 173   :group 'environment)
 174
 175 (defgroup data nil
 176   "Support editing files of data."
 177   :group 'emacs)
 178
 179 (defgroup wp nil
 180   "Word processing."
 181   :group 'emacs)
 182
 183 (defgroup tex nil
 184   "Code related to the TeX formatter."
 185   :group 'wp)
 186
 187 (defgroup faces nil
 188   "Support for multiple fonts."
 189   :group 'emacs)
 190
 191 (defgroup hypermedia nil
 192   "Support for links between text or other media types."
 193   :group 'emacs)
 194
 195 (defgroup help nil
 196   "Support for on-line help systems."
 197   :group 'emacs)
 198
 199 (defgroup local nil
 200   "Code local to your site."
 201   :group 'emacs)
 202
 203 (defgroup customize '((widgets custom-group))
 204   "Customization of the Customization support."
 205   :link '(custom-manual "(custom)Top")
 206   :link '(url-link :tag "Development Page"
 207                    "http://www.dina.kvl.dk/~abraham/custom/")
 208   :prefix "custom-"
 209   :group 'help)
 210
 211 (defgroup custom-faces nil
 212   "Faces used by customize."
 213   :group 'customize
 214   :group 'faces)
 215
 216 ;;; Utilities.
 217
 218 (defun custom-quote (sexp)
 219   "Quote SEXP iff it is not self quoting."
 220   (if (or (memq sexp '(t nil))
 221           (and (symbolp sexp)
 222                (eq (aref (symbol-name sexp) 0) ?:))
 223           (and (listp sexp)
 224                (memq (car sexp) '(lambda)))
 225           (stringp sexp)
 226           (numberp sexp)
 227           (and (fboundp 'characterp)
 228                (characterp sexp)))
 229       sexp
 230     (list 'quote sexp)))
 231
 232 (defun custom-split-regexp-maybe (regexp)
 233   "If REGEXP is a string, split it to a list at `\\|'.
 234 You can get the original back with from the result with:
 235   (mapconcat 'identity result \"\\|\")
 236
 237 IF REGEXP is not a string, return it unchanged."
 238   (if (stringp regexp)
 239       (let ((start 0)
 240             all)
 241         (while (string-match "\\\\|" regexp start)
 242           (setq all (cons (substring regexp start (match-beginning 0)) all)
 243                 start (match-end 0)))
 244         (nreverse (cons (substring regexp start) all)))
 245     regexp))
 246
 247 (defun custom-variable-prompt ()
 248   ;; Code stolen from `help.el'.
 249   "Prompt for a variable, defaulting to the variable at point.
 250 Return a list suitable for use in `interactive'."
 251    (let ((v (variable-at-point))
 252          (enable-recursive-minibuffers t)
 253          val)
 254      (setq val (completing-read
 255                 (if v
 256                     (format "Customize variable (default %s): " v)
 257                   "Customize variable: ")
 258                 obarray 'boundp t))
 259      (list (if (equal val "")
 260                v (intern val)))))
 261
 262 ;;; Unlispify.
 263
 264 (defvar custom-prefix-list nil
 265   "List of prefixes that should be ignored by `custom-unlispify'")
 266
 267 (defcustom custom-unlispify-menu-entries t
 268   "Display menu entries as words instead of symbols if non nil."
 269   :group 'customize
 270   :type 'boolean)
 271
 272 (defun custom-unlispify-menu-entry (symbol &optional no-suffix)
 273   "Convert symbol into a menu entry."
 274   (cond ((not custom-unlispify-menu-entries)
 275          (symbol-name symbol))
 276         ((get symbol 'custom-tag)
 277          (if no-suffix
 278              (get symbol 'custom-tag)
 279            (concat (get symbol 'custom-tag) "...")))
 280         (t
 281          (save-excursion
 282            (set-buffer (get-buffer-create " *Custom-Work*"))
 283            (erase-buffer)
 284            (princ symbol (current-buffer))
 285            (goto-char (point-min))
 286            (when (and (eq (get symbol 'custom-type) 'boolean)
 287                       (re-search-forward "-p\\'" nil t))
 288              (replace-match "" t t)
 289              (goto-char (point-min)))
 290            (let ((prefixes custom-prefix-list)
 291                  prefix)
 292              (while prefixes
 293                (setq prefix (car prefixes))
 294                (if (search-forward prefix (+ (point) (length prefix)) t)
 295                    (progn
 296                      (setq prefixes nil)
 297                      (delete-region (point-min) (point)))
 298                  (setq prefixes (cdr prefixes)))))
 299            (subst-char-in-region (point-min) (point-max) ?- ?\  t)
 300            (capitalize-region (point-min) (point-max))
 301            (unless no-suffix
 302              (goto-char (point-max))
 303              (insert "..."))
 304            (buffer-string)))))
 305
 306 (defcustom custom-unlispify-tag-names t
 307   "Display tag names as words instead of symbols if non nil."
 308   :group 'customize
 309   :type 'boolean)
 310
 311 (defun custom-unlispify-tag-name (symbol)
 312   "Convert symbol into a menu entry."
 313   (let ((custom-unlispify-menu-entries custom-unlispify-tag-names))
 314     (custom-unlispify-menu-entry symbol t)))
 315
 316 (defun custom-prefix-add (symbol prefixes)
 317   ;; Addd SYMBOL to list of ignored PREFIXES.
 318   (cons (or (get symbol 'custom-prefix)
 319             (concat (symbol-name symbol) "-"))
 320         prefixes))
 321
 322 ;;; Guess.
 323
 324 (defcustom custom-guess-name-alist
 325   '(("-p\\'" boolean)
 326     ("-hook\\'" hook)
 327     ("-face\\'" face)
 328     ("-file\\'" file)
 329     ("-function\\'" function)
 330     ("-functions\\'" (repeat function))
 331     ("-list\\'" (repeat sexp))
 332     ("-alist\\'" (repeat (cons sexp sexp))))
 333   "Alist of (MATCH TYPE).
 334
 335 MATCH should be a regexp matching the name of a symbol, and TYPE should
 336 be a widget suitable for editing the value of that symbol.  The TYPE
 337 of the first entry where MATCH matches the name of the symbol will be
 338 used.
 339
 340 This is used for guessing the type of variables not declared with
 341 customize."
 342   :type '(repeat (group (regexp :tag "Match") (sexp :tag "Type")))
 343   :group 'customize)
 344
 345 (defcustom custom-guess-doc-alist
 346   '(("\\`\\*?Non-nil " boolean))
 347   "Alist of (MATCH TYPE).
 348
 349 MATCH should be a regexp matching a documentation string, and TYPE
 350 should be a widget suitable for editing the value of a variable with
 351 that documentation string.  The TYPE of the first entry where MATCH
 352 matches the name of the symbol will be used.
 353
 354 This is used for guessing the type of variables not declared with
 355 customize."
 356   :type '(repeat (group (regexp :tag "Match") (sexp :tag "Type")))
 357   :group 'customize)
 358
 359 (defun custom-guess-type (symbol)
 360   "Guess a widget suitable for editing the value of SYMBOL.
 361 This is done by matching SYMBOL with `custom-guess-name-alist' and
 362 if that fails, the doc string with `custom-guess-doc-alist'."
 363   (let ((name (symbol-name symbol))
 364         (names custom-guess-name-alist)
 365         current found)
 366     (while names
 367       (setq current (car names)
 368             names (cdr names))
 369       (when (string-match (nth 0 current) name)
 370         (setq found (nth 1 current)
 371               names nil)))
 372     (unless found
 373       (let ((doc (documentation-property symbol 'variable-documentation))
 374             (docs custom-guess-doc-alist))
 375         (when doc
 376           (while docs
 377             (setq current (car docs)
 378                   docs (cdr docs))
 379             (when (string-match (nth 0 current) doc)
 380               (setq found (nth 1 current)
 381                     docs nil))))))
 382     found))
 383
 384 ;;; Custom Mode Commands.
 385
 386 (defvar custom-options nil
 387   "Customization widgets in the current buffer.")
 388
 389 (defun custom-set ()
 390   "Set changes in all modified options."
 391   (interactive)
 392   (let ((children custom-options))
 393     (mapcar (lambda (child)
 394               (when (eq (widget-get child :custom-state) 'modified)
 395                 (widget-apply child :custom-set)))
 396             children)))
 397
 398 (defun custom-save ()
 399   "Set all modified group members and save them."
 400   (interactive)
 401   (let ((children custom-options))
 402     (mapcar (lambda (child)
 403               (when (memq (widget-get child :custom-state) '(modified set))
 404                 (widget-apply child :custom-save)))
 405             children))
 406   (custom-save-all))
 407
 408 (defvar custom-reset-menu
 409   '(("Current" . custom-reset-current)
 410     ("Saved" . custom-reset-saved)
 411     ("Factory Settings" . custom-reset-factory))
 412   "Alist of actions for the `Reset' button.
 413 The key is a string containing the name of the action, the value is a
 414 lisp function taking the widget as an element which will be called
 415 when the action is chosen.")
 416
 417 (defun custom-reset (event)
 418   "Select item from reset menu."
 419   (let* ((completion-ignore-case t)
 420          (answer (widget-choose "Reset to"
 421                                 custom-reset-menu
 422                                 event)))
 423     (if answer
 424         (funcall answer))))
 425
 426 (defun custom-reset-current ()
 427   "Reset all modified group members to their current value."
 428   (interactive)
 429   (let ((children custom-options))
 430     (mapcar (lambda (child)
 431               (when (eq (widget-get child :custom-state) 'modified)
 432                 (widget-apply child :custom-reset-current)))
 433             children)))
 434
 435 (defun custom-reset-saved ()
 436   "Reset all modified or set group members to their saved value."
 437   (interactive)
 438   (let ((children custom-options))
 439     (mapcar (lambda (child)
 440               (when (eq (widget-get child :custom-state) 'modified)
 441                 (widget-apply child :custom-reset-current)))
 442             children)))
 443
 444 (defun custom-reset-factory ()
 445   "Reset all modified, set, or saved group members to their factory settings."
 446   (interactive)
 447   (let ((children custom-options))
 448     (mapcar (lambda (child)
 449               (when (eq (widget-get child :custom-state) 'modified)
 450                 (widget-apply child :custom-reset-current)))
 451             children)))
 452
 453 ;;; The Customize Commands
 454
 455 ;;;###autoload
 456 (defun customize (symbol)
 457   "Customize SYMBOL, which must be a customization group."
 458   (interactive (list (completing-read "Customize group: (default emacs) "
 459                                       obarray
 460                                       (lambda (symbol)
 461                                         (get symbol 'custom-group))
 462                                       t)))
 463
 464   (when (stringp symbol)
 465     (if (string-equal "" symbol)
 466         (setq symbol 'emacs)
 467       (setq symbol (intern symbol))))
 468   (custom-buffer-create (list (list symbol 'custom-group))))
 469
 470 ;;;###autoload
 471 (defun customize-variable (symbol)
 472   "Customize SYMBOL, which must be a variable."
 473   (interactive (custom-variable-prompt))
 474   (custom-buffer-create (list (list symbol 'custom-variable))))
 475
 476 ;;;###autoload
 477 (defun customize-variable-other-window (symbol)
 478   "Customize SYMBOL, which must be a variable.
 479 Show the buffer in another window, but don't select it."
 480   (interactive (custom-variable-prompt))
 481   (custom-buffer-create-other-window (list (list symbol 'custom-variable))))
 482
 483 ;;;###autoload
 484 (defun customize-face (&optional symbol)
 485   "Customize SYMBOL, which should be a face name or nil.
 486 If SYMBOL is nil, customize all faces."
 487   (interactive (list (completing-read "Customize face: (default all) "
 488                                       obarray 'custom-facep)))
 489   (if (or (null symbol) (and (stringp symbol) (zerop (length symbol))))
 490       (let ((found nil))
 491         (message "Looking for faces...")
 492         (mapcar (lambda (symbol)
 493                   (setq found (cons (list symbol 'custom-face) found)))
 494                 (nreverse (mapcar 'intern
 495                                   (sort (mapcar 'symbol-name (face-list))
 496                                         'string<))))
 497
 498         (custom-buffer-create found))
 499     (if (stringp symbol)
 500         (setq symbol (intern symbol)))
 501     (unless (symbolp symbol)
 502       (error "Should be a symbol %S" symbol))
 503     (custom-buffer-create (list (list symbol 'custom-face)))))
 504
 505 ;;;###autoload
 506 (defun customize-face-other-window (&optional symbol)
 507   "Show customization buffer for FACE in other window."
 508   (interactive (list (completing-read "Customize face: "
 509                                       obarray 'custom-facep)))
 510   (if (or (null symbol) (and (stringp symbol) (zerop (length symbol))))
 511       ()
 512     (if (stringp symbol)
 513         (setq symbol (intern symbol)))
 514     (unless (symbolp symbol)
 515       (error "Should be a symbol %S" symbol))
 516     (custom-buffer-create-other-window (list (list symbol 'custom-face)))))
 517
 518 ;;;###autoload
 519 (defun customize-customized ()
 520   "Customize all already customized user options."
 521   (interactive)
 522   (let ((found nil))
 523     (mapatoms (lambda (symbol)
 524                 (and (get symbol 'saved-face)
 525                      (custom-facep symbol)
 526                      (setq found (cons (list symbol 'custom-face) found)))
 527                 (and (get symbol 'saved-value)
 528                      (boundp symbol)
 529                      (setq found
 530                            (cons (list symbol 'custom-variable) found)))))
 531     (if found
 532         (custom-buffer-create found)
 533       (error "No customized user options"))))
 534
 535 ;;;###autoload
 536 (defun customize-apropos (regexp &optional all)
 537   "Customize all user options matching REGEXP.
 538 If ALL (e.g., started with a prefix key), include options which are not
 539 user-settable."
 540   (interactive "sCustomize regexp: \nP")
 541   (let ((found nil))
 542     (mapatoms (lambda (symbol)
 543                 (when (string-match regexp (symbol-name symbol))
 544                   (when (get symbol 'custom-group)
 545                     (setq found (cons (list symbol 'custom-group) found)))
 546                   (when (custom-facep symbol)
 547                     (setq found (cons (list symbol 'custom-face) found)))
 548                   (when (and (boundp symbol)
 549                              (or (get symbol 'saved-value)
 550                                  (get symbol 'factory-value)
 551                                  (if all
 552                                      (get symbol 'variable-documentation)
 553                                    (user-variable-p symbol))))
 554                     (setq found
 555                           (cons (list symbol 'custom-variable) found))))))
 556     (if found
 557         (custom-buffer-create found)
 558       (error "No matches"))))
 559
 560 ;;;###autoload
 561 (defun custom-buffer-create (options)
 562   "Create a buffer containing OPTIONS.
 563 OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where
 564 SYMBOL is a customization option, and WIDGET is a widget for editing
 565 that option."
 566   (kill-buffer (get-buffer-create "*Customization*"))
 567   (switch-to-buffer (get-buffer-create "*Customization*"))
 568   (custom-buffer-create-internal options))
 569
 570 (defun custom-buffer-create-other-window (options)
 571   "Create a buffer containing OPTIONS.
 572 OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where
 573 SYMBOL is a customization option, and WIDGET is a widget for editing
 574 that option."
 575   (kill-buffer (get-buffer-create "*Customization*"))
 576   (let ((window (selected-window)))
 577     (switch-to-buffer-other-window (get-buffer-create "*Customization*"))
 578     (custom-buffer-create-internal options)
 579     (select-window window)))
 580
 581
 582 (defun custom-buffer-create-internal (options)
 583   (message "Creating customization buffer...")
 584   (custom-mode)
 585   (widget-insert "This is a customization buffer.
 586 Push RET or click mouse-2 on the word ")
 587   ;; (put-text-property 1 2 'start-open nil)
 588   (widget-create 'info-link
 589                  :tag "help"
 590                  :help-echo "Read the online help."
 591                  "(custom)The Customization Buffer")
 592   (widget-insert " for more information.\n\n")
 593   (setq custom-options
 594         (if (= (length options) 1)
 595             (mapcar (lambda (entry)
 596                       (widget-create (nth 1 entry)
 597                                      :custom-state 'unknown
 598                                      :tag (custom-unlispify-tag-name
 599                                            (nth 0 entry))
 600                                      :value (nth 0 entry)))
 601                     options)
 602           (let ((count 0)
 603                 (length (length options)))
 604             (mapcar (lambda (entry)
 605                         (prog2
 606                             (message "Creating customization items %2d%%..."
 607                                      (/ (* 100.0 count) length))
 608                             (widget-create (nth 1 entry)
 609                                          :tag (custom-unlispify-tag-name
 610                                                (nth 0 entry))
 611                                          :value (nth 0 entry))
 612                           (setq count (1+ count))
 613                           (unless (eq (preceding-char) ?\n)
 614                             (widget-insert "\n"))
 615                           (widget-insert "\n")))
 616                       options))))
 617   (unless (eq (preceding-char) ?\n)
 618     (widget-insert "\n"))
 619   (widget-insert "\n")
 620   (message "Creating customization magic...")
 621   (mapcar 'custom-magic-reset custom-options)
 622   (message "Creating customization buttons...")
 623   (widget-create 'push-button
 624                  :tag "Set"
 625                  :help-echo "Set all modifications for this session."
 626                  :action (lambda (widget &optional event)
 627                            (custom-set)))
 628   (widget-insert " ")
 629   (widget-create 'push-button
 630                  :tag "Save"
 631                  :help-echo "\
 632 Make the modifications default for future sessions."
 633                  :action (lambda (widget &optional event)
 634                            (custom-save)))
 635   (widget-insert " ")
 636   (widget-create 'push-button
 637                  :tag "Reset"
 638                  :help-echo "Undo all modifications."
 639                  :action (lambda (widget &optional event)
 640                            (custom-reset event)))
 641   (widget-insert " ")
 642   (widget-create 'push-button
 643                  :tag "Done"
 644                  :help-echo "Bury the buffer."
 645                  :action (lambda (widget &optional event)
 646                            (bury-buffer)
 647                            ;; Steal button release event.
 648                            (if (and (fboundp 'button-press-event-p)
 649                                     (fboundp 'next-command-event))
 650                                ;; XEmacs
 651                                (and event
 652                                     (button-press-event-p event)
 653                                     (next-command-event))
 654                              ;; Emacs
 655                              (when (memq 'down (event-modifiers event))
 656                                (read-event)))))
 657   (widget-insert "\n")
 658   (message "Creating customization setup...")
 659   (widget-setup)
 660   (goto-char (point-min))
 661   (forward-char)                        ;Kludge: bob is writable in XEmacs.
 662   (message "Creating customization buffer...done"))
 663
 664 ;;; Modification of Basic Widgets.
 665 ;;
 666 ;; We add extra properties to the basic widgets needed here.  This is
 667 ;; fine, as long as we are careful to stay within out own namespace.
 668 ;;
 669 ;; We want simple widgets to be displayed by default, but complex
 670 ;; widgets to be hidden.
 671
 672 (widget-put (get 'item 'widget-type) :custom-show t)
 673 (widget-put (get 'editable-field 'widget-type)
 674             :custom-show (lambda (widget value)
 675                            (let ((pp (pp-to-string value)))
 676                              (cond ((string-match "\n" pp)
 677                                     nil)
 678                                    ((> (length pp) 40)
 679                                     nil)
 680                                    (t t)))))
 681 (widget-put (get 'menu-choice 'widget-type) :custom-show t)
 682
 683 ;;; The `custom-manual' Widget.
 684
 685 (define-widget 'custom-manual 'info-link
 686   "Link to the manual entry for this customization option."
 687   :help-echo "Read the manual entry for this option."
 688   :tag "Manual")
 689
 690 ;;; The `custom-magic' Widget.
 691
 692 (defface custom-invalid-face '((((class color))
 693                                 (:foreground "yellow" :background "red"))
 694                                (t
 695                                 (:bold t :italic t :underline t)))
 696   "Face used when the customize item is invalid.")
 697
 698 (defface custom-rogue-face '((((class color))
 699                               (:foreground "pink" :background "black"))
 700                              (t
 701                               (:underline t)))
 702   "Face used when the customize item is not defined for customization.")
 703
 704 (defface custom-modified-face '((((class color))
 705                                  (:foreground "white" :background "blue"))
 706                                 (t
 707                                  (:italic t :bold)))
 708   "Face used when the customize item has been modified.")
 709
 710 (defface custom-set-face '((((class color))
 711                                 (:foreground "blue" :background "white"))
 712                                (t
 713                                 (:italic t)))
 714   "Face used when the customize item has been set.")
 715
 716 (defface custom-changed-face '((((class color))
 717                                 (:foreground "white" :background "blue"))
 718                                (t
 719                                 (:italic t)))
 720   "Face used when the customize item has been changed.")
 721
 722 (defface custom-saved-face '((t (:underline t)))
 723   "Face used when the customize item has been saved.")
 724
 725 (defcustom custom-magic-alist '((nil "#" underline "\
 726 uninitialized, you should not see this.")
 727                                 (unknown "?" italic "\
 728 unknown, you should not see this.")
 729                                 (hidden "-" default "\
 730 hidden, press the state button to show.")
 731                                 (invalid "x" custom-invalid-face "\
 732 the value displayed for this item is invalid and cannot be set.")
 733                                 (modified "*" custom-modified-face "\
 734 you have edited the item, and can now set it.")
 735                                 (set "+" custom-set-face "\
 736 you have set this item, but not saved it.")
 737                                 (changed ":" custom-changed-face "\
 738 this item has been changed outside customize.")
 739                                 (saved "!" custom-saved-face "\
 740 this item has been saved.")
 741                                 (rogue "@" custom-rogue-face "\
 742 this item is not prepared for customization.")
 743                                 (factory " " nil "\
 744 this item is unchanged from its factory setting."))
 745   "Alist of customize option states.
 746 Each entry is of the form (STATE MAGIC FACE DESCRIPTION), where
 747
 748 STATE is one of the following symbols:
 749
 750 `nil'
 751    For internal use, should never occur.
 752 `unknown'
 753    For internal use, should never occur.
 754 `hidden'
 755    This item is not being displayed.
 756 `invalid'
 757    This item is modified, but has an invalid form.
 758 `modified'
 759    This item is modified, and has a valid form.
 760 `set'
 761    This item has been set but not saved.
 762 `changed'
 763    The current value of this item has been changed temporarily.
 764 `saved'
 765    This item is marked for saving.
 766 `rogue'
 767    This item has no customization information.
 768 `factory'
 769    This item is unchanged from the factory default.
 770
 771 MAGIC is a string used to present that state.
 772
 773 FACE is a face used to present the state.
 774
 775 DESCRIPTION is a string describing the state.
 776
 777 The list should be sorted most significant first."
 778   :type '(list (checklist :inline t
 779                           (group (const nil)
 780                                  (string :tag "Magic")
 781                                  face
 782                                  (string :tag "Description"))
 783                           (group (const unknown)
 784                                  (string :tag "Magic")
 785                                  face
 786                                  (string :tag "Description"))
 787                           (group (const hidden)
 788                                  (string :tag "Magic")
 789                                  face
 790                                  (string :tag "Description"))
 791                           (group (const invalid)
 792                                  (string :tag "Magic")
 793                                  face
 794                                  (string :tag "Description"))
 795                           (group (const modified)
 796                                  (string :tag "Magic")
 797                                  face
 798                                  (string :tag "Description"))
 799                           (group (const set)
 800                                  (string :tag "Magic")
 801                                  face
 802                                  (string :tag "Description"))
 803                           (group (const changed)
 804                                  (string :tag "Magic")
 805                                  face
 806                                  (string :tag "Description"))
 807                           (group (const saved)
 808                                  (string :tag "Magic")
 809                                  face
 810                                  (string :tag "Description"))
 811                           (group (const rogue)
 812                                  (string :tag "Magic")
 813                                  face
 814                                  (string :tag "Description"))
 815                           (group (const factory)
 816                                  (string :tag "Magic")
 817                                  face
 818                                  (string :tag "Description")))
 819                (editable-list :inline t
 820                               (group symbol
 821                                      (string :tag "Magic")
 822                                      face
 823                                      (string :tag "Description"))))
 824   :group 'customize
 825   :group 'custom-faces)
 826
 827 (defcustom custom-magic-show 'long
 828   "Show long description of the state of each customization option."
 829   :type '(choice (const :tag "no" nil)
 830                  (const short)
 831                  (const long))
 832   :group 'customize)
 833
 834 (defcustom custom-magic-show-button t
 835   "Show a magic button indicating the state of each customization option."
 836   :type 'boolean
 837   :group 'customize)
 838
 839 (define-widget 'custom-magic 'default
 840   "Show and manipulate state for a customization option."
 841   :format "%v"
 842   :action 'widget-choice-item-action
 843   :value-get 'ignore
 844   :value-create 'custom-magic-value-create
 845   :value-delete 'widget-children-value-delete)
 846
 847 (defun custom-magic-value-create (widget)
 848   ;; Create compact status report for WIDGET.
 849   (let* ((parent (widget-get widget :parent))
 850          (state (widget-get parent :custom-state))
 851          (entry (assq state custom-magic-alist))
 852          (magic (nth 1 entry))
 853          (face (nth 2 entry))
 854          (text (nth 3 entry))
 855          (lisp (eq (widget-get parent :custom-form) 'lisp))
 856          children)
 857     (when custom-magic-show
 858       (push (widget-create-child-and-convert widget 'choice-item
 859                                              :help-echo "\
 860 Change the state of this item."
 861                                              :format "%[%t%]"
 862                                              :tag "State")
 863             children)
 864       (insert ": ")
 865       (if (eq custom-magic-show 'long)
 866           (insert text)
 867         (insert (symbol-name state)))
 868       (when lisp
 869         (insert " (lisp)"))
 870       (insert "\n"))
 871     (when custom-magic-show-button
 872       (when custom-magic-show
 873         (let ((indent (widget-get parent :indent)))
 874           (when indent
 875             (insert-char ?  indent))))
 876       (push (widget-create-child-and-convert widget 'choice-item
 877                                              :button-face face
 878                                              :help-echo "Change the state."
 879                                              :format "%[%t%]"
 880                                              :tag (if lisp
 881                                                       (concat "(" magic ")")
 882                                                     (concat "[" magic "]")))
 883             children)
 884       (insert " "))
 885     (widget-put widget :children children)))
 886
 887 (defun custom-magic-reset (widget)
 888   "Redraw the :custom-magic property of WIDGET."
 889   (let ((magic (widget-get widget :custom-magic)))
 890     (widget-value-set magic (widget-value magic))))
 891
 892 ;;; The `custom-level' Widget.
 893
 894 (define-widget 'custom-level 'item
 895   "The custom level buttons."
 896   :format "%[%t%]"
 897   :help-echo "Expand or collapse this item."
 898   :action 'custom-level-action)
 899
 900 (defun custom-level-action (widget &optional event)
 901   "Toggle visibility for parent to WIDGET."
 902   (let* ((parent (widget-get widget :parent))
 903          (state (widget-get parent :custom-state)))
 904     (cond ((memq state '(invalid modified))
 905            (error "There are unset changes"))
 906           ((eq state 'hidden)
 907            (widget-put parent :custom-state 'unknown))
 908           (t
 909            (widget-put parent :custom-state 'hidden)))
 910     (custom-redraw parent)))
 911
 912 ;;; The `custom' Widget.
 913
 914 (define-widget 'custom 'default
 915   "Customize a user option."
 916   :convert-widget 'custom-convert-widget
 917   :format "%l%[%t%]: %v%m%h%a"
 918   :format-handler 'custom-format-handler
 919   :notify 'custom-notify
 920   :custom-level 1
 921   :custom-state 'hidden
 922   :documentation-property 'widget-subclass-responsibility
 923   :value-create 'widget-subclass-responsibility
 924   :value-delete 'widget-children-value-delete
 925   :value-get 'widget-item-value-get
 926   :validate 'widget-editable-list-validate
 927   :match (lambda (widget value) (symbolp value)))
 928
 929 (defun custom-convert-widget (widget)
 930   ;; Initialize :value and :tag from :args in WIDGET.
 931   (let ((args (widget-get widget :args)))
 932     (when args
 933       (widget-put widget :value (widget-apply widget
 934                                               :value-to-internal (car args)))
 935       (widget-put widget :tag (custom-unlispify-tag-name (car args)))
 936       (widget-put widget :args nil)))
 937   widget)
 938
 939 (defun custom-format-handler (widget escape)
 940   ;; We recognize extra escape sequences.
 941   (let* ((buttons (widget-get widget :buttons))
 942          (state (widget-get widget :custom-state))
 943          (level (widget-get widget :custom-level)))
 944     (cond ((eq escape ?l)
 945            (when level
 946              (push (widget-create-child-and-convert
 947                     widget 'custom-level (make-string level ?*))
 948                    buttons)
 949              (widget-insert " ")
 950              (widget-put widget :buttons buttons)))
 951           ((eq escape ?L)
 952            (when (eq state 'hidden)
 953              (widget-insert " ...")))
 954           ((eq escape ?m)
 955            (and (eq (preceding-char) ?\n)
 956                 (widget-get widget :indent)
 957                 (insert-char ?  (widget-get widget :indent)))
 958            (let ((magic (widget-create-child-and-convert
 959                          widget 'custom-magic nil)))
 960              (widget-put widget :custom-magic magic)
 961              (push magic buttons)
 962              (widget-put widget :buttons buttons)))
 963           ((eq escape ?a)
 964            (let* ((symbol (widget-get widget :value))
 965                   (links (get symbol 'custom-links))
 966                   (many (> (length links) 2)))
 967              (when links
 968                (and (eq (preceding-char) ?\n)
 969                     (widget-get widget :indent)
 970                     (insert-char ?  (widget-get widget :indent)))
 971                (insert "See also ")
 972                (while links
 973                  (push (widget-create-child-and-convert widget (car links))
 974                        buttons)
 975                  (setq links (cdr links))
 976                  (cond ((null links)
 977                         (insert ".\n"))
 978                        ((null (cdr links))
 979                         (if many
 980                             (insert ", and ")
 981                           (insert " and ")))
 982                        (t
 983                         (insert ", "))))
 984                (widget-put widget :buttons buttons))))
 985           (t
 986            (widget-default-format-handler widget escape)))))
 987
 988 (defun custom-notify (widget &rest args)
 989   "Keep track of changes."
 990   (unless (memq (widget-get widget :custom-state) '(nil unknown hidden))
 991     (widget-put widget :custom-state 'modified))
 992   (let ((buffer-undo-list t))
 993     (custom-magic-reset widget))
 994   (apply 'widget-default-notify widget args))
 995
 996 (defun custom-redraw (widget)
 997   "Redraw WIDGET with current settings."
 998   (let ((pos (point))
 999         (from (marker-position (widget-get widget :from)))
1000         (to (marker-position (widget-get widget :to))))
1001     (save-excursion
1002       (widget-value-set widget (widget-value widget))
1003       (custom-redraw-magic widget))
1004     (when (and (>= pos from) (<= pos to))
1005       (goto-char pos))))
1006
1007 (defun custom-redraw-magic (widget)
1008   "Redraw WIDGET state with current settings."
1009   (while widget
1010     (let ((magic (widget-get widget :custom-magic)))
1011       (unless magic
1012         (debug))
1013       (widget-value-set magic (widget-value magic))
1014       (when (setq widget (widget-get widget :group))
1015         (custom-group-state-update widget))))
1016   (widget-setup))
1017
1018 (defun custom-show (widget value)
1019   "Non-nil if WIDGET should be shown with VALUE by default."
1020   (let ((show (widget-get widget :custom-show)))
1021     (cond ((null show)
1022            nil)
1023           ((eq t show)
1024            t)
1025           (t
1026            (funcall show widget value)))))
1027
1028 (defvar custom-load-recursion nil
1029   "Hack to avoid recursive dependencies.")
1030
1031 (defun custom-load-symbol (symbol)
1032   "Load all dependencies for SYMBOL."
1033   (unless custom-load-recursion
1034     (let ((custom-load-recursion t)
1035           (loads (get symbol 'custom-loads))
1036           load)
1037       (while loads
1038         (setq load (car loads)
1039               loads (cdr loads))
1040         (cond ((symbolp load)
1041                (condition-case nil
1042                    (require load)
1043                  (error nil)))
1044               ((assoc load load-history))
1045               (t
1046                (condition-case nil
1047                    (load-library load)
1048                  (error nil))))))))
1049
1050 (defun custom-load-widget (widget)
1051   "Load all dependencies for WIDGET."
1052   (custom-load-symbol (widget-value widget)))
1053
1054 ;;; The `custom-variable' Widget.
1055
1056 (defface custom-variable-sample-face '((t (:underline t)))
1057   "Face used for unpushable variable tags."
1058   :group 'custom-faces)
1059
1060 (defface custom-variable-button-face '((t (:underline t :bold t)))
1061   "Face used for pushable variable tags."
1062   :group 'custom-faces)
1063
1064 (define-widget 'custom-variable 'custom
1065   "Customize variable."
1066   :format "%l%v%m%h%a"
1067   :help-echo "Set or reset this variable."
1068   :documentation-property 'variable-documentation
1069   :custom-state nil
1070   :custom-menu 'custom-variable-menu-create
1071   :custom-form 'edit
1072   :value-create 'custom-variable-value-create
1073   :action 'custom-variable-action
1074   :custom-set 'custom-variable-set
1075   :custom-save 'custom-variable-save
1076   :custom-reset-current 'custom-redraw
1077   :custom-reset-saved 'custom-variable-reset-saved
1078   :custom-reset-factory 'custom-variable-reset-factory)
1079
1080 (defun custom-variable-type (symbol)
1081   "Return a widget suitable for editing the value of SYMBOL.
1082 If SYMBOL has a `custom-type' property, use that.
1083 Otherwise, look up symbol in `custom-guess-type-alist'."
1084   (let* ((type (or (get symbol 'custom-type)
1085                    (and (not (get symbol 'factory-value))
1086                         (custom-guess-type symbol))
1087                    'sexp))
1088          (options (get symbol 'custom-options))
1089          (tmp (if (listp type)
1090                   (copy-list type)
1091                 (list type))))
1092     (when options
1093       (widget-put tmp :options options))
1094     tmp))
1095
1096 (defun custom-variable-value-create (widget)
1097   "Here is where you edit the variables value."
1098   (custom-load-widget widget)
1099   (let* ((buttons (widget-get widget :buttons))
1100          (children (widget-get widget :children))
1101          (form (widget-get widget :custom-form))
1102          (state (widget-get widget :custom-state))
1103          (symbol (widget-get widget :value))
1104          (tag (widget-get widget :tag))
1105          (type (custom-variable-type symbol))
1106          (conv (widget-convert type))
1107          (value (if (default-boundp symbol)
1108                     (default-value symbol)
1109                   (widget-get conv :value))))
1110     ;; If the widget is new, the child determine whether it is hidden.
1111     (cond (state)
1112           ((custom-show type value)
1113            (setq state 'unknown))
1114           (t
1115            (setq state 'hidden)))
1116     ;; If we don't know the state, see if we need to edit it in lisp form.
1117     (when (eq state 'unknown)
1118       (unless (widget-apply conv :match value)
1119         ;; (widget-apply (widget-convert type) :match value)
1120         (setq form 'lisp)))
1121     ;; Now we can create the child widget.
1122     (cond ((eq state 'hidden)
1123            ;; Indicate hidden value.
1124            (push (widget-create-child-and-convert
1125                   widget 'item
1126                   :format "%{%t%}: ..."
1127                   :sample-face 'custom-variable-sample-face
1128                   :tag tag
1129                   :parent widget)
1130                  children))
1131           ((eq form 'lisp)
1132            ;; In lisp mode edit the saved value when possible.
1133            (let* ((value (cond ((get symbol 'saved-value)
1134                                 (car (get symbol 'saved-value)))
1135                                ((get symbol 'factory-value)
1136                                 (car (get symbol 'factory-value)))
1137                                ((default-boundp symbol)
1138                                 (custom-quote (default-value symbol)))
1139                                (t
1140                                 (custom-quote (widget-get conv :value))))))
1141              (push (widget-create-child-and-convert
1142                     widget 'sexp
1143                     :button-face 'custom-variable-button-face
1144                     :tag (symbol-name symbol)
1145                     :parent widget
1146                     :value value)
1147                    children)))
1148           (t
1149            ;; Edit mode.
1150            (push (widget-create-child-and-convert
1151                   widget type
1152                   :tag tag
1153                   :button-face 'custom-variable-button-face
1154                   :sample-face 'custom-variable-sample-face
1155                   :value value)
1156                  children)))
1157     ;; Now update the state.
1158     (unless (eq (preceding-char) ?\n)
1159       (widget-insert "\n"))
1160     (if (eq state 'hidden)
1161         (widget-put widget :custom-state state)
1162       (custom-variable-state-set widget))
1163     (widget-put widget :custom-form form)
1164     (widget-put widget :buttons buttons)
1165     (widget-put widget :children children)))
1166
1167 (defun custom-variable-state-set (widget)
1168   "Set the state of WIDGET."
1169   (let* ((symbol (widget-value widget))
1170          (value (if (default-boundp symbol)
1171                     (default-value symbol)
1172                   (widget-get widget :value)))
1173          tmp
1174          (state (cond ((setq tmp (get symbol 'customized-value))
1175                        (if (condition-case nil
1176                                (equal value (eval (car tmp)))
1177                              (error nil))
1178                            'set
1179                          'changed))
1180                       ((setq tmp (get symbol 'saved-value))
1181                        (if (condition-case nil
1182                                (equal value (eval (car tmp)))
1183                              (error nil))
1184                            'saved
1185                          'changed))
1186                       ((setq tmp (get symbol 'factory-value))
1187                        (if (condition-case nil
1188                                (equal value (eval (car tmp)))
1189                              (error nil))
1190                            'factory
1191                          'changed))
1192                       (t 'rogue))))
1193     (widget-put widget :custom-state state)))
1194
1195 (defvar custom-variable-menu
1196   '(("Edit" . custom-variable-edit)
1197     ("Edit Lisp" . custom-variable-edit-lisp)
1198     ("Set" . custom-variable-set)
1199     ("Save" . custom-variable-save)
1200     ("Reset to Current" . custom-redraw)
1201     ("Reset to Saved" . custom-variable-reset-saved)
1202     ("Reset to Factory Settings" . custom-variable-reset-factory))
1203   "Alist of actions for the `custom-variable' widget.
1204 The key is a string containing the name of the action, the value is a
1205 lisp function taking the widget as an element which will be called
1206 when the action is chosen.")
1207
1208 (defun custom-variable-action (widget &optional event)
1209   "Show the menu for `custom-variable' WIDGET.
1210 Optional EVENT is the location for the menu."
1211   (if (eq (widget-get widget :custom-state) 'hidden)
1212       (progn
1213         (widget-put widget :custom-state 'unknown)
1214         (custom-redraw widget))
1215     (let* ((completion-ignore-case t)
1216            (answer (widget-choose (custom-unlispify-tag-name
1217                                    (widget-get widget :value))
1218                                   custom-variable-menu
1219                                   event)))
1220       (if answer
1221           (funcall answer widget)))))
1222
1223 (defun custom-variable-edit (widget)
1224   "Edit value of WIDGET."
1225   (widget-put widget :custom-state 'unknown)
1226   (widget-put widget :custom-form 'edit)
1227   (custom-redraw widget))
1228
1229 (defun custom-variable-edit-lisp (widget)
1230   "Edit the lisp representation of the value of WIDGET."
1231   (widget-put widget :custom-state 'unknown)
1232   (widget-put widget :custom-form 'lisp)
1233   (custom-redraw widget))
1234
1235 (defun custom-variable-set (widget)
1236   "Set the current value for the variable being edited by WIDGET."
1237   (let ((form (widget-get widget :custom-form))
1238         (state (widget-get widget :custom-state))
1239         (child (car (widget-get widget :children)))
1240         (symbol (widget-value widget))
1241         val)
1242     (cond ((eq state 'hidden)
1243            (error "Cannot set hidden variable."))
1244           ((setq val (widget-apply child :validate))
1245            (goto-char (widget-get val :from))
1246            (error "%s" (widget-get val :error)))
1247           ((eq form 'lisp)
1248            (set-default symbol (eval (setq val (widget-value child))))
1249            (put symbol 'customized-value (list val)))
1250           (t
1251            (set-default symbol (setq val (widget-value child)))
1252            (put symbol 'customized-value (list (custom-quote val)))))
1253     (custom-variable-state-set widget)
1254     (custom-redraw-magic widget)))
1255
1256 (defun custom-variable-save (widget)
1257   "Set the default value for the variable being edited by WIDGET."
1258   (let ((form (widget-get widget :custom-form))
1259         (state (widget-get widget :custom-state))
1260         (child (car (widget-get widget :children)))
1261         (symbol (widget-value widget))
1262         val)
1263     (cond ((eq state 'hidden)
1264            (error "Cannot set hidden variable."))
1265           ((setq val (widget-apply child :validate))
1266            (goto-char (widget-get val :from))
1267            (error "%s" (widget-get val :error)))
1268           ((eq form 'lisp)
1269            (put symbol 'saved-value (list (widget-value child)))
1270            (set-default symbol (eval (widget-value child))))
1271           (t
1272            (put symbol
1273                 'saved-value (list (custom-quote (widget-value
1274                                                   child))))
1275            (set-default symbol (widget-value child))))
1276     (put symbol 'customized-value nil)
1277     (custom-save-all)
1278     (custom-variable-state-set widget)
1279     (custom-redraw-magic widget)))
1280
1281 (defun custom-variable-reset-saved (widget)
1282   "Restore the saved value for the variable being edited by WIDGET."
1283   (let ((symbol (widget-value widget)))
1284     (if (get symbol 'saved-value)
1285         (condition-case nil
1286             (set-default symbol (eval (car (get symbol 'saved-value))))
1287           (error nil))
1288       (error "No saved value for %s" symbol))
1289     (put symbol 'customized-value nil)
1290     (widget-put widget :custom-state 'unknown)
1291     (custom-redraw widget)))
1292
1293 (defun custom-variable-reset-factory (widget)
1294   "Restore the factory setting for the variable being edited by WIDGET."
1295   (let ((symbol (widget-value widget)))
1296     (if (get symbol 'factory-value)
1297         (set-default symbol (eval (car (get symbol 'factory-value))))
1298       (error "No factory default for %S" symbol))
1299     (put symbol 'customized-value nil)
1300     (when (get symbol 'saved-value)
1301       (put symbol 'saved-value nil)
1302       (custom-save-all))
1303     (widget-put widget :custom-state 'unknown)
1304     (custom-redraw widget)))
1305
1306 ;;; The `custom-face-edit' Widget.
1307
1308 (define-widget 'custom-face-edit 'checklist
1309   "Edit face attributes."
1310   :format "%t: %v"
1311   :tag "Attributes"
1312   :extra-offset 12
1313   :button-args '(:help-echo "Control whether this attribute have any effect.")
1314   :args (mapcar (lambda (att)
1315                   (list 'group
1316                         :inline t
1317                         :sibling-args (widget-get (nth 1 att) :sibling-args)
1318                         (list 'const :format "" :value (nth 0 att))
1319                         (nth 1 att)))
1320                 custom-face-attributes))
1321
1322 ;;; The `custom-display' Widget.
1323
1324 (define-widget 'custom-display 'menu-choice
1325   "Select a display type."
1326   :tag "Display"
1327   :value t
1328   :help-echo "Specify frames where the face attributes should be used."
1329   :args '((const :tag "all" t)
1330           (checklist
1331            :offset 0
1332            :extra-offset 9
1333            :args ((group :sibling-args (:help-echo "\
1334 Only match the specified window systems.")
1335                          (const :format "Type: "
1336                                 type)
1337                          (checklist :inline t
1338                                     :offset 0
1339                                     (const :format "X "
1340                                            :sibling-args (:help-echo "\
1341 The X11 Window System.")
1342                                            x)
1343                                     (const :format "PM "
1344                                            :sibling-args (:help-echo "\
1345 OS/2 Presentation Manager.")
1346                                            pm)
1347                                     (const :format "Win32 "
1348                                            :sibling-args (:help-echo "\
1349 Windows NT/95/97.")
1350                                            win32)
1351                                     (const :format "DOS "
1352                                            :sibling-args (:help-echo "\
1353 Plain MS-DOS.")
1354                                            pc)
1355                                     (const :format "TTY%n"
1356                                            :sibling-args (:help-echo "\
1357 Plain text terminals.")
1358                                            tty)))
1359                   (group :sibling-args (:help-echo "\
1360 Only match the frames with the specified color support.")
1361                          (const :format "Class: "
1362                                 class)
1363                          (checklist :inline t
1364                                     :offset 0
1365                                     (const :format "Color "
1366                                            :sibling-args (:help-echo "\
1367 Match color frames.")
1368                                            color)
1369                                     (const :format "Grayscale "
1370                                            :sibling-args (:help-echo "\
1371 Match grayscale frames.")
1372                                            grayscale)
1373                                     (const :format "Monochrome%n"
1374                                            :sibling-args (:help-echo "\
1375 Match frames with no color support.")
1376                                            mono)))
1377                   (group :sibling-args (:help-echo "\
1378 Only match frames with the specified intensity.")
1379                          (const :format "\
1380 Background brightness: "
1381                                 background)
1382                          (checklist :inline t
1383                                     :offset 0
1384                                     (const :format "Light "
1385                                            :sibling-args (:help-echo "\
1386 Match frames with light backgrounds.")
1387                                            light)
1388                                     (const :format "Dark\n"
1389                                            :sibling-args (:help-echo "\
1390 Match frames with dark backgrounds.")
1391                                            dark)))))))
1392
1393 ;;; The `custom-face' Widget.
1394
1395 (defface custom-face-tag-face '((t (:underline t)))
1396   "Face used for face tags."
1397   :group 'custom-faces)
1398
1399 (define-widget 'custom-face 'custom
1400   "Customize face."
1401   :format "%l%{%t%}: %s%m%h%a%v"
1402   :format-handler 'custom-face-format-handler
1403   :sample-face 'custom-face-tag-face
1404   :help-echo "Set or reset this face."
1405   :documentation-property '(lambda (face)
1406                              (face-doc-string face))
1407   :value-create 'custom-face-value-create
1408   :action 'custom-face-action
1409   :custom-form 'selected
1410   :custom-set 'custom-face-set
1411   :custom-save 'custom-face-save
1412   :custom-reset-current 'custom-redraw
1413   :custom-reset-saved 'custom-face-reset-saved
1414   :custom-reset-factory 'custom-face-reset-factory
1415   :custom-menu 'custom-face-menu-create)
1416
1417 (defun custom-face-format-handler (widget escape)
1418   ;; We recognize extra escape sequences.
1419   (let (child
1420         (symbol (widget-get widget :value)))
1421     (cond ((eq escape ?s)
1422            (and (string-match "XEmacs" emacs-version)
1423                 ;; XEmacs cannot display initialized faces.
1424                 (not (custom-facep symbol))
1425                 (copy-face 'custom-face-empty symbol))
1426            (setq child (widget-create-child-and-convert
1427                         widget 'item
1428                         :format "(%{%t%})\n"
1429                         :sample-face symbol
1430                         :tag "sample")))
1431           (t
1432            (custom-format-handler widget escape)))
1433     (when child
1434       (widget-put widget
1435                   :buttons (cons child (widget-get widget :buttons))))))
1436
1437 (define-widget 'custom-face-all 'editable-list
1438   "An editable list of display specifications and attributes."
1439   :entry-format "%i %d %v"
1440   :insert-button-args '(:help-echo "Insert new display specification here.")
1441   :append-button-args '(:help-echo "Append new display specification here.")
1442   :delete-button-args '(:help-echo "Delete this display specification.")
1443   :args '((group :format "%v" custom-display custom-face-edit)))
1444
1445 (defconst custom-face-all (widget-convert 'custom-face-all)
1446   "Converted version of the `custom-face-all' widget.")
1447
1448 (define-widget 'custom-display-unselected 'item
1449   "A display specification that doesn't match the selected display."
1450   :match 'custom-display-unselected-match)
1451
1452 (defun custom-display-unselected-match (widget value)
1453   "Non-nil if VALUE is an unselected display specification."
1454   (and (listp value)
1455        (eq (length value) 2)
1456        (not (custom-display-match-frame value (selected-frame)))))
1457
1458 (define-widget 'custom-face-selected 'group
1459   "Edit the attributes of the selected display in a face specification."
1460   :args '((repeat :format ""
1461                   :inline t
1462                   (group custom-display-unselected sexp))
1463           (group (sexp :format "") custom-face-edit)
1464           (repeat :format ""
1465                   :inline t
1466                   sexp)))
1467
1468 (defconst custom-face-selected (widget-convert 'custom-face-selected)
1469   "Converted version of the `custom-face-selected' widget.")
1470
1471 (defun custom-face-value-create (widget)
1472   ;; Create a list of the display specifications.
1473   (unless (eq (preceding-char) ?\n)
1474     (insert "\n"))
1475   (when (not (eq (widget-get widget :custom-state) 'hidden))
1476     (message "Creating face editor...")
1477     (custom-load-widget widget)
1478     (let* ((symbol (widget-value widget))
1479            (spec (or (get symbol 'saved-face)
1480                      (get symbol 'factory-face)
1481                      ;; Attempt to construct it.
1482                      (list (list t (custom-face-attributes-get
1483                                     symbol (selected-frame))))))
1484            (form (widget-get widget :custom-form))
1485            (indent (widget-get widget :indent))
1486            (edit (widget-create-child-and-convert
1487                   widget
1488                   (cond ((and (eq form 'selected)
1489                               (widget-apply custom-face-selected :match spec))
1490                          (when indent (insert-char ?\  indent))
1491                          'custom-face-selected)
1492                         ((and (not (eq form 'lisp))
1493                               (widget-apply custom-face-all :match spec))
1494                          'custom-face-all)
1495                         (t
1496                          (when indent (insert-char ?\  indent))
1497                          'sexp))
1498                   :value spec)))
1499       (custom-face-state-set widget)
1500       (widget-put widget :children (list edit)))
1501     (message "Creating face editor...done")))
1502
1503 (defvar custom-face-menu
1504   '(("Edit Selected" . custom-face-edit-selected)
1505     ("Edit All" . custom-face-edit-all)
1506     ("Edit Lisp" . custom-face-edit-lisp)
1507     ("Set" . custom-face-set)
1508     ("Save" . custom-face-save)
1509     ("Reset to Saved" . custom-face-reset-saved)
1510     ("Reset to Factory Setting" . custom-face-reset-factory))
1511   "Alist of actions for the `custom-face' widget.
1512 The key is a string containing the name of the action, the value is a
1513 lisp function taking the widget as an element which will be called
1514 when the action is chosen.")
1515
1516 (defun custom-face-edit-selected (widget)
1517   "Edit selected attributes of the value of WIDGET."
1518   (widget-put widget :custom-state 'unknown)
1519   (widget-put widget :custom-form 'selected)
1520   (custom-redraw widget))
1521
1522 (defun custom-face-edit-all (widget)
1523   "Edit all attributes of the value of WIDGET."
1524   (widget-put widget :custom-state 'unknown)
1525   (widget-put widget :custom-form 'all)
1526   (custom-redraw widget))
1527
1528 (defun custom-face-edit-lisp (widget)
1529   "Edit the lisp representation of the value of WIDGET."
1530   (widget-put widget :custom-state 'unknown)
1531   (widget-put widget :custom-form 'lisp)
1532   (custom-redraw widget))
1533
1534 (defun custom-face-state-set (widget)
1535   "Set the state of WIDGET."
1536   (let ((symbol (widget-value widget)))
1537     (widget-put widget :custom-state (cond ((get symbol 'customized-face)
1538                                             'set)
1539                                            ((get symbol 'saved-face)
1540                                             'saved)
1541                                            ((get symbol 'factory-face)
1542                                             'factory)
1543                                            (t
1544                                             'rogue)))))
1545
1546 (defun custom-face-action (widget &optional event)
1547   "Show the menu for `custom-face' WIDGET.
1548 Optional EVENT is the location for the menu."
1549   (if (eq (widget-get widget :custom-state) 'hidden)
1550       (progn
1551         (widget-put widget :custom-state 'unknown)
1552         (custom-redraw widget))
1553     (let* ((completion-ignore-case t)
1554            (symbol (widget-get widget :value))
1555            (answer (widget-choose (custom-unlispify-tag-name symbol)
1556                                   custom-face-menu event)))
1557       (if answer
1558           (funcall answer widget)))))
1559
1560 (defun custom-face-set (widget)
1561   "Make the face attributes in WIDGET take effect."
1562   (let* ((symbol (widget-value widget))
1563          (child (car (widget-get widget :children)))
1564          (value (widget-value child)))
1565     (put symbol 'customized-face value)
1566     (when (fboundp 'copy-face)
1567       (copy-face 'custom-face-empty symbol))
1568     (custom-face-display-set symbol value)
1569     (custom-face-state-set widget)
1570     (custom-redraw-magic widget)))
1571
1572 (defun custom-face-save (widget)
1573   "Make the face attributes in WIDGET default."
1574   (let* ((symbol (widget-value widget))
1575          (child (car (widget-get widget :children)))
1576          (value (widget-value child)))
1577     (when (fboundp 'copy-face)
1578       (copy-face 'custom-face-empty symbol))
1579     (custom-face-display-set symbol value)
1580     (put symbol 'saved-face value)
1581     (put symbol 'customized-face nil)
1582     (custom-face-state-set widget)
1583     (custom-redraw-magic widget)))
1584
1585 (defun custom-face-reset-saved (widget)
1586   "Restore WIDGET to the face's default attributes."
1587   (let* ((symbol (widget-value widget))
1588          (child (car (widget-get widget :children)))
1589          (value (get symbol 'saved-face)))
1590     (unless value
1591       (error "No saved value for this face"))
1592     (put symbol 'customized-face nil)
1593     (when (fboundp 'copy-face)
1594       (copy-face 'custom-face-empty symbol))
1595     (custom-face-display-set symbol value)
1596     (widget-value-set child value)
1597     (custom-face-state-set widget)
1598     (custom-redraw-magic widget)))
1599
1600 (defun custom-face-reset-factory (widget)
1601   "Restore WIDGET to the face's factory settings."
1602   (let* ((symbol (widget-value widget))
1603          (child (car (widget-get widget :children)))
1604          (value (get symbol 'factory-face)))
1605     (unless value
1606       (error "No factory default for this face"))
1607     (put symbol 'customized-face nil)
1608     (when (get symbol 'saved-face)
1609       (put symbol 'saved-face nil)
1610       (custom-save-all))
1611     (when (fboundp 'copy-face)
1612       (copy-face 'custom-face-empty symbol))
1613     (custom-face-display-set symbol value)
1614     (widget-value-set child value)
1615     (custom-face-state-set widget)
1616     (custom-redraw-magic widget)))
1617
1618 ;;; The `face' Widget.
1619
1620 (define-widget 'face 'default
1621   "Select and customize a face."
1622   :convert-widget 'widget-item-convert-widget
1623   :format "%[%t%]: %v"
1624   :tag "Face"
1625   :value 'default
1626   :value-create 'widget-face-value-create
1627   :value-delete 'widget-face-value-delete
1628   :value-get 'widget-item-value-get
1629   :validate 'widget-editable-list-validate
1630   :action 'widget-face-action
1631   :match '(lambda (widget value) (symbolp value)))
1632
1633 (defun widget-face-value-create (widget)
1634   ;; Create a `custom-face' child.
1635   (let* ((symbol (widget-value widget))
1636          (child (widget-create-child-and-convert
1637                  widget 'custom-face
1638                  :format "%t %s%m%h%v"
1639                  :custom-level nil
1640                  :value symbol)))
1641     (custom-magic-reset child)
1642     (setq custom-options (cons child custom-options))
1643     (widget-put widget :children (list child))))
1644
1645 (defun widget-face-value-delete (widget)
1646   ;; Remove the child from the options.
1647   (let ((child (car (widget-get widget :children))))
1648     (setq custom-options (delq child custom-options))
1649     (widget-children-value-delete widget)))
1650
1651 (defvar face-history nil
1652   "History of entered face names.")
1653
1654 (defun widget-face-action (widget &optional event)
1655   "Prompt for a face."
1656   (let ((answer (completing-read "Face: "
1657                                  (mapcar (lambda (face)
1658                                            (list (symbol-name face)))
1659                                          (face-list))
1660                                  nil nil nil
1661                                  'face-history)))
1662     (unless (zerop (length answer))
1663       (widget-value-set widget (intern answer))
1664       (widget-apply widget :notify widget event)
1665       (widget-setup))))
1666
1667 ;;; The `hook' Widget.
1668
1669 (define-widget 'hook 'list
1670   "A emacs lisp hook"
1671   :convert-widget 'custom-hook-convert-widget
1672   :tag "Hook")
1673
1674 (defun custom-hook-convert-widget (widget)
1675   ;; Handle `:custom-options'.
1676   (let* ((options (widget-get widget :options))
1677          (other `(editable-list :inline t
1678                                 :entry-format "%i %d%v"
1679                                 (function :format " %v")))
1680          (args (if options
1681                    (list `(checklist :inline t
1682                                      ,@(mapcar (lambda (entry)
1683                                                  `(function-item ,entry))
1684                                                options))
1685                          other)
1686                  (list other))))
1687     (widget-put widget :args args)
1688     widget))
1689
1690 ;;; The `custom-group' Widget.
1691
1692 (defcustom custom-group-tag-faces '(custom-group-tag-face-1)
1693   ;; In XEmacs, this ought to play games with font size.
1694   "Face used for group tags.
1695 The first member is used for level 1 groups, the second for level 2,
1696 and so forth.  The remaining group tags are shown with
1697 `custom-group-tag-face'."
1698   :type '(repeat face)
1699   :group 'custom-faces)
1700
1701 (defface custom-group-tag-face-1 '((((class color)
1702                                      (background dark))
1703                                     (:foreground "pink" :underline t))
1704                                    (((class color)
1705                                      (background light))
1706                                     (:foreground "red" :underline t))
1707                                    (t (:underline t)))
1708   "Face used for group tags.")
1709
1710 (defface custom-group-tag-face '((((class color)
1711                                    (background dark))
1712                                   (:foreground "light blue" :underline t))
1713                                  (((class color)
1714                                    (background light))
1715                                   (:foreground "blue" :underline t))
1716                                  (t (:underline t)))
1717   "Face used for low level group tags."
1718   :group 'custom-faces)
1719
1720 (define-widget 'custom-group 'custom
1721   "Customize group."
1722   :format "%l%{%t%}:%L\n%m%h%a%v"
1723   :sample-face-get 'custom-group-sample-face-get
1724   :documentation-property 'group-documentation
1725   :help-echo "Set or reset all members of this group."
1726   :value-create 'custom-group-value-create
1727   :action 'custom-group-action
1728   :custom-set 'custom-group-set
1729   :custom-save 'custom-group-save
1730   :custom-reset-current 'custom-group-reset-current
1731   :custom-reset-saved 'custom-group-reset-saved
1732   :custom-reset-factory 'custom-group-reset-factory
1733   :custom-menu 'custom-group-menu-create)
1734
1735 (defun custom-group-sample-face-get (widget)
1736   ;; Use :sample-face.
1737   (or (nth (1- (widget-get widget :custom-level)) custom-group-tag-faces)
1738       'custom-group-tag-face))
1739
1740 (defun custom-group-value-create (widget)
1741   (let ((state (widget-get widget :custom-state)))
1742     (unless (eq state 'hidden)
1743       (message "Creating group...")
1744       (custom-load-widget widget)
1745       (let* ((level (widget-get widget :custom-level))
1746              (symbol (widget-value widget))
1747              (members (get symbol 'custom-group))
1748              (prefixes (widget-get widget :custom-prefixes))
1749              (custom-prefix-list (custom-prefix-add symbol prefixes))
1750              (length (length members))
1751              (count 0)
1752              (children (mapcar (lambda (entry)
1753                                  (widget-insert "\n")
1754                                  (message "Creating group members... %2d%%"
1755                                           (/ (* 100.0 count) length))
1756                                  (setq count (1+ count))
1757                                  (prog1
1758                                      (widget-create-child-and-convert
1759                                       widget (nth 1 entry)
1760                                       :group widget
1761                                       :tag (custom-unlispify-tag-name
1762                                             (nth 0 entry))
1763                                       :custom-prefixes custom-prefix-list
1764                                       :custom-level (1+ level)
1765                                       :value (nth 0 entry))
1766                                    (unless (eq (preceding-char) ?\n)
1767                                      (widget-insert "\n"))))
1768                                members)))
1769         (message "Creating group magic...")
1770         (mapcar 'custom-magic-reset children)
1771         (message "Creating group state...")
1772         (widget-put widget :children children)
1773         (custom-group-state-update widget)
1774         (message "Creating group... done")))))
1775
1776 (defvar custom-group-menu
1777   '(("Set" . custom-group-set)
1778     ("Save" . custom-group-save)
1779     ("Reset to Current" . custom-group-reset-current)
1780     ("Reset to Saved" . custom-group-reset-saved)
1781     ("Reset to Factory" . custom-group-reset-factory))
1782   "Alist of actions for the `custom-group' widget.
1783 The key is a string containing the name of the action, the value is a
1784 lisp function taking the widget as an element which will be called
1785 when the action is chosen.")
1786
1787 (defun custom-group-action (widget &optional event)
1788   "Show the menu for `custom-group' WIDGET.
1789 Optional EVENT is the location for the menu."
1790   (if (eq (widget-get widget :custom-state) 'hidden)
1791       (progn
1792         (widget-put widget :custom-state 'unknown)
1793         (custom-redraw widget))
1794     (let* ((completion-ignore-case t)
1795            (answer (widget-choose (custom-unlispify-tag-name
1796                                    (widget-get widget :value))
1797                                   custom-group-menu
1798                                   event)))
1799       (if answer
1800           (funcall answer widget)))))
1801
1802 (defun custom-group-set (widget)
1803   "Set changes in all modified group members."
1804   (let ((children (widget-get widget :children)))
1805     (mapcar (lambda (child)
1806               (when (eq (widget-get child :custom-state) 'modified)
1807                 (widget-apply child :custom-set)))
1808             children )))
1809
1810 (defun custom-group-save (widget)
1811   "Save all modified group members."
1812   (let ((children (widget-get widget :children)))
1813     (mapcar (lambda (child)
1814               (when (memq (widget-get child :custom-state) '(modified set))
1815                 (widget-apply child :custom-save)))
1816             children )))
1817
1818 (defun custom-group-reset-current (widget)
1819   "Reset all modified group members."
1820   (let ((children (widget-get widget :children)))
1821     (mapcar (lambda (child)
1822               (when (eq (widget-get child :custom-state) 'modified)
1823                 (widget-apply child :custom-reset-current)))
1824             children )))
1825
1826 (defun custom-group-reset-saved (widget)
1827   "Reset all modified or set group members."
1828   (let ((children (widget-get widget :children)))
1829     (mapcar (lambda (child)
1830               (when (memq (widget-get child :custom-state) '(modified set))
1831                 (widget-apply child :custom-reset-saved)))
1832             children )))
1833
1834 (defun custom-group-reset-factory (widget)
1835   "Reset all modified, set, or saved group members."
1836   (let ((children (widget-get widget :children)))
1837     (mapcar (lambda (child)
1838               (when (memq (widget-get child :custom-state)
1839                           '(modified set saved))
1840                 (widget-apply child :custom-reset-factory)))
1841             children )))
1842
1843 (defun custom-group-state-update (widget)
1844   "Update magic."
1845   (unless (eq (widget-get widget :custom-state) 'hidden)
1846     (let* ((children (widget-get widget :children))
1847            (states (mapcar (lambda (child)
1848                              (widget-get child :custom-state))
1849                            children))
1850            (magics custom-magic-alist)
1851            (found 'factory))
1852       (while magics
1853         (let ((magic (car (car magics))))
1854           (if (and (not (eq magic 'hidden))
1855                    (memq magic states))
1856               (setq found magic
1857                     magics nil)
1858             (setq magics (cdr magics)))))
1859       (widget-put widget :custom-state found)))
1860   (custom-magic-reset widget))
1861
1862 ;;; The `custom-save-all' Function.
1863
1864 (defcustom custom-file "~/.emacs"
1865   "File used for storing customization information.
1866 If you change this from the default \"~/.emacs\" you need to
1867 explicitly load that file for the settings to take effect."
1868   :type 'file
1869   :group 'customize)
1870
1871 (defun custom-save-delete (symbol)
1872   "Delete the call to SYMBOL form `custom-file'.
1873 Leave point at the location of the call, or after the last expression."
1874   (set-buffer (find-file-noselect custom-file))
1875   (goto-char (point-min))
1876   (catch 'found
1877     (while t
1878       (let ((sexp (condition-case nil
1879                       (read (current-buffer))
1880                     (end-of-file (throw 'found nil)))))
1881         (when (and (listp sexp)
1882                    (eq (car sexp) symbol))
1883           (delete-region (save-excursion
1884                            (backward-sexp)
1885                            (point))
1886                          (point))
1887           (throw 'found nil))))))
1888
1889 (defun custom-save-variables ()
1890   "Save all customized variables in `custom-file'."
1891   (save-excursion
1892     (custom-save-delete 'custom-set-variables)
1893     (let ((standard-output (current-buffer)))
1894       (unless (bolp)
1895         (princ "\n"))
1896       (princ "(custom-set-variables")
1897       (mapatoms (lambda (symbol)
1898                   (let ((value (get symbol 'saved-value)))
1899                     (when value
1900                       (princ "\n '(")
1901                       (princ symbol)
1902                       (princ " ")
1903                       (prin1 (car value))
1904                       (if (or (get symbol 'factory-value)
1905                               (and (not (boundp symbol))
1906                                    (not (get symbol 'force-value))))
1907                           (princ ")")
1908                         (princ " t)"))))))
1909       (princ ")")
1910       (unless (looking-at "\n")
1911         (princ "\n")))))
1912
1913 (defun custom-save-faces ()
1914   "Save all customized faces in `custom-file'."
1915   (save-excursion
1916     (custom-save-delete 'custom-set-faces)
1917     (let ((standard-output (current-buffer)))
1918       (unless (bolp)
1919         (princ "\n"))
1920       (princ "(custom-set-faces")
1921       (let ((value (get 'default 'saved-face)))
1922         ;; The default face must be first, since it affects the others.
1923         (when value
1924           (princ "\n '(default ")
1925           (prin1 value)
1926           (if (or (get 'default 'factory-face)
1927                   (and (not (custom-facep 'default))
1928                        (not (get 'default 'force-face))))
1929               (princ ")")
1930             (princ " t)"))))
1931       (mapatoms (lambda (symbol)
1932                   (let ((value (get symbol 'saved-face)))
1933                     (when (and (not (eq symbol 'default))
1934                                ;; Don't print default face here.
1935                                value)
1936                       (princ "\n '(")
1937                       (princ symbol)
1938                       (princ " ")
1939                       (prin1 value)
1940                       (if (or (get symbol 'factory-face)
1941                               (and (not (custom-facep symbol))
1942                                    (not (get symbol 'force-face))))
1943                           (princ ")")
1944                         (princ " t)"))))))
1945       (princ ")")
1946       (unless (looking-at "\n")
1947         (princ "\n")))))
1948
1949 ;;;###autoload
1950 (defun custom-save-all ()
1951   "Save all customizations in `custom-file'."
1952   (custom-save-variables)
1953   (custom-save-faces)
1954   (save-excursion
1955     (set-buffer (find-file-noselect custom-file))
1956     (save-buffer)))
1957
1958 ;;; The Customize Menu.
1959
1960 ;;; Menu support
1961
1962 (unless (string-match "XEmacs" emacs-version)
1963   (defconst custom-help-menu '("Customize"
1964                                ["Update menu..." custom-menu-update t]
1965                                ["Group..." customize t]
1966                                ["Variable..." customize-variable t]
1967                                ["Face..." customize-face t]
1968                                ["Saved..." customize-customized t]
1969                                ["Apropos..." customize-apropos t])
1970     ;; This menu should be identical to the one defined in `menu-bar.el'.
1971     "Customize menu")
1972
1973   (defun custom-menu-reset ()
1974     "Reset customize menu."
1975     (remove-hook 'custom-define-hook 'custom-menu-reset)
1976     (define-key global-map [menu-bar help-menu customize-menu]
1977       (cons (car custom-help-menu)
1978             (easy-menu-create-keymaps (car custom-help-menu)
1979                                       (cdr custom-help-menu)))))
1980
1981   (defun custom-menu-update (event)
1982     "Update customize menu."
1983     (interactive "e")
1984     (add-hook 'custom-define-hook 'custom-menu-reset)
1985     (let* ((emacs (widget-apply '(custom-group) :custom-menu 'emacs))
1986            (menu `(,(car custom-help-menu)
1987                    ,emacs
1988                    ,@(cdr (cdr custom-help-menu)))))
1989       (let ((map (easy-menu-create-keymaps (car menu) (cdr menu))))
1990         (define-key global-map [menu-bar help-menu customize-menu]
1991           (cons (car menu) map)))))
1992
1993   (defcustom custom-menu-nesting 2
1994     "Maximum nesting in custom menus."
1995     :type 'integer
1996     :group 'customize))
1997
1998 (defun custom-face-menu-create (widget symbol)
1999   "Ignoring WIDGET, create a menu entry for customization face SYMBOL."
2000   (vector (custom-unlispify-menu-entry symbol)
2001           `(custom-buffer-create '((,symbol custom-face)))
2002           t))
2003
2004 (defun custom-variable-menu-create (widget symbol)
2005   "Ignoring WIDGET, create a menu entry for customization variable SYMBOL."
2006   (let ((type (get symbol 'custom-type)))
2007     (unless (listp type)
2008       (setq type (list type)))
2009     (if (and type (widget-get type :custom-menu))
2010         (widget-apply type :custom-menu symbol)
2011       (vector (custom-unlispify-menu-entry symbol)
2012               `(custom-buffer-create '((,symbol custom-variable)))
2013               t))))
2014
2015 ;; Add checkboxes to boolean variable entries.
2016 (widget-put (get 'boolean 'widget-type)
2017             :custom-menu (lambda (widget symbol)
2018                            (vector (custom-unlispify-menu-entry symbol)
2019                                    `(custom-buffer-create
2020                                      '((,symbol custom-variable)))
2021                                    ':style 'toggle
2022                                    ':selected symbol)))
2023
2024 (if (string-match "XEmacs" emacs-version)
2025     ;; XEmacs can create menus dynamically.
2026     (defun custom-group-menu-create (widget symbol)
2027       "Ignoring WIDGET, create a menu entry for customization group SYMBOL."
2028       `( ,(custom-unlispify-menu-entry symbol t)
2029          :filter (lambda (&rest junk)
2030                    (cdr (custom-menu-create ',symbol)))))
2031   ;; But emacs can't.
2032   (defun custom-group-menu-create (widget symbol)
2033     "Ignoring WIDGET, create a menu entry for customization group SYMBOL."
2034     ;; Limit the nesting.
2035     (let ((custom-menu-nesting (1- custom-menu-nesting)))
2036       (custom-menu-create symbol))))
2037
2038 ;;;###autoload
2039 (defun custom-menu-create (symbol &optional name)
2040   "Create menu for customization group SYMBOL.
2041 If optional NAME is given, use that as the name of the menu.
2042 Otherwise make up a name from SYMBOL.
2043 The menu is in a format applicable to `easy-menu-define'."
2044   (unless name
2045     (setq name (custom-unlispify-menu-entry symbol)))
2046   (let ((item (vector name
2047                       `(custom-buffer-create '((,symbol custom-group)))
2048                       t)))
2049     (if (and (or (not (boundp 'custom-menu-nesting))
2050                  (>= custom-menu-nesting 0))
2051              (< (length (get symbol 'custom-group)) widget-menu-max-size))
2052         (let ((custom-prefix-list (custom-prefix-add symbol
2053                                                      custom-prefix-list)))
2054           (custom-load-symbol symbol)
2055           `(,(custom-unlispify-menu-entry symbol t)
2056             ,item
2057             "--"
2058             ,@(mapcar (lambda (entry)
2059                         (widget-apply (if (listp (nth 1 entry))
2060                                           (nth 1 entry)
2061                                         (list (nth 1 entry)))
2062                                       :custom-menu (nth 0 entry)))
2063                       (get symbol 'custom-group))))
2064       item)))
2065
2066 ;;;###autoload
2067 (defun customize-menu-create (symbol)
2068   "Return a customize menu for customization group SYMBOL.
2069 The format is suitable for use with `easy-menu-define'."
2070   (if (string-match "XEmacs" emacs-version)
2071       ;; We can delay it under XEmacs.
2072       `("Customize"
2073         :filter (lambda (&rest junk)
2074                   (cdr (custom-menu-create ',symbol))))
2075     ;; But we must create it now under Emacs.
2076     (cons "Customize" (cdr (custom-menu-create symbol)))))
2077
2078 ;;; The Custom Mode.
2079
2080 (defvar custom-mode-map nil
2081   "Keymap for `custom-mode'.")
2082
2083 (unless custom-mode-map
2084   (setq custom-mode-map (make-sparse-keymap))
2085   (set-keymap-parent custom-mode-map widget-keymap)
2086   (define-key custom-mode-map "q" 'bury-buffer))
2087
2088 (easy-menu-define custom-mode-customize-menu
2089     custom-mode-map
2090   "Menu used in customization buffers."
2091   (customize-menu-create 'customize))
2092
2093 (easy-menu-define custom-mode-menu
2094     custom-mode-map
2095   "Menu used in customization buffers."
2096   `("Custom"
2097     ["Set" custom-set t]
2098     ["Save" custom-save t]
2099     ["Reset to Current" custom-reset-current t]
2100     ["Reset to Saved" custom-reset-saved t]
2101     ["Reset to Factory Settings" custom-reset-factory t]
2102     ["Info" (Info-goto-node "(custom)The Customization Buffer") t]))
2103
2104 (defcustom custom-mode-hook nil
2105   "Hook called when entering custom-mode."
2106   :type 'hook
2107   :group 'customize)
2108
2109 (defun custom-mode ()
2110   "Major mode for editing customization buffers.
2111
2112 The following commands are available:
2113
2114 Move to next button or editable field.     \\[widget-forward]
2115 Move to previous button or editable field. \\[widget-backward]
2116 Activate button under the mouse pointer.   \\[widget-button-click]
2117 Activate button under point.               \\[widget-button-press]
2118 Set all modifications.                     \\[custom-set]
2119 Make all modifications default.            \\[custom-save]
2120 Reset all modified options.                \\[custom-reset-current]
2121 Reset all modified or set options.         \\[custom-reset-saved]
2122 Reset all options.                         \\[custom-reset-factory]
2123
2124 Entry to this mode calls the value of `custom-mode-hook'
2125 if that value is non-nil."
2126   (kill-all-local-variables)
2127   (setq major-mode 'custom-mode
2128         mode-name "Custom")
2129   (use-local-map custom-mode-map)
2130   (easy-menu-add custom-mode-customize-menu)
2131   (easy-menu-add custom-mode-menu)
2132   (make-local-variable 'custom-options)
2133   (run-hooks 'custom-mode-hook))
2134
2135 ;;; The End.
2136
2137 (provide 'cus-edit)
2138
2139 ;; cus-edit.el ends here