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.04
   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-show :custom-magic
  21   :custom-state :custom-level :custom-form
  22   :custom-apply :custom-set-default :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 ;;; The Custom Mode.
  54
  55 (defvar custom-options nil
  56   "Customization widgets in the current buffer.")
  57
  58 (defvar custom-mode-map nil
  59   "Keymap for `custom-mode'.")
  60
  61 (unless custom-mode-map
  62   (setq custom-mode-map (make-sparse-keymap))
  63   (set-keymap-parent custom-mode-map widget-keymap))
  64
  65 (easy-menu-define custom-mode-menu
  66     custom-mode-map
  67   "Menu used in customization buffers."
  68     '("Custom"
  69       ["Apply" custom-apply t]
  70       ["Set Default" custom-set-default t]
  71       ["Reset" custom-reset t]
  72       ["Save" custom-save t]))
  73
  74 (defun custom-mode ()
  75   "Major mode for editing customization buffers.
  76
  77 The following commands are available:
  78
  79 \\[widget-forward]              Move to next button or editable field.
  80 \\[widget-backward]             Move to previous button or editable field.
  81 \\[widget-button-click]         Activate button under the mouse pointer.
  82 \\[widget-button-press]         Activate button under point.
  83 \\[custom-apply]                Apply all modifications.
  84 \\[custom-set-default]          Make all modifications default.
  85 \\[custom-reset]                Undo all modifications.
  86 \\[custom-save]                 Save defaults for future emacs sessions.
  87
  88 Entry to this mode calls the value of `custom-mode-hook'
  89 if that value is non-nil."
  90   (kill-all-local-variables)
  91   (setq major-mode 'custom-mode
  92         mode-name "Custom")
  93   (use-local-map custom-mode-map)
  94   (make-local-variable 'custom-options)
  95   (run-hooks 'custom-mode-hook))
  96
  97 ;;; Custom Mode Commands.
  98
  99 (defun custom-apply ()
 100   "Apply changes in all modified options."
 101   (interactive)
 102   (let ((children custom-options))
 103     (mapcar (lambda (child)
 104               (when (eq (widget-get child :custom-state) 'modified)
 105                 (widget-apply child :custom-apply)))
 106             children)))
 107
 108 (defun custom-set-default ()
 109   "Set default in all modified group members."
 110   (interactive)
 111   (let ((children custom-options))
 112     (mapcar (lambda (child)
 113               (when (eq (widget-get child :custom-state) 'modified)
 114                 (widget-apply child :custom-set-default)))
 115             children)))
 116
 117 (defun custom-reset ()
 118   "Reset all modified group members."
 119   (interactive)
 120   (let ((children custom-options))
 121     (mapcar (lambda (child)
 122               (when (eq (widget-get child :custom-state) 'modified)
 123                 (widget-apply child :custom-reset)))
 124             children)))
 125
 126 ;;; The Customize Commands
 127
 128 ;;;###autoload
 129 (defun customize (symbol)
 130   "Customize SYMBOL, which must be a customization group."
 131   (interactive (list (completing-read "Customize group: (default emacs) "
 132                                       obarray
 133                                       (lambda (symbol)
 134                                         (get symbol 'custom-group))
 135                                       t)))
 136
 137   (when (stringp symbol)
 138     (if (string-equal "" symbol)
 139         (setq symbol 'emacs)
 140       (setq symbol (intern symbol))))
 141   (custom-buffer-create (list (list symbol 'custom-group))))
 142
 143 ;;;###autoload
 144 (defun customize-variable (symbol)
 145   "Customize SYMBOL, which must be a variable."
 146   (interactive
 147    ;; Code stolen from `help.el'.
 148    (let ((v (variable-at-point))
 149          (enable-recursive-minibuffers t)
 150          val)
 151      (setq val (completing-read
 152                 (if v
 153                     (format "Customize variable (default %s): " v)
 154                   "Customize variable: ")
 155                 obarray 'boundp t))
 156      (list (if (equal val "")
 157                v (intern val)))))
 158   (custom-buffer-create (list (list symbol 'custom-variable))))
 159
 160 ;;;###autoload
 161 (defun customize-face (symbol)
 162   "Customize FACE."
 163   (interactive (list (completing-read "Customize face: "
 164                                       obarray 'custom-facep)))
 165   (if (stringp symbol)
 166       (setq symbol (intern symbol)))
 167   (unless (symbolp symbol)
 168     (error "Should be a symbol %S" symbol))
 169   (custom-buffer-create (list (list symbol 'custom-face))))
 170
 171 ;;;###autoload
 172 (defun customize-customized ()
 173   "Customize all already customized user options."
 174   (interactive)
 175   (let ((found nil))
 176     (mapatoms (lambda (symbol)
 177                 (and (get symbol 'saved-face)
 178                      (custom-facep symbol)
 179                      (setq found (cons (list symbol 'custom-face) found)))
 180                 (and (get symbol 'saved-value)
 181                      (boundp symbol)
 182                      (setq found
 183                            (cons (list symbol 'custom-variable) found)))))
 184     (if found
 185         (custom-buffer-create found)
 186       (error "No customized user options"))))
 187
 188 ;;;###autoload
 189 (defun customize-apropos (regexp &optional all)
 190   "Customize all user options matching REGEXP.
 191 If ALL (e.g., started with a prefix key), include options which are not
 192 user-settable."
 193   (interactive "sCustomize regexp: \nP")
 194   (let ((found nil))
 195     (mapatoms (lambda (symbol)
 196                 (when (string-match regexp (symbol-name symbol))
 197                   (when (get symbol 'custom-group)
 198                     (setq found (cons (list symbol 'custom-group) found)))
 199                   (when (custom-facep symbol)
 200                     (setq found (cons (list symbol 'custom-face) found)))
 201                   (when (and (boundp symbol)
 202                              (or (get symbol 'saved-value)
 203                                  (get symbol 'factory-value)
 204                                  (if all
 205                                      (get symbol 'variable-documentation)
 206                                    (user-variable-p symbol))))
 207                     (setq found
 208                           (cons (list symbol 'custom-variable) found))))))
 209     (if found
 210         (custom-buffer-create found)
 211       (error "No matches"))))
 212
 213 ;;;###autoload
 214 (defun custom-buffer-create (options)
 215   "Create a buffer containing OPTIONS.
 216 OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where
 217 SYMBOL is a customization option, and WIDGET is a widget for editing
 218 that option."
 219   (kill-buffer (get-buffer-create "*Customization*"))
 220   (switch-to-buffer (get-buffer-create "*Customization*"))
 221   (custom-mode)
 222   (widget-insert "This is a customization buffer.
 223 Push RET or click mouse-2 on the word ")
 224   (widget-create 'info-link
 225                  :tag "help"
 226                  :help-echo "Push me for help."
 227                  "(custom)The Customization Buffer")
 228   (widget-insert " for more information.\n\n")
 229   (setq custom-options
 230         (mapcar (lambda (entry)
 231                   (prog1
 232                       (if (> (length options) 1)
 233                           (widget-create (nth 1 entry)
 234                                          :value (nth 0 entry))
 235                         ;; If there is only one entry, don't hide it!
 236                         (widget-create (nth 1 entry)
 237                                        :custom-state 'unknown
 238                                        :value (nth 0 entry)))
 239                     (unless (eq (preceding-char) ?\n)
 240                       (widget-insert "\n"))
 241                     (widget-insert "\n")))
 242                 options))
 243   (mapcar 'custom-magic-reset custom-options)
 244   (widget-create 'push-button
 245                  :tag "Apply"
 246                  :help-echo "Push me to apply all modifications."
 247                  :action (lambda (widget &optional event)
 248                            (custom-apply)))
 249   (widget-insert " ")
 250   (widget-create 'push-button
 251                  :tag "Set Default"
 252                  :help-echo "Push me to make the modifications default."
 253                  :action (lambda (widget &optional event)
 254                            (custom-set-default)))
 255   (widget-insert " ")
 256   (widget-create 'push-button
 257                  :tag "Reset"
 258                  :help-echo "Push me to undo all modifications.."
 259                  :action (lambda (widget &optional event)
 260                            (custom-reset)))
 261   (widget-insert " ")
 262   (widget-create 'push-button
 263                  :tag "Save"
 264                  :help-echo "Push me to store the new defaults permanently."
 265                  :action (lambda (widget &optional event)
 266                            (custom-save)))
 267   (widget-insert "\n")
 268   (widget-setup))
 269
 270 ;;; Modification of Basic Widgets.
 271 ;;
 272 ;; We add extra properties to the basic widgets needed here.  This is
 273 ;; fine, as long as we are careful to stay within out own namespace.
 274 ;;
 275 ;; We want simple widgets to be displayed by default, but complex
 276 ;; widgets to be hidden.
 277
 278 (widget-put (get 'item 'widget-type) :custom-show t)
 279 (widget-put (get 'editable-field 'widget-type)
 280             :custom-show (lambda (widget value)
 281                            (let ((pp (pp-to-string value)))
 282                              (cond ((string-match "\n" pp)
 283                                     nil)
 284                                    ((> (length pp) 40)
 285                                     nil)
 286                                    (t t)))))
 287 (widget-put (get 'menu-choice 'widget-type) :custom-show t)
 288
 289 ;;; The `custom-manual' Widget.
 290
 291 (define-widget 'custom-manual 'info-link
 292   "Link to the manual entry for this customization option."
 293   :tag "Manual")
 294
 295 ;;; The `custom-magic' Widget.
 296
 297 (define-widget 'custom-magic 'item
 298   "Status feedback for customization option."
 299   :format "%[%v%]"
 300   :action 'widget-choice-item-action
 301   :value-create 'custom-magic-value-create)
 302
 303 (defface custom-invalid-face '((((class color))
 304                                 (:foreground "yellow" :background "red"))
 305                                (t
 306                                 (:bold t :italic t :underline t)))
 307   "Face used when the customize item is invalid.")
 308
 309 (defface custom-rogue-face '((((class color))
 310                               (:foreground "pink" :background "black"))
 311                              (t
 312                               (:underline t)))
 313   "Face used when the customize item is not defined for customization.")
 314
 315 (defface custom-modified-face '((((class color))
 316                                  (:foreground "white" :background "blue"))
 317                                 (t
 318                                  (:italic t :bold)))
 319   "Face used when the customize item has been modified.")
 320
 321 (defface custom-applied-face '((((class color))
 322                                 (:foreground "blue" :background "white"))
 323                                (t
 324                                 (:italic t)))
 325   "Face used when the customize item has been applied.")
 326
 327 (defface custom-saved-face '((t (:underline t)))
 328   "Face used when the customize item has been saved.")
 329
 330 (defcustom custom-magic-alist '((nil "#" underline)
 331                                 (unknown "?" italic)
 332                                 (hidden "-" default)
 333                                 (invalid "x" custom-invalid-face)
 334                                 (modified "*" custom-modified-face)
 335                                 (applied "+" custom-applied-face)
 336                                 (saved "!" custom-saved-face)
 337                                 (rogue "@" custom-rogue-face)
 338                                 (factory " " nil))
 339   "Alist of magic representing a customize items status.
 340 Each entry is of the form (STATE MAGIC FACE), where
 341
 342 STATE is one of the following symbols:
 343
 344 `nil'
 345    For internal use, should never occur.
 346 `unknown'
 347    For internal use, should never occur.
 348 `hidden'
 349    This item is not being displayed.
 350 `invalid'
 351    This item is modified, but has an invalid form.
 352 `modified'
 353    This item is modified, and has a valid form.
 354 `applied'
 355    This items current value has been changed temporarily.
 356 `saved'
 357    This item is marked for saving.
 358 `rogue'
 359    This item has no customization information.
 360 `factory'
 361    This item is unchanged from the factory default.
 362
 363 MAGIC is a string used to present that state.
 364
 365 FACE is a face used to present the state.
 366
 367 The list should be sorted most significant first."
 368   :type '(repeat (list (choice (const nil)
 369                                (const unknown)
 370                                (const hidden)
 371                                (const invalid)
 372                                (const modified)
 373                                (const applied)
 374                                (const saved)
 375                                (const rogue)
 376                                (const factory))
 377                        string face))
 378   :group 'customize)
 379
 380 (defun custom-magic-value-create (widget)
 381   ;; Create compact status report for WIDGET.
 382   (let* ((parent (widget-get widget :parent))
 383          (state (widget-get parent :custom-state))
 384          (entry (assq state custom-magic-alist))
 385          (magic (nth 1 entry))
 386          (face (nth 2 entry)))
 387     (if (eq (widget-get parent :custom-form) 'lisp)
 388         (widget-insert "(" magic ")")
 389       (widget-insert "[" magic "]"))
 390     (widget-put widget :button-face face)))
 391
 392 (defun custom-magic-reset (widget)
 393   "Redraw the :custom-magic property of WIDGET."
 394   (let ((magic (widget-get widget :custom-magic)))
 395     (widget-value-set magic (widget-value magic))))
 396
 397 ;;; The `custom-level' Widget.
 398
 399 (define-widget 'custom-level 'item
 400   "The custom level buttons."
 401   :format "%[%t%]"
 402   :help-echo "Push me to expand or collapse this item."
 403   :action 'custom-level-action)
 404
 405 (defun custom-level-action (widget &optional event)
 406   "Toggle visibility for parent to WIDGET."
 407   (let* ((parent (widget-get widget :parent))
 408          (state (widget-get parent :custom-state)))
 409     (cond ((memq state '(invalid modified))
 410            (error "There are unapplied changes"))
 411           ((eq state 'hidden)
 412            (widget-put parent :custom-state 'unknown))
 413           (t
 414            (widget-put parent :custom-state 'hidden)))
 415     (custom-redraw parent)))
 416
 417 ;;; The `custom' Widget.
 418
 419 (defvar custom-save-needed-p nil
 420   "Non-nil if any customizations need to be saved.")
 421
 422 (add-hook 'kill-emacs-hook 'custom-save-maybe)
 423
 424 (defun custom-save-maybe ()
 425   (and custom-save-needed-p
 426        (y-or-n-p "You have unsaved customizations, save them now? ")
 427        (custom-save)))
 428
 429 (define-widget 'custom 'default
 430   "Customize a user option."
 431   :convert-widget 'widget-item-convert-widget
 432   :format "%l%[%t%]: %v%m %h%a"
 433   :format-handler 'custom-format-handler
 434   :notify 'custom-notify
 435   :custom-level 1
 436   :custom-state 'hidden
 437   :documentation-property 'widget-subclass-responsibility
 438   :value-create 'widget-subclass-responsibility
 439   :value-delete 'widget-children-value-delete
 440   :value-get 'widget-item-value-get
 441   :validate 'widget-editable-list-validate
 442   :match (lambda (widget value) (symbolp value)))
 443
 444 (defun custom-format-handler (widget escape)
 445   ;; We recognize extra escape sequences.
 446   (let* ((buttons (widget-get widget :buttons))
 447          (state (widget-get widget :custom-state))
 448          (level (widget-get widget :custom-level)))
 449     (cond ((eq escape ?l)
 450            (when level
 451              (push (widget-create-child-and-convert
 452                     widget 'custom-level (make-string level ?*))
 453                    buttons)
 454              (widget-insert " ")
 455              (widget-put widget :buttons buttons)))
 456           ((eq escape ?L)
 457              (push (widget-create-child-and-convert
 458                     widget 'custom-level
 459                     :format "%[%t%]"
 460                     (if (eq state 'hidden) "show" "hide"))
 461                    buttons)
 462              (widget-insert " ")
 463              (widget-put widget :buttons buttons))
 464           ((eq escape ?m)
 465            (and (eq (preceding-char) ?\n)
 466                 (widget-get widget :indent)
 467                 (insert-char ?  (widget-get widget :indent)))
 468            (let ((magic (widget-create-child-and-convert
 469                          widget 'custom-magic nil)))
 470              (widget-put widget :custom-magic magic)
 471              (push magic buttons)
 472              (widget-put widget :buttons buttons)))
 473           ((eq escape ?a)
 474            (let* ((symbol (widget-get widget :value))
 475                   (links (get symbol 'custom-links))
 476                   (many (> (length links) 2)))
 477              (when links
 478                (and (eq (preceding-char) ?\n)
 479                     (widget-get widget :indent)
 480                     (insert-char ?  (widget-get widget :indent)))
 481                (insert "See also ")
 482                (while links
 483                  (push (widget-create-child-and-convert widget (car links))
 484                        buttons)
 485                  (setq links (cdr links))
 486                  (cond ((null links)
 487                         (insert ".\n"))
 488                        ((null (cdr links))
 489                         (if many
 490                             (insert ", and ")
 491                           (insert " and ")))
 492                        (t
 493                         (insert ", "))))
 494                (widget-put widget :buttons buttons))))
 495           (t
 496            (widget-default-format-handler widget escape)))))
 497
 498 (defun custom-notify (widget &rest args)
 499   "Keep track of changes."
 500   (widget-put widget :custom-state 'modified)
 501   (let ((buffer-undo-list t))
 502     (custom-magic-reset widget))
 503   (apply 'widget-default-notify widget args))
 504
 505 (defun custom-redraw (widget)
 506   "Redraw WIDGET with current settings."
 507   (widget-value-set widget (widget-value widget))
 508   (custom-redraw-magic widget))
 509
 510 (defun custom-redraw-magic (widget)
 511   "Redraw WIDGET state with current settings."
 512   (while widget
 513     (let ((magic (widget-get widget :custom-magic)))
 514       (unless magic
 515         (debug))
 516       (widget-value-set magic (widget-value magic))
 517       (when (setq widget (widget-get widget :group))
 518         (custom-group-state-update widget))))
 519   (widget-setup))
 520
 521 (defun custom-show (widget value)
 522   "Non-nil if WIDGET should be shown with VALUE by default."
 523   (let ((show (widget-get widget :custom-show)))
 524     (cond ((null show)
 525            nil)
 526           ((eq t show)
 527            t)
 528           (t
 529            (funcall show widget value)))))
 530
 531 ;;; The `custom-variable' Widget.
 532
 533 (define-widget 'custom-variable 'custom
 534   "Customize variable."
 535   :format "%l%v%m %h%a"
 536   :help-echo "Push me to set or reset this variable."
 537   :documentation-property 'variable-documentation
 538   :custom-state nil
 539   :custom-form 'edit
 540   :value-create 'custom-variable-value-create
 541   :action 'custom-variable-action
 542   :custom-apply 'custom-variable-apply
 543   :custom-set-default 'custom-variable-set-default
 544   :custom-reset 'custom-redraw)
 545
 546 (defun custom-variable-value-create (widget)
 547   "Here is where you edit the variables value."
 548   (let* ((buttons (widget-get widget :buttons))
 549          (children (widget-get widget :children))
 550          (form (widget-get widget :custom-form))
 551          (state (widget-get widget :custom-state))
 552          (symbol (widget-get widget :value))
 553          (options (get symbol 'custom-options))
 554          (child-type (or (get symbol 'custom-type) 'sexp))
 555          (type (let ((tmp (if (listp child-type)
 556                               (copy-list child-type)
 557                             (list child-type))))
 558                  (when options
 559                    (widget-put tmp :options options))
 560                  tmp))
 561          (conv (widget-convert type))
 562          (value (if (default-boundp symbol)
 563                     (default-value symbol)
 564                   (widget-get conv :value))))
 565     ;; If the widget is new, the child determine whether it is hidden.
 566     (cond (state)
 567           ((custom-show type value)
 568            (setq state 'unknown))
 569           (t
 570            (setq state 'hidden)))
 571     ;; If we don't know the state, see if we need to edit it in lisp form.
 572     (when (eq state 'unknown)
 573       (unless (widget-apply (widget-convert type) :match value)
 574         (setq form 'lisp)))
 575     ;; Now we can create the child widget.
 576     (cond ((eq state 'hidden)
 577            ;; Make hidden value easy to show.
 578            (push (widget-create-child-and-convert
 579                   widget 'custom-level
 580                   :tag (symbol-name symbol)
 581                   :format "%t: %[show%]")
 582                  buttons))
 583           ((eq form 'lisp)
 584            ;; In lisp mode edit the saved value when possible.
 585            (let* ((value (cond ((get symbol 'saved-value)
 586                                 (car (get symbol 'saved-value)))
 587                                ((get symbol 'factory-value)
 588                                 (car (get symbol 'factory-value)))
 589                                ((default-boundp symbol)
 590                                 (custom-quote (default-value symbol)))
 591                                (t
 592                                 (custom-quote (widget-get conv :value))))))
 593              (push (widget-create-child-and-convert widget 'sexp
 594                                                     :tag (symbol-name symbol)
 595                                                     :parent widget
 596                                                     :value value)
 597                    children)))
 598           (t
 599            ;; Edit mode.
 600            (push (widget-create-child-and-convert widget type
 601                                                   :tag (symbol-name symbol)
 602                                                   :value value)
 603                  children)))
 604     ;; Now update the state.
 605     (unless (eq (preceding-char) ?\n)
 606       (widget-insert "\n"))
 607     (if (eq state 'hidden)
 608         (widget-put widget :custom-state state)
 609       (custom-variable-state-set widget))
 610     (widget-put widget :custom-form form)
 611     (widget-put widget :buttons buttons)
 612     (widget-put widget :children children)))
 613
 614 (defun custom-variable-state-set (widget)
 615   "Set the state of WIDGET."
 616   (let* ((symbol (widget-value widget))
 617          (value (default-value symbol))
 618          (state (if (get symbol 'saved-value)
 619                     (if (condition-case nil
 620                             (equal value
 621                                    (eval (car (get symbol 'saved-value))))
 622                           (error nil))
 623                         'saved
 624                       'applied)
 625                   (if (get symbol 'factory-value)
 626                       (if (condition-case nil
 627                               (equal value
 628                                      (eval (car (get symbol 'factory-value))))
 629                             (error nil))
 630                           'factory
 631                         'applied)
 632                     'rogue))))
 633     (widget-put widget :custom-state state)))
 634
 635 (defvar custom-variable-menu
 636   '(("Edit" . custom-variable-edit)
 637     ("Edit Default" . custom-variable-edit-lisp)
 638     ("Apply" . custom-variable-apply)
 639     ("Set Default" . custom-variable-set-default)
 640     ("Reset" . custom-redraw)
 641     ("Reset to Default" . custom-variable-default)
 642     ("Reset to Factory Settings" . custom-variable-factory))
 643   "Alist of actions for the `custom-variable' widget.
 644 The key is a string containing the name of the action, the value is a
 645 lisp function taking the widget as an element which will be called
 646 when the action is chosen.")
 647
 648 (defun custom-variable-action (widget &optional event)
 649   "Show the menu for `custom-variable' WIDGET.
 650 Optional EVENT is the location for the menu."
 651   (let* ((completion-ignore-case t)
 652          (answer (widget-choose (symbol-name (widget-get widget :value))
 653                                 custom-variable-menu
 654                                 event)))
 655     (if answer
 656         (funcall answer widget))))
 657
 658 (defun custom-variable-edit (widget)
 659   "Edit value of WIDGET."
 660   (widget-put widget :custom-state 'unknown)
 661   (widget-put widget :custom-form 'edit)
 662   (custom-redraw widget))
 663
 664 (defun custom-variable-edit-lisp (widget)
 665   "Edit the lisp representation of the value of WIDGET."
 666   (widget-put widget :custom-state 'unknown)
 667   (widget-put widget :custom-form 'lisp)
 668   (custom-redraw widget))
 669
 670 (defun custom-variable-apply (widget)
 671   "Set the current value for the variable being edited by WIDGET."
 672   (let ((form (widget-get widget :custom-form))
 673         (state (widget-get widget :custom-state))
 674         (child (car (widget-get widget :children)))
 675         (symbol (widget-value widget))
 676         val)
 677     (cond ((eq state 'hidden)
 678            (error "Cannot apply hidden variable."))
 679           ((setq val (widget-apply child :validate))
 680            (error "Invalid %S" val))
 681           ((eq form 'lisp)
 682            (set symbol (eval (widget-value child))))
 683           (t
 684            (set symbol (widget-value child))))
 685     (custom-variable-state-set widget)
 686     (custom-redraw-magic widget)))
 687
 688 (defun custom-variable-set-default (widget)
 689   "Set the default value for the variable being edited by WIDGET."
 690   (let ((form (widget-get widget :custom-form))
 691         (state (widget-get widget :custom-state))
 692         (child (car (widget-get widget :children)))
 693         (symbol (widget-value widget))
 694         val)
 695     (cond ((eq state 'hidden)
 696            (error "Cannot apply hidden variable."))
 697           ((setq val (widget-apply child :validate))
 698            (error "Invalid %S" val))
 699           ((eq form 'lisp)
 700            (setq custom-save-needed-p (cons symbol custom-save-needed-p))
 701            (put symbol 'saved-value (list (widget-value child)))
 702            (set symbol (eval (widget-value child))))
 703           (t
 704            (setq custom-save-needed-p (cons symbol custom-save-needed-p))
 705            (put symbol
 706                 'saved-value (list (custom-quote (widget-value
 707                                                   child))))
 708            (set symbol (widget-value child))))
 709     (custom-variable-state-set widget)
 710     (custom-redraw-magic widget)))
 711
 712 (defun custom-variable-default (widget)
 713   "Restore the default value for the variable being edited by WIDGET."
 714   (let ((symbol (widget-value widget)))
 715     (if (get symbol 'saved-value)
 716         (condition-case nil
 717             (set symbol (eval (car (get symbol 'saved-value))))
 718           (error nil))
 719       (error "No default value for %s" symbol))
 720     (widget-put widget :custom-state 'unknown)
 721     (custom-redraw widget)))
 722
 723 (defun custom-variable-factory (widget)
 724   "Restore the factory setting for the variable being edited by WIDGET."
 725   (let ((symbol (widget-value widget)))
 726     (if (get symbol 'factory-value)
 727         (set symbol (eval (car (get symbol 'factory-value))))
 728       (error "No factory default for %S" symbol))
 729     (when (get symbol 'saved-value)
 730       (setq custom-save-needed-p (cons symbol custom-save-needed-p))
 731       (put symbol 'saved-value nil))
 732     (widget-put widget :custom-state 'unknown)
 733     (custom-redraw widget)))
 734
 735 ;;; The `custom-face-edit' Widget.
 736
 737 (defvar custom-face-edit-args
 738   (mapcar (lambda (att)
 739             (list 'group
 740                   :inline t
 741                   (list 'const :format "" :value (nth 0 att))
 742                   (nth 1 att)))
 743           custom-face-attributes))
 744
 745 (define-widget 'custom-face-edit 'checklist
 746   "Edit face attributes."
 747   :format "%t: %v"
 748   :tag "Attributes"
 749   :extra-offset 12
 750   :args (mapcar (lambda (att)
 751                   (list 'group
 752                         :inline t
 753                         (list 'const :format "" :value (nth 0 att))
 754                         (nth 1 att)))
 755                 custom-face-attributes))
 756
 757 ;;; The `custom-display' Widget.
 758
 759 (define-widget 'custom-display 'menu-choice
 760   "Select a display type."
 761   :tag "Display"
 762   :value t
 763   :args '((const :tag "all" t)
 764           (checklist :offset 0
 765                      :extra-offset 9
 766                      :args ((group (const :format "Type: " type)
 767                                    (checklist :inline t
 768                                               :offset 0
 769                                               (const :format "X "
 770                                                      x)
 771                                               (const :format "TTY%n"
 772                                                      tty)))
 773                             (group (const :format "Class: " class)
 774                                    (checklist :inline t
 775                                               :offset 0
 776                                               (const :format "Color "
 777                                                      color)
 778                                               (const :format
 779                                                      "Grayscale "
 780                                                      grayscale)
 781                                               (const :format "Monochrome%n"
 782                                                      mono)))
 783                             (group  (const :format "Background: " background)
 784                                     (checklist :inline t
 785                                                :offset 0
 786                                                (const :format "Light "
 787                                                       light)
 788                                                (const :format "Dark\n"
 789                                                       dark)))))))
 790
 791 ;;; The `custom-face' Widget.
 792
 793 (define-widget 'custom-face 'custom
 794   "Customize face."
 795   :format "%l%[%t%]: %s%m %h%a%v"
 796   :format-handler 'custom-face-format-handler
 797   :help-echo "Push me to set or reset this face."
 798   :documentation-property 'face-documentation
 799   :value-create 'custom-face-value-create
 800   :action 'custom-face-action
 801   :custom-apply 'custom-face-apply
 802   :custom-set-default 'custom-face-set-default
 803   :custom-reset 'custom-redraw)
 804
 805 (defun custom-face-format-handler (widget escape)
 806   ;; We recognize extra escape sequences.
 807   (let (child
 808         (state (widget-get widget :custom-state))
 809         (symbol (widget-get widget :value)))
 810     (cond ((eq escape ?s)
 811            (setq child (widget-create-child-and-convert
 812                         widget 'custom-level
 813                         :format "(%[%t%])\n"
 814                         :button-face symbol
 815                         (if (eq state 'hidden) "show" "hide"))))
 816           (t
 817            (custom-format-handler widget escape)))
 818     (when child
 819       (widget-put widget
 820                   :buttons (cons child (widget-get widget :buttons))))))
 821
 822 (defun custom-face-value-create (widget)
 823   ;; Create a list of the display specifications.
 824   (unless (eq (preceding-char) ?\n)
 825     (insert "\n"))
 826   (when (not (eq (widget-get widget :custom-state) 'hidden))
 827     (let* ((symbol (widget-value widget))
 828            (edit (widget-create-child-and-convert
 829                   widget 'editable-list
 830                   :entry-format "%i %d %v"
 831                   :value (or (get symbol 'saved-face)
 832                              (get symbol 'factory-face))
 833                   '(group :format "%v"
 834                           custom-display custom-face-edit))))
 835       (custom-face-state-set widget)
 836       (widget-put widget :children (list edit)))))
 837
 838 (defvar custom-face-menu
 839   '(("Apply" . custom-face-apply)
 840     ("Set Default" . custom-face-set-default)
 841     ("Reset to Default" . custom-face-default)
 842     ("Reset to Factory Setting" . custom-face-factory))
 843   "Alist of actions for the `custom-face' widget.
 844 The key is a string containing the name of the action, the value is a
 845 lisp function taking the widget as an element which will be called
 846 when the action is chosen.")
 847
 848 (defun custom-face-state-set (widget)
 849   "Set the state of WIDGET."
 850   (let ((symbol (widget-value widget)))
 851     (widget-put widget :custom-state (cond ((get symbol 'saved-face)
 852                                             'saved)
 853                                            ((get symbol 'factory-face)
 854                                             'factory)
 855                                            (t
 856                                             'rogue)))))
 857
 858 (defun custom-face-action (widget &optional event)
 859   "Show the menu for `custom-face' WIDGET.
 860 Optional EVENT is the location for the menu."
 861   (when (eq (widget-get widget :custom-state) 'hidden)
 862     (error "You cannot edit a hidden face"))
 863   (let* ((completion-ignore-case t)
 864          (symbol (widget-get widget :value))
 865          (answer (widget-choose (symbol-name symbol) custom-face-menu event)))
 866     (if answer
 867         (funcall answer widget))))
 868
 869 (defun custom-face-apply (widget)
 870   "Make the face attributes in WIDGET take effect."
 871   (let* ((symbol (widget-value widget))
 872          (child (car (widget-get widget :children)))
 873          (value (widget-value child)))
 874     (custom-face-display-set symbol value)
 875     (custom-face-state-set widget)
 876     (custom-redraw-magic widget)))
 877
 878 (defun custom-face-set-default (widget)
 879   "Make the face attributes in WIDGET default."
 880   (let* ((symbol (widget-value widget))
 881          (child (car (widget-get widget :children)))
 882          (value (widget-value child)))
 883     (custom-face-display-set symbol value)
 884     (put symbol 'saved-face value)
 885     (custom-face-state-set widget)
 886     (custom-redraw-magic widget)))
 887
 888 (defun custom-face-default (widget)
 889   "Restore WIDGET to the face's default attributes."
 890   (let* ((symbol (widget-value widget))
 891          (child (car (widget-get widget :children)))
 892          (value (get symbol 'saved-face)))
 893     (unless value
 894       (error "No saved value for this face")
 895       (custom-face-display-set symbol value)
 896     (widget-value-set child value)
 897     (custom-face-state-set widget)
 898     (custom-redraw-magic widget))))
 899
 900 (defun custom-face-factory (widget)
 901   "Restore WIDGET to the face's factory settings."
 902   (let* ((symbol (widget-value widget))
 903          (child (car (widget-get widget :children)))
 904          (value (get symbol 'factory-face)))
 905     (unless value
 906       (error "No factory default for this face"))
 907     (when (get symbol 'saved-face)
 908       (put symbol 'saved-face nil))
 909     (custom-face-display-set symbol value)
 910     (widget-value-set child value)
 911     (custom-face-state-set widget)
 912     (custom-redraw-magic widget)))
 913
 914 ;;; The `face' Widget.
 915
 916 (define-widget 'face 'default
 917   "Select and customize a face."
 918   :convert-widget 'widget-item-convert-widget
 919   :format "%[%t%]: %v"
 920   :tag "Face"
 921   :value 'default
 922   :value-create 'widget-face-value-create
 923   :value-delete 'widget-face-value-delete
 924   :value-get 'widget-item-value-get
 925   :validate 'widget-editable-list-validate
 926   :action 'widget-face-action
 927   :match '(lambda (widget value) (symbolp value)))
 928
 929 (defun widget-face-value-create (widget)
 930   ;; Create a `custom-face' child.
 931   (let* ((symbol (widget-value widget))
 932          (child (widget-create-child-and-convert
 933                  widget 'custom-face
 934                  :format "%t %s%m %h%v"
 935                  :custom-level nil
 936                  :value symbol)))
 937     (custom-magic-reset child)
 938     (setq custom-options (cons child custom-options))
 939     (widget-put widget :children (list child))))
 940
 941 (defun widget-face-value-delete (widget)
 942   ;; Remove the child from the options.
 943   (let ((child (car (widget-get widget :children))))
 944     (setq custom-options (delq child custom-options))
 945     (widget-children-value-delete widget)))
 946
 947 (defvar face-history nil
 948   "History of entered face names.")
 949
 950 (defun widget-face-action (widget &optional event)
 951   "Prompt for a face."
 952   (let ((answer (completing-read "Face: "
 953                                  (mapcar (lambda (face)
 954                                            (list (symbol-name face)))
 955                                          (face-list))
 956                                  nil nil nil
 957                                  'face-history)))
 958     (unless (zerop (length answer))
 959       (widget-value-set widget (intern answer))
 960       (widget-apply widget :notify widget event)
 961       (widget-setup))))
 962
 963 ;;; The `hook' Widget.
 964
 965 (define-widget 'hook 'list
 966   "A emacs lisp hook"
 967   :convert-widget 'custom-hook-convert-widget
 968   :tag "Hook")
 969
 970 (defun custom-hook-convert-widget (widget)
 971   ;; Handle `:custom-options'.
 972   (let* ((options (widget-get widget :options))
 973          (other `(editable-list :inline t (function :format "%v")))
 974          (args (if options
 975                    (list `(checklist :inline t
 976                                      ,@(mapcar (lambda (entry)
 977                                                  `(function-item ,entry))
 978                                                options))
 979                          other)
 980                  (list other))))
 981     (widget-put widget :args args)
 982     widget))
 983
 984 ;;; The `custom-group' Widget.
 985
 986 (define-widget 'custom-group 'custom
 987   "Customize group."
 988   :format "%l%[%t%]: %L\n%m %h%a%v"
 989   :documentation-property 'group-documentation
 990   :help-echo "Push me to set or reset all members of this group."
 991   :value-create 'custom-group-value-create
 992   :action 'custom-group-action
 993   :custom-apply 'custom-group-apply
 994   :custom-set-default 'custom-group-set-default
 995   :custom-reset 'custom-group-reset)
 996
 997 (defun custom-group-value-create (widget)
 998   (let* ((state (widget-get widget :custom-state))
 999          (level (widget-get widget :custom-level))
1000          (symbol (widget-value widget))
1001          (members (get symbol 'custom-group)))
1002     (unless (eq state 'hidden)
1003       (let* ((children (mapcar (lambda (entry)
1004                                  (widget-insert "\n")
1005                                  (prog1
1006                                      (widget-create-child-and-convert
1007                                       widget (nth 1 entry)
1008                                       :group widget
1009                                       :custom-level (1+ level)
1010                                       :value (nth 0 entry))
1011                                    (unless (eq (preceding-char) ?\n)
1012                                      (widget-insert "\n"))))
1013                                members)))
1014         (mapcar 'custom-magic-reset children)
1015         (widget-put widget :children children)
1016         (custom-group-state-update widget)))))
1017
1018 (defvar custom-group-menu
1019   '(("Apply" . custom-group-apply)
1020     ("Set Default" . custom-group-set-default)
1021     ("Reset" . custom-group-reset))
1022   "Alist of actions for the `custom-group' widget.
1023 The key is a string containing the name of the action, the value is a
1024 lisp function taking the widget as an element which will be called
1025 when the action is chosen.")
1026
1027 (defun custom-group-action (widget &optional event)
1028   "Show the menu for `custom-group' WIDGET.
1029 Optional EVENT is the location for the menu."
1030   (let* ((completion-ignore-case t)
1031          (answer (widget-choose (symbol-name (widget-get widget :value))
1032                                 custom-group-menu
1033                                 event)))
1034     (if answer
1035         (funcall answer widget))))
1036
1037 (defun custom-group-apply (widget)
1038   "Apply changes in all modified group members."
1039   (let ((children (widget-get widget :children)))
1040     (mapcar (lambda (child)
1041               (when (eq (widget-get child :custom-state) 'modified)
1042                 (widget-apply child :custom-apply)))
1043             children )))
1044
1045 (defun custom-group-set-default (widget)
1046   "Set default in all modified group members."
1047   (let ((children (widget-get widget :children)))
1048     (mapcar (lambda (child)
1049               (when (eq (widget-get child :custom-state) 'modified)
1050                 (widget-apply child :custom-set-default)))
1051             children )))
1052
1053 (defun custom-group-reset (widget)
1054   "Reset all modified group members."
1055   (let ((children (widget-get widget :children)))
1056     (mapcar (lambda (child)
1057               (when (eq (widget-get child :custom-state) 'modified)
1058                 (widget-apply child :custom-reset)))
1059             children )))
1060
1061 (defun custom-group-state-update (widget)
1062   "Update magic."
1063   (unless (eq (widget-get widget :custom-state) 'hidden)
1064     (let* ((children (widget-get widget :children))
1065            (states (mapcar (lambda (child)
1066                              (widget-get child :custom-state))
1067                            children))
1068            (magics custom-magic-alist)
1069            (found 'factory))
1070       (while magics
1071         (let ((magic (car (car magics))))
1072           (if (and (not (eq magic 'hidden))
1073                    (memq magic states))
1074               (setq found magic
1075                     magics nil)
1076             (setq magics (cdr magics)))))
1077       (widget-put widget :custom-state found)))
1078   (custom-magic-reset widget))
1079
1080 ;;; The `custom-save' Command.
1081
1082 (defcustom custom-file "~/.emacs"
1083   "File used for storing customization information.
1084 If you change this from the default \"~/.emacs\" you need to
1085 explicitly load that file for the settings to take effect."
1086   :type 'file
1087   :group 'customize)
1088
1089 (defun custom-save-delete (symbol)
1090   "Delete the call to SYMBOL form `custom-file'.
1091 Leave point at the location of the call, or after the last expression."
1092   (set-buffer (find-file-noselect custom-file))
1093   (goto-char (point-min))
1094   (catch 'found
1095     (while t
1096       (let ((sexp (condition-case nil
1097                       (read (current-buffer))
1098                     (end-of-file (throw 'found nil)))))
1099         (when (and (listp sexp)
1100                    (eq (car sexp) symbol))
1101           (delete-region (save-excursion
1102                            (backward-sexp)
1103                            (point))
1104                          (point))
1105           (throw 'found nil))))))
1106
1107 (defun custom-save-variables ()
1108   "Save all customized variables in `custom-file'."
1109   (save-excursion
1110     (custom-save-delete 'custom-set-variables)
1111     (let ((standard-output (current-buffer)))
1112       (unless (bolp)
1113         (princ "\n"))
1114       (princ "(custom-set-variables")
1115       (mapatoms (lambda (symbol)
1116                   (let ((value (get symbol 'saved-value)))
1117                     (when value
1118                       (princ "\n '(")
1119                       (princ symbol)
1120                       (princ " ")
1121                       (prin1 (car value))
1122                       (if (or (get symbol 'factory-value)
1123                               (and (not (boundp symbol))
1124                                    (not (get symbol 'force-value))))
1125                           (princ ")")
1126                         (princ " t)"))))))
1127       (princ ")")
1128       (unless (eolp)
1129         (princ "\n")))))
1130
1131 (defun custom-save-faces ()
1132   "Save all customized faces in `custom-file'."
1133   (save-excursion
1134     (custom-save-delete 'custom-set-faces)
1135     (let ((standard-output (current-buffer)))
1136       (unless (bolp)
1137         (princ "\n"))
1138       (princ "(custom-set-faces")
1139       (mapatoms (lambda (symbol)
1140                   (let ((value (get symbol 'saved-face)))
1141                     (when value
1142                       (princ "\n '(")
1143                       (princ symbol)
1144                       (princ " ")
1145                       (prin1 value)
1146                       (if (or (get symbol 'factory-face)
1147                               (and (not (custom-facep symbol))
1148                                    (not (get symbol 'force-face))))
1149                           (princ ")")
1150                         (princ " t)"))))))
1151       (princ ")")
1152       (unless (eolp)
1153         (princ "\n")))))
1154
1155 (defun custom-save ()
1156   "Save all customizations in `custom-file'."
1157   (interactive)
1158   (custom-save-variables)
1159   (custom-save-faces)
1160   (setq custom-save-needed-p nil)
1161   (save-excursion
1162     (set-buffer (find-file-noselect custom-file))
1163     (save-buffer)))
1164
1165 ;;; The End.
1166
1167 (provide 'custom-edit)
1168
1169 ;; custom-edit.el ends here