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

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