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