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