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