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

   1 ;;; custom-edit.el --- Tools for customization Emacs.
   2 ;;
   3 ;; Copyright (C) 1996 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
   6 ;; Keywords: help, faces
   7 ;; Version: 1.15
   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 'widget-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)
  23
  24 ;;; Utilities.
  25
  26 (defun custom-quote (sexp)
  27   "Quote SEXP iff it is not self quoting."
  28   (if (or (memq sexp '(t nil))
  29           (and (symbolp sexp)
  30                (eq (aref (symbol-name sexp) 0) ?:))
  31           (and (listp sexp)
  32                (memq (car sexp) '(lambda)))
  33           (stringp sexp)
  34           (numberp sexp))
  35       sexp
  36     (list 'quote sexp)))
  37
  38 (defun custom-split-regexp-maybe (regexp)
  39   "If REGEXP is a string, split it to a list at `\\|'.
  40 You can get the original back with from the result with:
  41   (mapconcat 'identity result \"\\|\")
  42
  43 IF REGEXP is not a string, return it unchanged."
  44   (if (stringp regexp)
  45       (let ((start 0)
  46             all)
  47         (while (string-match "\\\\|" regexp start)
  48           (setq all (cons (substring regexp start (match-beginning 0)) all)
  49                 start (match-end 0)))
  50         (nreverse (cons (substring regexp start) all)))
  51     regexp))
  52
  53 (defvar custom-prefix-list nil
  54   "List of prefixes that should be ignored by `custom-unlispify'")
  55
  56 (defcustom custom-unlispify-menu-entries t
  57   "Display menu entries as words instead of symbols if non nil."
  58   :group 'customize
  59   :type 'boolean)
  60
  61 (defun custom-unlispify-menu-entry (symbol &optional no-suffix)
  62   "Convert symbol into a menu entry."
  63   (cond ((not custom-unlispify-menu-entries)
  64          (symbol-name symbol))
  65         ((get symbol 'custom-tag)
  66          (if no-suffix
  67              (get symbol 'custom-tag)
  68            (concat (get symbol 'custom-tag) "...")))
  69         (t
  70          (save-excursion
  71            (set-buffer (get-buffer-create " *Custom-Work*"))
  72            (erase-buffer)
  73            (princ symbol (current-buffer))
  74            (goto-char (point-min))
  75            (let ((prefixes custom-prefix-list)
  76                  prefix)
  77              (while prefixes
  78                (setq prefix (car prefixes))
  79                (if (search-forward prefix (+ (point) (length prefix)) t)
  80                    (progn
  81                      (setq prefixes nil)
  82                      (delete-region (point-min) (point)))
  83                  (setq prefixes (cdr prefixes)))))
  84            (subst-char-in-region (point-min) (point-max) ?- ?\  t)
  85            (capitalize-region (point-min) (point-max))
  86            (unless no-suffix
  87              (goto-char (point-max))
  88              (insert "..."))
  89            (buffer-string)))))
  90
  91 (defcustom custom-unlispify-tag-names t
  92   "Display tag names as words instead of symbols if non nil."
  93   :group 'customize
  94   :type 'boolean)
  95
  96 (defun custom-unlispify-tag-name (symbol)
  97   "Convert symbol into a menu entry."
  98   (let ((custom-unlispify-menu-entries custom-unlispify-tag-names))
  99     (custom-unlispify-menu-entry symbol t)))
 100
 101 (defun custom-prefix-add (symbol prefixes)
 102   ;; Addd SYMBOL to list of ignored PREFIXES.
 103   (cons (or (get symbol 'custom-prefix)
 104             (concat (symbol-name symbol) "-"))
 105         prefixes))
 106
 107 ;;; The Custom Mode.
 108
 109 (defvar custom-options nil
 110   "Customization widgets in the current buffer.")
 111
 112 (defvar custom-mode-map nil
 113   "Keymap for `custom-mode'.")
 114
 115 (unless custom-mode-map
 116   (setq custom-mode-map (make-sparse-keymap))
 117   (set-keymap-parent custom-mode-map widget-keymap))
 118
 119 (easy-menu-define custom-mode-menu
 120     custom-mode-map
 121   "Menu used in customization buffers."
 122     '("Custom"
 123       ["Set" custom-set t]
 124       ["Save" custom-save t]
 125       ["Reset" custom-reset t]
 126       ["Info" (Info-goto-node "(custom)The Customization Buffer") t]))
 127
 128 (defcustom custom-mode-hook nil
 129   "Hook called when entering custom-mode."
 130   :type 'hook
 131   :group 'customize)
 132
 133 (defun custom-mode ()
 134   "Major mode for editing customization buffers.
 135
 136 The following commands are available:
 137
 138 \\[widget-forward]              Move to next button or editable field.
 139 \\[widget-backward]             Move to previous button or editable field.
 140 \\[widget-button-click]         Activate button under the mouse pointer.
 141 \\[widget-button-press]         Activate button under point.
 142 \\[custom-set]                  Set all modifications.
 143 \\[custom-save]         Make all modifications default.
 144 \\[custom-reset]                Undo all modifications.
 145
 146 Entry to this mode calls the value of `custom-mode-hook'
 147 if that value is non-nil."
 148   (kill-all-local-variables)
 149   (setq major-mode 'custom-mode
 150         mode-name "Custom")
 151   (use-local-map custom-mode-map)
 152   (make-local-variable 'custom-options)
 153   (run-hooks 'custom-mode-hook))
 154
 155 ;;; Custom Mode Commands.
 156
 157 (defun custom-set ()
 158   "Set changes in all modified options."
 159   (interactive)
 160   (let ((children custom-options))
 161     (mapcar (lambda (child)
 162               (when (eq (widget-get child :custom-state) 'modified)
 163                 (widget-apply child :custom-set)))
 164             children)))
 165
 166 (defun custom-save ()
 167   "Set all modified group members and save them."
 168   (interactive)
 169   (let ((children custom-options))
 170     (mapcar (lambda (child)
 171               (when (memq (widget-get child :custom-state) '(modified set))
 172                 (widget-apply child :custom-save)))
 173             children))
 174   (custom-save-all))
 175
 176 (defun custom-reset ()
 177   "Reset all modified group members."
 178   (interactive)
 179   (let ((children custom-options))
 180     (mapcar (lambda (child)
 181               (when (eq (widget-get child :custom-state) 'modified)
 182                 (widget-apply child :custom-reset)))
 183             children)))
 184
 185 ;;; The Customize Commands
 186
 187 ;;;###autoload
 188 (defun customize (symbol)
 189   "Customize SYMBOL, which must be a customization group."
 190   (interactive (list (completing-read "Customize group: (default emacs) "
 191                                       obarray
 192                                       (lambda (symbol)
 193                                         (get symbol 'custom-group))
 194                                       t)))
 195
 196   (when (stringp symbol)
 197     (if (string-equal "" symbol)
 198         (setq symbol 'emacs)
 199       (setq symbol (intern symbol))))
 200   (custom-buffer-create (list (list symbol 'custom-group))))
 201
 202 ;;;###autoload
 203 (defun customize-variable (symbol)
 204   "Customize SYMBOL, which must be a variable."
 205   (interactive
 206    ;; Code stolen from `help.el'.
 207    (let ((v (variable-at-point))
 208          (enable-recursive-minibuffers t)
 209          val)
 210      (setq val (completing-read
 211                 (if v
 212                     (format "Customize variable (default %s): " v)
 213                   "Customize variable: ")
 214                 obarray 'boundp t))
 215      (list (if (equal val "")
 216                v (intern val)))))
 217   (custom-buffer-create (list (list symbol 'custom-variable))))
 218
 219 ;;;###autoload
 220 (defun customize-face (symbol)
 221   "Customize FACE."
 222   (interactive (list (completing-read "Customize face: "
 223                                       obarray 'custom-facep)))
 224   (if (stringp symbol)
 225       (setq symbol (intern symbol)))
 226   (unless (symbolp symbol)
 227     (error "Should be a symbol %S" symbol))
 228   (custom-buffer-create (list (list symbol 'custom-face))))
 229
 230 ;;;###autoload
 231 (defun customize-customized ()
 232   "Customize all already customized user options."
 233   (interactive)
 234   (let ((found nil))
 235     (mapatoms (lambda (symbol)
 236                 (and (get symbol 'saved-face)
 237                      (custom-facep symbol)
 238                      (setq found (cons (list symbol 'custom-face) found)))
 239                 (and (get symbol 'saved-value)
 240                      (boundp symbol)
 241                      (setq found
 242                            (cons (list symbol 'custom-variable) found)))))
 243     (if found
 244         (custom-buffer-create found)
 245       (error "No customized user options"))))
 246
 247 ;;;###autoload
 248 (defun customize-apropos (regexp &optional all)
 249   "Customize all user options matching REGEXP.
 250 If ALL (e.g., started with a prefix key), include options which are not
 251 user-settable."
 252   (interactive "sCustomize regexp: \nP")
 253   (let ((found nil))
 254     (mapatoms (lambda (symbol)
 255                 (when (string-match regexp (symbol-name symbol))
 256                   (when (get symbol 'custom-group)
 257                     (setq found (cons (list symbol 'custom-group) found)))
 258                   (when (custom-facep symbol)
 259                     (setq found (cons (list symbol 'custom-face) found)))
 260                   (when (and (boundp symbol)
 261                              (or (get symbol 'saved-value)
 262                                  (get symbol 'factory-value)
 263                                  (if all
 264                                      (get symbol 'variable-documentation)
 265                                    (user-variable-p symbol))))
 266                     (setq found
 267                           (cons (list symbol 'custom-variable) found))))))
 268     (if found
 269         (custom-buffer-create found)
 270       (error "No matches"))))
 271
 272 ;;;###autoload
 273 (defun custom-buffer-create (options)
 274   "Create a buffer containing OPTIONS.
 275 OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where
 276 SYMBOL is a customization option, and WIDGET is a widget for editing
 277 that option."
 278   (kill-buffer (get-buffer-create "*Customization*"))
 279   (switch-to-buffer (get-buffer-create "*Customization*"))
 280   (custom-mode)
 281   (widget-insert "This is a customization buffer.
 282 Push RET or click mouse-2 on the word ")
 283   (widget-create 'info-link
 284                  :tag "help"
 285                  :help-echo "Push me for help."
 286                  "(custom)The Customization Buffer")
 287   (widget-insert " for more information.\n\n")
 288   (setq custom-options
 289         (mapcar (lambda (entry)
 290                   (prog1
 291                       (if (> (length options) 1)
 292                           (widget-create (nth 1 entry)
 293                                          :tag (custom-unlispify-tag-name
 294                                                (nth 0 entry))
 295                                          :value (nth 0 entry))
 296                         ;; If there is only one entry, don't hide it!
 297                         (widget-create (nth 1 entry)
 298                                        :custom-state 'unknown
 299                                        :tag (custom-unlispify-tag-name
 300                                                (nth 0 entry))
 301                                        :value (nth 0 entry)))
 302                     (unless (eq (preceding-char) ?\n)
 303                       (widget-insert "\n"))
 304                     (widget-insert "\n")))
 305                 options))
 306   (mapcar 'custom-magic-reset custom-options)
 307   (widget-create 'push-button
 308                  :tag "Set"
 309                  :help-echo "Push me to set all modifications."
 310                  :action (lambda (widget &optional event)
 311                            (custom-set)))
 312   (widget-insert " ")
 313   (widget-create 'push-button
 314                  :tag "Save"
 315                  :help-echo "Push me to make the modifications default."
 316                  :action (lambda (widget &optional event)
 317                            (custom-save)))
 318   (widget-insert " ")
 319   (widget-create 'push-button
 320                  :tag "Reset"
 321                  :help-echo "Push me to undo all modifications.."
 322                  :action (lambda (widget &optional event)
 323                            (custom-reset)))
 324   (widget-insert "\n")
 325   (widget-setup))
 326
 327 ;;; Modification of Basic Widgets.
 328 ;;
 329 ;; We add extra properties to the basic widgets needed here.  This is
 330 ;; fine, as long as we are careful to stay within out own namespace.
 331 ;;
 332 ;; We want simple widgets to be displayed by default, but complex
 333 ;; widgets to be hidden.
 334
 335 (widget-put (get 'item 'widget-type) :custom-show t)
 336 (widget-put (get 'editable-field 'widget-type)
 337             :custom-show (lambda (widget value)
 338                            (let ((pp (pp-to-string value)))
 339                              (cond ((string-match "\n" pp)
 340                                     nil)
 341                                    ((> (length pp) 40)
 342                                     nil)
 343                                    (t t)))))
 344 (widget-put (get 'menu-choice 'widget-type) :custom-show t)
 345
 346 ;;; The `custom-manual' Widget.
 347
 348 (define-widget 'custom-manual 'info-link
 349   "Link to the manual entry for this customization option."
 350   :tag "Manual")
 351
 352 ;;; The `custom-magic' Widget.
 353
 354 (defface custom-invalid-face '((((class color))
 355                                 (:foreground "yellow" :background "red"))
 356                                (t
 357                                 (:bold t :italic t :underline t)))
 358   "Face used when the customize item is invalid.")
 359
 360 (defface custom-rogue-face '((((class color))
 361                               (:foreground "pink" :background "black"))
 362                              (t
 363                               (:underline t)))
 364   "Face used when the customize item is not defined for customization.")
 365
 366 (defface custom-modified-face '((((class color))
 367                                  (:foreground "white" :background "blue"))
 368                                 (t
 369                                  (:italic t :bold)))
 370   "Face used when the customize item has been modified.")
 371
 372 (defface custom-set-face '((((class color))
 373                                 (:foreground "blue" :background "white"))
 374                                (t
 375                                 (:italic t)))
 376   "Face used when the customize item has been set.")
 377
 378 (defface custom-changed-face '((((class color))
 379                                 (:foreground "white" :background "blue"))
 380                                (t
 381                                 (:italic t)))
 382   "Face used when the customize item has been changed.")
 383
 384 (defface custom-saved-face '((t (:underline t)))
 385   "Face used when the customize item has been saved.")
 386
 387 (defcustom custom-magic-alist '((nil "#" underline "\
 388 uninitialized, you should not see this.")
 389                                 (unknown "?" italic "\
 390 unknown, you should not see this.")
 391                                 (hidden "-" default "\
 392 hidden, press the stars `*' on the line above to show.")
 393                                 (invalid "x" custom-invalid-face "\
 394 the value displayed for this item is invalid and cannot be set.")
 395                                 (modified "*" custom-modified-face "\
 396 you have edited the item, and can now set it.")
 397                                 (set "+" custom-set-face "\
 398 you have set this item, but not saved it.")
 399                                 (changed ":" custom-changed-face "\
 400 this item has been changed outside customize.")
 401                                 (saved "!" custom-saved-face "\
 402 this item has been saved.")
 403                                 (rogue "@" custom-rogue-face "\
 404 this item is not prepared for customization.")
 405                                 (factory " " nil "\
 406 this item is unchanged from its factory setting."))
 407   "Alist of customize option states.
 408 Each entry is of the form (STATE MAGIC FACE DESCRIPTION), where
 409
 410 STATE is one of the following symbols:
 411
 412 `nil'
 413    For internal use, should never occur.
 414 `unknown'
 415    For internal use, should never occur.
 416 `hidden'
 417    This item is not being displayed.
 418 `invalid'
 419    This item is modified, but has an invalid form.
 420 `modified'
 421    This item is modified, and has a valid form.
 422 `set'
 423    This item has been set but not saved.
 424 `changed'
 425    The current value of this item has been changed temporarily.
 426 `saved'
 427    This item is marked for saving.
 428 `rogue'
 429    This item has no customization information.
 430 `factory'
 431    This item is unchanged from the factory default.
 432
 433 MAGIC is a string used to present that state.
 434
 435 FACE is a face used to present the state.
 436
 437 DESCRIPTION is a string describing the state.
 438
 439 The list should be sorted most significant first."
 440   :type '(list (checklist :inline t
 441                           (group (const nil)
 442                                  (string :tag "Magic")
 443                                  face
 444                                  (string :tag "Description"))
 445                           (group (const unknown)
 446                                  (string :tag "Magic")
 447                                  face
 448                                  (string :tag "Description"))
 449                           (group (const hidden)
 450                                  (string :tag "Magic")
 451                                  face
 452                                  (string :tag "Description"))
 453                           (group (const invalid)
 454                                  (string :tag "Magic")
 455                                  face
 456                                  (string :tag "Description"))
 457                           (group (const modified)
 458                                  (string :tag "Magic")
 459                                  face
 460                                  (string :tag "Description"))
 461                           (group (const set)
 462                                  (string :tag "Magic")
 463                                  face
 464                                  (string :tag "Description"))
 465                           (group (const changed)
 466                                  (string :tag "Magic")
 467                                  face
 468                                  (string :tag "Description"))
 469                           (group (const saved)
 470                                  (string :tag "Magic")
 471                                  face
 472                                  (string :tag "Description"))
 473                           (group (const rogue)
 474                                  (string :tag "Magic")
 475                                  face
 476                                  (string :tag "Description"))
 477                           (group (const factory)
 478                                  (string :tag "Magic")
 479                                  face
 480                                  (string :tag "Description")))
 481                (editable-list :inline t
 482                               (group symbol
 483                                      (string :tag "Magic")
 484                                      face
 485                                      (string :tag "Description"))))
 486   :group 'customize)
 487
 488 (defcustom custom-magic-show 'long
 489   "Show long description of the state of each customization option."
 490   :type '(choice (const :tag "no" nil)
 491                  (const short)
 492                  (const long))
 493   :group 'customize)
 494
 495 (defcustom custom-magic-show-button t
 496   "Show a magic button indicating the state of each customization option."
 497   :type 'boolean
 498   :group 'customize)
 499
 500 (define-widget 'custom-magic 'default
 501   "Show and manipulate state for a customization option."
 502   :format "%v"
 503   :action 'widget-choice-item-action
 504   :value-get 'ignore
 505   :value-create 'custom-magic-value-create
 506   :value-delete 'widget-children-value-delete)
 507
 508 (defun custom-magic-value-create (widget)
 509   ;; Create compact status report for WIDGET.
 510   (let* ((parent (widget-get widget :parent))
 511          (state (widget-get parent :custom-state))
 512          (entry (assq state custom-magic-alist))
 513          (magic (nth 1 entry))
 514          (face (nth 2 entry))
 515          (text (nth 3 entry))
 516          (lisp (eq (widget-get parent :custom-form) 'lisp))
 517          children)
 518     (when custom-magic-show
 519       (push (widget-create-child-and-convert widget 'choice-item
 520                                              :format "%[%t%]"
 521                                              :tag "State")
 522             children)
 523       (insert ": ")
 524       (if (eq custom-magic-show 'long)
 525           (insert text)
 526         (insert (symbol-name state)))
 527       (when lisp
 528         (insert " (lisp)"))
 529       (insert "\n"))
 530     (when custom-magic-show-button
 531       (when custom-magic-show
 532         (let ((indent (widget-get parent :indent)))
 533           (when indent
 534             (insert-char ?  indent))))
 535       (push (widget-create-child-and-convert widget 'choice-item
 536                                              :button-face face
 537                                              :format "%[%t%]"
 538                                              :tag (if lisp
 539                                                       (concat "(" magic ")")
 540                                                     (concat "[" magic "]")))
 541             children)
 542       (insert " "))
 543     (widget-put widget :children children)))
 544
 545 (defun custom-magic-reset (widget)
 546   "Redraw the :custom-magic property of WIDGET."
 547   (let ((magic (widget-get widget :custom-magic)))
 548     (widget-value-set magic (widget-value magic))))
 549
 550 ;;; The `custom-level' Widget.
 551
 552 (define-widget 'custom-level 'item
 553   "The custom level buttons."
 554   :format "%[%t%]"
 555   :help-echo "Push me to expand or collapse this item."
 556   :action 'custom-level-action)
 557
 558 (defun custom-level-action (widget &optional event)
 559   "Toggle visibility for parent to WIDGET."
 560   (let* ((parent (widget-get widget :parent))
 561          (state (widget-get parent :custom-state)))
 562     (cond ((memq state '(invalid modified))
 563            (error "There are unset changes"))
 564           ((eq state 'hidden)
 565            (widget-put parent :custom-state 'unknown))
 566           (t
 567            (widget-put parent :custom-state 'hidden)))
 568     (custom-redraw parent)))
 569
 570 ;;; The `custom' Widget.
 571
 572 (define-widget 'custom 'default
 573   "Customize a user option."
 574   :convert-widget 'custom-convert-widget
 575   :format "%l%[%t%]: %v%m%h%a"
 576   :format-handler 'custom-format-handler
 577   :notify 'custom-notify
 578   :custom-level 1
 579   :custom-state 'hidden
 580   :documentation-property 'widget-subclass-responsibility
 581   :value-create 'widget-subclass-responsibility
 582   :value-delete 'widget-children-value-delete
 583   :value-get 'widget-item-value-get
 584   :validate 'widget-editable-list-validate
 585   :match (lambda (widget value) (symbolp value)))
 586
 587 (defun custom-convert-widget (widget)
 588   ;; Initialize :value and :tag from :args in WIDGET.
 589   (let ((args (widget-get widget :args)))
 590     (when args
 591       (widget-put widget :value (widget-apply widget
 592                                               :value-to-internal (car args)))
 593       (widget-put widget :tag (custom-unlispify-tag-name (car args)))
 594       (widget-put widget :args nil)))
 595   widget)
 596
 597 (defun custom-format-handler (widget escape)
 598   ;; We recognize extra escape sequences.
 599   (let* ((buttons (widget-get widget :buttons))
 600          (state (widget-get widget :custom-state))
 601          (level (widget-get widget :custom-level)))
 602     (cond ((eq escape ?l)
 603            (when level
 604              (push (widget-create-child-and-convert
 605                     widget 'custom-level (make-string level ?*))
 606                    buttons)
 607              (widget-insert " ")
 608              (widget-put widget :buttons buttons)))
 609           ((eq escape ?L)
 610            (when (eq state 'hidden)
 611              (widget-insert " ...")))
 612           ((eq escape ?m)
 613            (and (eq (preceding-char) ?\n)
 614                 (widget-get widget :indent)
 615                 (insert-char ?  (widget-get widget :indent)))
 616            (let ((magic (widget-create-child-and-convert
 617                          widget 'custom-magic nil)))
 618              (widget-put widget :custom-magic magic)
 619              (push magic buttons)
 620              (widget-put widget :buttons buttons)))
 621           ((eq escape ?a)
 622            (let* ((symbol (widget-get widget :value))
 623                   (links (get symbol 'custom-links))
 624                   (many (> (length links) 2)))
 625              (when links
 626                (and (eq (preceding-char) ?\n)
 627                     (widget-get widget :indent)
 628                     (insert-char ?  (widget-get widget :indent)))
 629                (insert "See also ")
 630                (while links
 631                  (push (widget-create-child-and-convert widget (car links))
 632                        buttons)
 633                  (setq links (cdr links))
 634                  (cond ((null links)
 635                         (insert ".\n"))
 636                        ((null (cdr links))
 637                         (if many
 638                             (insert ", and ")
 639                           (insert " and ")))
 640                        (t
 641                         (insert ", "))))
 642                (widget-put widget :buttons buttons))))
 643           (t
 644            (widget-default-format-handler widget escape)))))
 645
 646 (defun custom-notify (widget &rest args)
 647   "Keep track of changes."
 648   (widget-put widget :custom-state 'modified)
 649   (let ((buffer-undo-list t))
 650     (custom-magic-reset widget))
 651   (apply 'widget-default-notify widget args))
 652
 653 (defun custom-redraw (widget)
 654   "Redraw WIDGET with current settings."
 655   (widget-value-set widget (widget-value widget))
 656   (custom-redraw-magic widget))
 657
 658 (defun custom-redraw-magic (widget)
 659   "Redraw WIDGET state with current settings."
 660   (while widget
 661     (let ((magic (widget-get widget :custom-magic)))
 662       (unless magic
 663         (debug))
 664       (widget-value-set magic (widget-value magic))
 665       (when (setq widget (widget-get widget :group))
 666         (custom-group-state-update widget))))
 667   (widget-setup))
 668
 669 (defun custom-show (widget value)
 670   "Non-nil if WIDGET should be shown with VALUE by default."
 671   (let ((show (widget-get widget :custom-show)))
 672     (cond ((null show)
 673            nil)
 674           ((eq t show)
 675            t)
 676           (t
 677            (funcall show widget value)))))
 678
 679 (defun custom-load-symbol (symbol)
 680   "Load all dependencies for SYMBOL."
 681   (let ((loads (get symbol 'custom-loads))
 682         load)
 683     (while loads
 684       (setq load (car loads)
 685             loads (cdr loads))
 686       (cond ((symbolp load)
 687              (require load))
 688             ((member load load-history))
 689             (t
 690              (load-library load))))))
 691
 692 (defun custom-load-widget (widget)
 693   "Load all dependencies for WIDGET."
 694   (custom-load-symbol (widget-value widget)))
 695
 696 ;;; The `custom-variable' Widget.
 697
 698 (define-widget 'custom-variable 'custom
 699   "Customize variable."
 700   :format "%l%v%m%h%a"
 701   :help-echo "Push me to set or reset this variable."
 702   :documentation-property 'variable-documentation
 703   :custom-state nil
 704   :custom-menu 'custom-variable-menu-create
 705   :custom-form 'edit
 706   :value-create 'custom-variable-value-create
 707   :action 'custom-variable-action
 708   :custom-set 'custom-variable-set
 709   :custom-save 'custom-variable-save
 710   :custom-reset 'custom-redraw)
 711
 712 (defun custom-variable-value-create (widget)
 713   "Here is where you edit the variables value."
 714   (custom-load-widget widget)
 715   (let* ((buttons (widget-get widget :buttons))
 716          (children (widget-get widget :children))
 717          (form (widget-get widget :custom-form))
 718          (state (widget-get widget :custom-state))
 719          (symbol (widget-get widget :value))
 720          (options (get symbol 'custom-options))
 721          (child-type (or (get symbol 'custom-type) 'sexp))
 722          (tag (widget-get widget :tag))
 723          (type (let ((tmp (if (listp child-type)
 724                               (copy-list child-type)
 725                             (list child-type))))
 726                  (when options
 727                    (widget-put tmp :options options))
 728                  tmp))
 729          (conv (widget-convert type))
 730          (value (if (default-boundp symbol)
 731                     (default-value symbol)
 732                   (widget-get conv :value))))
 733     ;; If the widget is new, the child determine whether it is hidden.
 734     (cond (state)
 735           ((custom-show type value)
 736            (setq state 'unknown))
 737           (t
 738            (setq state 'hidden)))
 739     ;; If we don't know the state, see if we need to edit it in lisp form.
 740     (when (eq state 'unknown)
 741       (unless (widget-apply conv :match value)
 742         ;; (widget-apply (widget-convert type) :match value)
 743         (setq form 'lisp)))
 744     ;; Now we can create the child widget.
 745     (cond ((eq state 'hidden)
 746            ;; Make hidden value easy to show.
 747            (insert tag ": ..."))
 748           ((eq form 'lisp)
 749            ;; In lisp mode edit the saved value when possible.
 750            (let* ((value (cond ((get symbol 'saved-value)
 751                                 (car (get symbol 'saved-value)))
 752                                ((get symbol 'factory-value)
 753                                 (car (get symbol 'factory-value)))
 754                                ((default-boundp symbol)
 755                                 (custom-quote (default-value symbol)))
 756                                (t
 757                                 (custom-quote (widget-get conv :value))))))
 758              (push (widget-create-child-and-convert widget 'sexp
 759                                                     :tag (symbol-name symbol)
 760                                                     :parent widget
 761                                                     :value value)
 762                    children)))
 763           (t
 764            ;; Edit mode.
 765            (push (widget-create-child-and-convert
 766                   widget type
 767                   :tag tag
 768                   :value value)
 769                  children)))
 770     ;; Now update the state.
 771     (unless (eq (preceding-char) ?\n)
 772       (widget-insert "\n"))
 773     (if (eq state 'hidden)
 774         (widget-put widget :custom-state state)
 775       (custom-variable-state-set widget))
 776     (widget-put widget :custom-form form)
 777     (widget-put widget :buttons buttons)
 778     (widget-put widget :children children)))
 779
 780 (defun custom-variable-state-set (widget)
 781   "Set the state of WIDGET."
 782   (let* ((symbol (widget-value widget))
 783          (value (if (default-boundp symbol)
 784                     (default-value symbol)
 785                   (widget-get widget :value)))
 786          tmp
 787          (state (cond ((setq tmp (get symbol 'customized-value))
 788                        (if (condition-case nil
 789                                (equal value (eval (car tmp)))
 790                              (error nil))
 791                            'saved
 792                          'set))
 793                       ((setq tmp (get symbol 'saved-value))
 794                        (if (condition-case nil
 795                                (equal value (eval (car tmp)))
 796                              (error nil))
 797                            'saved
 798                          'set))
 799                       ((setq tmp (get symbol 'factory-value))
 800                        (if (condition-case nil
 801                                (equal value (eval (car tmp)))
 802                              (error nil))
 803                            'factory
 804                          'set))
 805                       (t 'rogue))))
 806     (widget-put widget :custom-state state)))
 807
 808 (defvar custom-variable-menu
 809   '(("Edit" . custom-variable-edit)
 810     ("Edit Lisp" . custom-variable-edit-lisp)
 811     ("Set" . custom-variable-set)
 812     ("Save" . custom-variable-save)
 813     ("Reset" . custom-redraw)
 814     ("Reset to Default" . custom-variable-default)
 815     ("Reset to Factory Settings" . custom-variable-factory))
 816   "Alist of actions for the `custom-variable' widget.
 817 The key is a string containing the name of the action, the value is a
 818 lisp function taking the widget as an element which will be called
 819 when the action is chosen.")
 820
 821 (defun custom-variable-action (widget &optional event)
 822   "Show the menu for `custom-variable' WIDGET.
 823 Optional EVENT is the location for the menu."
 824   (let* ((completion-ignore-case t)
 825          (answer (widget-choose (symbol-name (widget-get widget :value))
 826                                 custom-variable-menu
 827                                 event)))
 828     (if answer
 829         (funcall answer widget))))
 830
 831 (defun custom-variable-edit (widget)
 832   "Edit value of WIDGET."
 833   (widget-put widget :custom-state 'unknown)
 834   (widget-put widget :custom-form 'edit)
 835   (custom-redraw widget))
 836
 837 (defun custom-variable-edit-lisp (widget)
 838   "Edit the lisp representation of the value of WIDGET."
 839   (widget-put widget :custom-state 'unknown)
 840   (widget-put widget :custom-form 'lisp)
 841   (custom-redraw widget))
 842
 843 (defun custom-variable-set (widget)
 844   "Set the current value for the variable being edited by WIDGET."
 845   (let ((form (widget-get widget :custom-form))
 846         (state (widget-get widget :custom-state))
 847         (child (car (widget-get widget :children)))
 848         (symbol (widget-value widget))
 849         val)
 850     (cond ((eq state 'hidden)
 851            (error "Cannot set hidden variable."))
 852           ((setq val (widget-apply child :validate))
 853            (error "Invalid %S" val))
 854           ((eq form 'lisp)
 855            (set symbol (eval (setq val (widget-value child))))
 856            (put symbol 'customized-value (list val)))
 857           (t
 858            (set symbol (widget-value child))
 859            (put symbol 'customized-value (list (custom-quote val)))))
 860     (custom-variable-state-set widget)
 861     (custom-redraw-magic widget)))
 862
 863 (defun custom-variable-save (widget)
 864   "Set the default value for the variable being edited by WIDGET."
 865   (let ((form (widget-get widget :custom-form))
 866         (state (widget-get widget :custom-state))
 867         (child (car (widget-get widget :children)))
 868         (symbol (widget-value widget))
 869         val)
 870     (cond ((eq state 'hidden)
 871            (error "Cannot set hidden variable."))
 872           ((setq val (widget-apply child :validate))
 873            (error "Invalid %S" val))
 874           ((eq form 'lisp)
 875            (put symbol 'saved-value (list (widget-value child)))
 876            (set symbol (eval (widget-value child))))
 877           (t
 878            (put symbol
 879                 'saved-value (list (custom-quote (widget-value
 880                                                   child))))
 881            (set symbol (widget-value child))))
 882     (put symbol 'customized-value nil)
 883     (custom-save-all)
 884     (custom-variable-state-set widget)
 885     (custom-redraw-magic widget)))
 886
 887 (defun custom-variable-default (widget)
 888   "Restore the default value for the variable being edited by WIDGET."
 889   (let ((symbol (widget-value widget)))
 890     (if (get symbol 'saved-value)
 891         (condition-case nil
 892             (set symbol (eval (car (get symbol 'saved-value))))
 893           (error nil))
 894       (error "No default value for %s" symbol))
 895     (put symbol 'customized-value nil)
 896     (widget-put widget :custom-state 'unknown)
 897     (custom-redraw widget)))
 898
 899 (defun custom-variable-factory (widget)
 900   "Restore the factory setting for the variable being edited by WIDGET."
 901   (let ((symbol (widget-value widget)))
 902     (if (get symbol 'factory-value)
 903         (set symbol (eval (car (get symbol 'factory-value))))
 904       (error "No factory default for %S" symbol))
 905     (put symbol 'customized-value nil)
 906     (when (get symbol 'saved-value)
 907       (put symbol 'saved-value nil)
 908       (custom-save-all))
 909     (widget-put widget :custom-state 'unknown)
 910     (custom-redraw widget)))
 911
 912 ;;; The `custom-face-edit' Widget.
 913
 914 (defvar custom-face-edit-args
 915   (mapcar (lambda (att)
 916             (list 'group
 917                   :inline t
 918                   (list 'const :format "" :value (nth 0 att))
 919                   (nth 1 att)))
 920           custom-face-attributes))
 921
 922 (define-widget 'custom-face-edit 'checklist
 923   "Edit face attributes."
 924   :format "%t: %v"
 925   :tag "Attributes"
 926   :extra-offset 12
 927   :args (mapcar (lambda (att)
 928                   (list 'group
 929                         :inline t
 930                         (list 'const :format "" :value (nth 0 att))
 931                         (nth 1 att)))
 932                 custom-face-attributes))
 933
 934 ;;; The `custom-display' Widget.
 935
 936 (define-widget 'custom-display 'menu-choice
 937   "Select a display type."
 938   :tag "Display"
 939   :value t
 940   :args '((const :tag "all" t)
 941           (checklist :offset 0
 942                      :extra-offset 9
 943                      :args ((group (const :format "Type: " type)
 944                                    (checklist :inline t
 945                                               :offset 0
 946                                               (const :format "X "
 947                                                      x)
 948                                               (const :format "PM "
 949                                                      pm)
 950                                               (const :format "Win32 "
 951                                                      win32)
 952                                               (const :format "DOS "
 953                                                      pc)
 954                                               (const :format "TTY%n"
 955                                                      tty)))
 956                             (group (const :format "Class: " class)
 957                                    (checklist :inline t
 958                                               :offset 0
 959                                               (const :format "Color "
 960                                                      color)
 961                                               (const :format
 962                                                      "Grayscale "
 963                                                      grayscale)
 964                                               (const :format "Monochrome%n"
 965                                                      mono)))
 966                             (group  (const :format "Background: " background)
 967                                     (checklist :inline t
 968                                                :offset 0
 969                                                (const :format "Light "
 970                                                       light)
 971                                                (const :format "Dark\n"
 972                                                       dark)))))))
 973
 974 ;;; The `custom-face' Widget.
 975
 976 (define-widget 'custom-face 'custom
 977   "Customize face."
 978   :format "%l%[%t%]: %s%m%h%a%v"
 979   :format-handler 'custom-face-format-handler
 980   :help-echo "Push me to set or reset this face."
 981   :documentation-property 'face-documentation
 982   :value-create 'custom-face-value-create
 983   :action 'custom-face-action
 984   :custom-set 'custom-face-set
 985   :custom-save 'custom-face-save
 986   :custom-reset 'custom-redraw
 987   :custom-menu 'custom-face-menu-create)
 988
 989 (defun custom-face-format-handler (widget escape)
 990   ;; We recognize extra escape sequences.
 991   (let (child
 992         (state (widget-get widget :custom-state))
 993         (symbol (widget-get widget :value)))
 994     (cond ((eq escape ?s)
 995            (and (string-match "XEmacs" emacs-version)
 996                 ;; XEmacs cannot display initialized faces.
 997                 (not (custom-facep symbol))
 998                 (copy-face 'custom-face-empty symbol))
 999            (setq child (widget-create-child-and-convert
1000                         widget 'custom-level
1001                         :format "(%[%t%])\n"
1002                         :button-face symbol
1003                         (if (eq state 'hidden) "*** show ***" "hide"))))
1004           (t
1005            (custom-format-handler widget escape)))
1006     (when child
1007       (widget-put widget
1008                   :buttons (cons child (widget-get widget :buttons))))))
1009
1010 (defun custom-face-value-create (widget)
1011   ;; Create a list of the display specifications.
1012   (unless (eq (preceding-char) ?\n)
1013     (insert "\n"))
1014   (when (not (eq (widget-get widget :custom-state) 'hidden))
1015     (custom-load-widget widget)
1016     (let* ((symbol (widget-value widget))
1017            (edit (widget-create-child-and-convert
1018                   widget 'editable-list
1019                   :entry-format "%i %d %v"
1020                   :value (or (get symbol 'saved-face)
1021                              (get symbol 'factory-face))
1022                   '(group :format "%v"
1023                           custom-display custom-face-edit))))
1024       (custom-face-state-set widget)
1025       (widget-put widget :children (list edit)))))
1026
1027 (defvar custom-face-menu
1028   '(("Set" . custom-face-set)
1029     ("Save" . custom-face-save)
1030     ("Reset to Default" . custom-face-default)
1031     ("Reset to Factory Setting" . custom-face-factory))
1032   "Alist of actions for the `custom-face' widget.
1033 The key is a string containing the name of the action, the value is a
1034 lisp function taking the widget as an element which will be called
1035 when the action is chosen.")
1036
1037 (defun custom-face-state-set (widget)
1038   "Set the state of WIDGET."
1039   (let ((symbol (widget-value widget)))
1040     (widget-put widget :custom-state (cond ((get symbol 'customized-face)
1041                                             'set)
1042                                            ((get symbol 'saved-face)
1043                                             'saved)
1044                                            ((get symbol 'factory-face)
1045                                             'factory)
1046                                            (t
1047                                             'rogue)))))
1048
1049 (defun custom-face-action (widget &optional event)
1050   "Show the menu for `custom-face' WIDGET.
1051 Optional EVENT is the location for the menu."
1052   (when (eq (widget-get widget :custom-state) 'hidden)
1053     (error "You cannot edit a hidden face"))
1054   (let* ((completion-ignore-case t)
1055          (symbol (widget-get widget :value))
1056          (answer (widget-choose (symbol-name symbol) custom-face-menu event)))
1057     (if answer
1058         (funcall answer widget))))
1059
1060 (defun custom-face-set (widget)
1061   "Make the face attributes in WIDGET take effect."
1062   (let* ((symbol (widget-value widget))
1063          (child (car (widget-get widget :children)))
1064          (value (widget-value child)))
1065     (put symbol 'customized-face value)
1066     (custom-face-display-set symbol value)
1067     (custom-face-state-set widget)
1068     (custom-redraw-magic widget)))
1069
1070 (defun custom-face-save (widget)
1071   "Make the face attributes in WIDGET default."
1072   (let* ((symbol (widget-value widget))
1073          (child (car (widget-get widget :children)))
1074          (value (widget-value child)))
1075     (custom-face-display-set symbol value)
1076     (put symbol 'saved-face value)
1077     (put symbol 'customized-face nil)
1078     (custom-face-state-set widget)
1079     (custom-redraw-magic widget)))
1080
1081 (defun custom-face-default (widget)
1082   "Restore WIDGET to the face's default attributes."
1083   (let* ((symbol (widget-value widget))
1084          (child (car (widget-get widget :children)))
1085          (value (get symbol 'saved-face)))
1086     (unless value
1087       (error "No saved value for this face"))
1088     (put symbol 'customized-face nil)
1089     (custom-face-display-set symbol value)
1090     (widget-value-set child value)
1091     (custom-face-state-set widget)
1092     (custom-redraw-magic widget)))
1093
1094 (defun custom-face-factory (widget)
1095   "Restore WIDGET to the face's factory settings."
1096   (let* ((symbol (widget-value widget))
1097          (child (car (widget-get widget :children)))
1098          (value (get symbol 'factory-face)))
1099     (unless value
1100       (error "No factory default for this face"))
1101     (put symbol 'customized-face nil)
1102     (when (get symbol 'saved-face)
1103       (put symbol 'saved-face nil)
1104       (custom-save-all))
1105     (custom-face-display-set symbol value)
1106     (widget-value-set child value)
1107     (custom-face-state-set widget)
1108     (custom-redraw-magic widget)))
1109
1110 ;;; The `face' Widget.
1111
1112 (define-widget 'face 'default
1113   "Select and customize a face."
1114   :convert-widget 'widget-item-convert-widget
1115   :format "%[%t%]: %v"
1116   :tag "Face"
1117   :value 'default
1118   :value-create 'widget-face-value-create
1119   :value-delete 'widget-face-value-delete
1120   :value-get 'widget-item-value-get
1121   :validate 'widget-editable-list-validate
1122   :action 'widget-face-action
1123   :match '(lambda (widget value) (symbolp value)))
1124
1125 (defun widget-face-value-create (widget)
1126   ;; Create a `custom-face' child.
1127   (let* ((symbol (widget-value widget))
1128          (child (widget-create-child-and-convert
1129                  widget 'custom-face
1130                  :format "%t %s%m%h%v"
1131                  :custom-level nil
1132                  :value symbol)))
1133     (custom-magic-reset child)
1134     (setq custom-options (cons child custom-options))
1135     (widget-put widget :children (list child))))
1136
1137 (defun widget-face-value-delete (widget)
1138   ;; Remove the child from the options.
1139   (let ((child (car (widget-get widget :children))))
1140     (setq custom-options (delq child custom-options))
1141     (widget-children-value-delete widget)))
1142
1143 (defvar face-history nil
1144   "History of entered face names.")
1145
1146 (defun widget-face-action (widget &optional event)
1147   "Prompt for a face."
1148   (let ((answer (completing-read "Face: "
1149                                  (mapcar (lambda (face)
1150                                            (list (symbol-name face)))
1151                                          (face-list))
1152                                  nil nil nil
1153                                  'face-history)))
1154     (unless (zerop (length answer))
1155       (widget-value-set widget (intern answer))
1156       (widget-apply widget :notify widget event)
1157       (widget-setup))))
1158
1159 ;;; The `hook' Widget.
1160
1161 (define-widget 'hook 'list
1162   "A emacs lisp hook"
1163   :convert-widget 'custom-hook-convert-widget
1164   :tag "Hook")
1165
1166 (defun custom-hook-convert-widget (widget)
1167   ;; Handle `:custom-options'.
1168   (let* ((options (widget-get widget :options))
1169          (other `(editable-list :inline t
1170                                 :entry-format "%i %d%v"
1171                                 (function :format " %v")))
1172          (args (if options
1173                    (list `(checklist :inline t
1174                                      ,@(mapcar (lambda (entry)
1175                                                  `(function-item ,entry))
1176                                                options))
1177                          other)
1178                  (list other))))
1179     (widget-put widget :args args)
1180     widget))
1181
1182 ;;; The `custom-group' Widget.
1183
1184 (define-widget 'custom-group 'custom
1185   "Customize group."
1186   :format "%l%[%t%]:%L\n%m%h%a%v"
1187   :documentation-property 'group-documentation
1188   :help-echo "Push me to set or reset all members of this group."
1189   :value-create 'custom-group-value-create
1190   :action 'custom-group-action
1191   :custom-set 'custom-group-set
1192   :custom-save 'custom-group-save
1193   :custom-reset 'custom-group-reset
1194   :custom-menu 'custom-group-menu-create)
1195
1196 (defun custom-group-value-create (widget)
1197   (let ((state (widget-get widget :custom-state)))
1198     (unless (eq state 'hidden)
1199       (custom-load-widget widget)
1200       (let* ((level (widget-get widget :custom-level))
1201              (symbol (widget-value widget))
1202              (members (get symbol 'custom-group))
1203              (prefixes (widget-get widget :custom-prefixes))
1204              (custom-prefix-list (custom-prefix-add symbol prefixes))
1205              (children (mapcar (lambda (entry)
1206                                  (widget-insert "\n")
1207                                  (prog1
1208                                      (widget-create-child-and-convert
1209                                       widget (nth 1 entry)
1210                                       :group widget
1211                                       :tag (custom-unlispify-tag-name
1212                                             (nth 0 entry))
1213                                       :custom-prefixes custom-prefix-list
1214                                       :custom-level (1+ level)
1215                                       :value (nth 0 entry))
1216                                    (unless (eq (preceding-char) ?\n)
1217                                      (widget-insert "\n"))))
1218                                members)))
1219         (mapcar 'custom-magic-reset children)
1220         (widget-put widget :children children)
1221         (custom-group-state-update widget)))))
1222
1223 (defvar custom-group-menu
1224   '(("Set" . custom-group-set)
1225     ("Save" . custom-group-save)
1226     ("Reset" . custom-group-reset))
1227   "Alist of actions for the `custom-group' widget.
1228 The key is a string containing the name of the action, the value is a
1229 lisp function taking the widget as an element which will be called
1230 when the action is chosen.")
1231
1232 (defun custom-group-action (widget &optional event)
1233   "Show the menu for `custom-group' WIDGET.
1234 Optional EVENT is the location for the menu."
1235   (let* ((completion-ignore-case t)
1236          (answer (widget-choose (symbol-name (widget-get widget :value))
1237                                 custom-group-menu
1238                                 event)))
1239     (if answer
1240         (funcall answer widget))))
1241
1242 (defun custom-group-set (widget)
1243   "Set changes in all modified group members."
1244   (let ((children (widget-get widget :children)))
1245     (mapcar (lambda (child)
1246               (when (eq (widget-get child :custom-state) 'modified)
1247                 (widget-apply child :custom-set)))
1248             children )))
1249
1250 (defun custom-group-save (widget)
1251   "Save all modified group members."
1252   (let ((children (widget-get widget :children)))
1253     (mapcar (lambda (child)
1254               (when (memq (widget-get child :custom-state) '(modified set))
1255                 (widget-apply child :custom-save)))
1256             children )))
1257
1258 (defun custom-group-reset (widget)
1259   "Reset all modified group members."
1260   (let ((children (widget-get widget :children)))
1261     (mapcar (lambda (child)
1262               (when (eq (widget-get child :custom-state) 'modified)
1263                 (widget-apply child :custom-reset)))
1264             children )))
1265
1266 (defun custom-group-state-update (widget)
1267   "Update magic."
1268   (unless (eq (widget-get widget :custom-state) 'hidden)
1269     (let* ((children (widget-get widget :children))
1270            (states (mapcar (lambda (child)
1271                              (widget-get child :custom-state))
1272                            children))
1273            (magics custom-magic-alist)
1274            (found 'factory))
1275       (while magics
1276         (let ((magic (car (car magics))))
1277           (if (and (not (eq magic 'hidden))
1278                    (memq magic states))
1279               (setq found magic
1280                     magics nil)
1281             (setq magics (cdr magics)))))
1282       (widget-put widget :custom-state found)))
1283   (custom-magic-reset widget))
1284
1285 ;;; The `custom-save-all' Function.
1286
1287 (defcustom custom-file "~/.emacs"
1288   "File used for storing customization information.
1289 If you change this from the default \"~/.emacs\" you need to
1290 explicitly load that file for the settings to take effect."
1291   :type 'file
1292   :group 'customize)
1293
1294 (defun custom-save-delete (symbol)
1295   "Delete the call to SYMBOL form `custom-file'.
1296 Leave point at the location of the call, or after the last expression."
1297   (set-buffer (find-file-noselect custom-file))
1298   (goto-char (point-min))
1299   (catch 'found
1300     (while t
1301       (let ((sexp (condition-case nil
1302                       (read (current-buffer))
1303                     (end-of-file (throw 'found nil)))))
1304         (when (and (listp sexp)
1305                    (eq (car sexp) symbol))
1306           (delete-region (save-excursion
1307                            (backward-sexp)
1308                            (point))
1309                          (point))
1310           (throw 'found nil))))))
1311
1312 (defun custom-save-variables ()
1313   "Save all customized variables in `custom-file'."
1314   (save-excursion
1315     (custom-save-delete 'custom-set-variables)
1316     (let ((standard-output (current-buffer)))
1317       (unless (bolp)
1318         (princ "\n"))
1319       (princ "(custom-set-variables")
1320       (mapatoms (lambda (symbol)
1321                   (let ((value (get symbol 'saved-value)))
1322                     (when value
1323                       (princ "\n '(")
1324                       (princ symbol)
1325                       (princ " ")
1326                       (prin1 (car value))
1327                       (if (or (get symbol 'factory-value)
1328                               (and (not (boundp symbol))
1329                                    (not (get symbol 'force-value))))
1330                           (princ ")")
1331                         (princ " t)"))))))
1332       (princ ")")
1333       (unless (eolp)
1334         (princ "\n")))))
1335
1336 (defun custom-save-faces ()
1337   "Save all customized faces in `custom-file'."
1338   (save-excursion
1339     (custom-save-delete 'custom-set-faces)
1340     (let ((standard-output (current-buffer)))
1341       (unless (bolp)
1342         (princ "\n"))
1343       (princ "(custom-set-faces")
1344       (mapatoms (lambda (symbol)
1345                   (let ((value (get symbol 'saved-face)))
1346                     (when value
1347                       (princ "\n '(")
1348                       (princ symbol)
1349                       (princ " ")
1350                       (prin1 value)
1351                       (if (or (get symbol 'factory-face)
1352                               (and (not (custom-facep symbol))
1353                                    (not (get symbol 'force-face))))
1354                           (princ ")")
1355                         (princ " t)"))))))
1356       (princ ")")
1357       (unless (eolp)
1358         (princ "\n")))))
1359
1360 (defun custom-save-all ()
1361   "Save all customizations in `custom-file'."
1362   (custom-save-variables)
1363   (custom-save-faces)
1364   (save-excursion
1365     (set-buffer (find-file-noselect custom-file))
1366     (save-buffer)))
1367
1368 ;;; The Customize Menu.
1369
1370 (defcustom custom-menu-nesting 2
1371   "Maximum nesting in custom menus."
1372   :type 'integer
1373   :group 'customize)
1374
1375 (defun custom-face-menu-create (widget symbol)
1376   "Ignoring WIDGET, create a menu entry for customization face SYMBOL."
1377   (vector (custom-unlispify-menu-entry symbol)
1378           `(custom-buffer-create '((,symbol custom-face)))
1379           t))
1380
1381 (defun custom-variable-menu-create (widget symbol)
1382   "Ignoring WIDGET, create a menu entry for customization variable SYMBOL."
1383   (let ((type (get symbol 'custom-type)))
1384     (unless (listp type)
1385       (setq type (list type)))
1386     (if (and type (widget-get type :custom-menu))
1387         (widget-apply type :custom-menu symbol)
1388       (vector (custom-unlispify-menu-entry symbol)
1389               `(custom-buffer-create '((,symbol custom-variable)))
1390               t))))
1391
1392 (widget-put (get 'boolean 'widget-type)
1393             :custom-menu (lambda (widget symbol)
1394                            (vector (custom-unlispify-menu-entry symbol)
1395                                    `(custom-buffer-create
1396                                      '((,symbol custom-variable)))
1397                                    ':style 'toggle
1398                                    ':selected symbol)))
1399
1400 (defun custom-group-menu-create (widget symbol)
1401   "Ignoring WIDGET, create a menu entry for customization group SYMBOL."
1402   (custom-menu-create symbol))
1403
1404 (defun custom-menu-create (symbol &optional name)
1405   "Create menu for customization group SYMBOL.
1406 If optional NAME is given, use that as the name of the menu.
1407 Otherwise make up a name from SYMBOL.
1408 The menu is in a format applicable to `easy-menu-define'."
1409   (unless name
1410     (setq name (custom-unlispify-menu-entry symbol)))
1411   (let ((item (vector name
1412                       `(custom-buffer-create '((,symbol custom-group)))
1413                       t)))
1414     (if (and (> custom-menu-nesting 0)
1415              (< (length (get symbol 'custom-group)) widget-menu-max-size))
1416         (let ((custom-menu-nesting (1- custom-menu-nesting))
1417               (custom-prefix-list (custom-prefix-add symbol
1418                                                      custom-prefix-list)))
1419           (custom-load-symbol symbol)
1420           `(,(custom-unlispify-menu-entry symbol t)
1421             ,item
1422             "--"
1423             ,@(mapcar (lambda (entry)
1424                         (widget-apply (if (listp (nth 1 entry))
1425                                           (nth 1 entry)
1426                                         (list (nth 1 entry)))
1427                                       :custom-menu (nth 0 entry)))
1428                       (get symbol 'custom-group))))
1429       item)))
1430
1431 ;;;###autoload
1432 (defun custom-menu-update ()
1433   "Update customize menu."
1434   (interactive)
1435   (add-hook 'custom-define-hook 'custom-menu-reset)
1436   (let ((menu `(,(car custom-help-menu)
1437                 ,(widget-apply '(custom-group) :custom-menu 'emacs)
1438                 ,@(cdr (cdr custom-help-menu)))))
1439     (if (fboundp 'add-submenu)
1440         (add-submenu '("Help") menu)
1441       (define-key global-map [menu-bar help-menu customize-menu]
1442         (cons (car menu) (easy-menu-create-keymaps (car menu) (cdr menu)))))))
1443
1444 ;;; Dependencies.
1445
1446 ;;;###autoload
1447 (defun custom-make-dependencies ()
1448   "Batch function to extract custom dependencies from .el files.
1449 Usage: emacs -batch *.el -f custom-make-dependencies > deps.el"
1450   (let ((buffers (buffer-list)))
1451     (while buffers
1452       (set-buffer (car buffers))
1453       (setq buffers (cdr buffers))
1454       (let ((file (buffer-file-name)))
1455         (when (and file (string-match "\\`\\(.*\\)\\.el\\'" file))
1456           (goto-char (point-min))
1457           (condition-case nil
1458               (let ((name (file-name-nondirectory (match-string 1 file))))
1459                 (while t
1460                   (let ((expr (read (current-buffer))))
1461                     (when (and (listp expr)
1462                                (memq (car expr) '(defcustom defface defgroup)))
1463                       (eval expr)
1464                       (put (nth 1 expr) 'custom-where name)))))
1465             (error nil))))))
1466   (mapatoms (lambda (symbol)
1467               (let ((members (get symbol 'custom-group))
1468                     item where found)
1469                 (when members
1470                   (princ "(put '")
1471                   (princ symbol)
1472                   (princ " 'custom-loads '(")
1473                   (while members
1474                     (setq item (car (car members))
1475                           members (cdr members)
1476                           where (get item 'custom-where))
1477                     (unless (or (null where)
1478                                 (member where found))
1479                       (when found
1480                         (princ " "))
1481                       (prin1 where)
1482                       (push where found)))
1483                   (princ "))\n"))))))
1484
1485 ;;; The End.
1486
1487 (provide 'custom-edit)
1488
1489 ;; custom-edit.el ends here