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.98
   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-default-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            (set symbol (eval (widget-value child))))
 428           (t
 429            (put symbol
 430                 'saved-value (list (custom-quote (widget-value
 431                                                   child))))
 432            (set symbol (widget-value child))))
 433     (custom-variable-state-set widget)
 434     (custom-redraw-magic widget)))
 435
 436 (defun custom-variable-default (widget)
 437   "Restore the default value for the variable being edited by WIDGET."
 438   (let ((symbol (widget-value widget)))
 439     (if (get symbol 'saved-value)
 440         (set symbol (car (get symbol 'saved-value)))
 441       (error "No default value for %s" symbol))
 442     (widget-put widget :custom-state 'unknown)
 443     (custom-redraw widget)))
 444
 445 (defun custom-variable-factory (widget)
 446   "Restore the factory setting for the variable being edited by WIDGET."
 447   (let ((symbol (widget-value widget)))
 448     (if (get symbol 'factory-value)
 449         (set symbol (car (get symbol 'factory-value)))
 450       (error "No factory default for %S" symbol))
 451     (when (get symbol 'saved-value)
 452       (put symbol 'saved-value nil))
 453     (widget-put widget :custom-state 'unknown)
 454     (custom-redraw widget)))
 455
 456 ;;; The `custom-face-edit' Widget.
 457
 458 (defvar custom-face-edit-args
 459   (mapcar (lambda (att)
 460             (list 'group
 461                   :inline t
 462                   (list 'const :format "" :value (nth 0 att))
 463                   (nth 1 att)))
 464           custom-face-attributes))
 465
 466 (define-widget 'custom-face-edit 'checklist
 467   "Edit face attributes."
 468   :format "%t: %v"
 469   :tag "Attributes"
 470   :extra-offset 12
 471   :args (mapcar (lambda (att)
 472                   (list 'group
 473                         :inline t
 474                         (list 'const :format "" :value (nth 0 att))
 475                         (nth 1 att)))
 476                 custom-face-attributes))
 477
 478 ;;; The `custom-display' Widget.
 479
 480 (define-widget 'custom-display 'menu-choice
 481   "Select a display type."
 482   :tag "Display"
 483   :value t
 484   :args '((const :tag "all" t)
 485           (checklist :offset 0
 486                      :extra-offset 9
 487                      :args ((group (const :format "Type: " type)
 488                                    (checklist :inline t
 489                                               :offset 0
 490                                               (const :format "X "
 491                                                      x)
 492                                               (const :format "TTY%n"
 493                                                      tty)))
 494                             (group (const :format "Class: " class)
 495                                    (checklist :inline t
 496                                               :offset 0
 497                                               (const :format "Color "
 498                                                      color)
 499                                               (const :format
 500                                                      "Grayscale "
 501                                                      grayscale)
 502                                               (const :format "Monochrome%n"
 503                                                      mono)))
 504                             (group  (const :format "Background: " background)
 505                                     (checklist :inline t
 506                                                :offset 0
 507                                                (const :format "Light "
 508                                                       light)
 509                                                (const :format "Dark\n"
 510                                                       dark)))))))
 511
 512 ;;; The `custom-face' Widget.
 513
 514 (define-widget 'custom-face 'custom
 515   "Customize face."
 516   :format "%l%[%t%]: %s%m %h%v"
 517   :format-handler 'custom-face-format-handler
 518   :help-echo "Push me to set or reset this face."
 519   :documentation-property 'face-documentation
 520   :value-create 'custom-face-value-create
 521   :action 'custom-face-action
 522   :custom-apply 'custom-face-apply
 523   :custom-set-default 'custom-face-set-default
 524   :custom-reset 'custom-redraw)
 525
 526 (defun custom-face-format-handler (widget escape)
 527   ;; We recognize extra escape sequences.
 528   (let* (child
 529          (symbol (widget-get widget :value)))
 530     (cond ((eq escape ?s)
 531            (setq child (widget-create-child-and-convert
 532                         widget 'custom-level
 533                         :format "(%[sample%])\n"
 534                         :button-face symbol)))
 535           (t
 536            (custom-format-handler widget escape)))
 537     (when child
 538       (widget-put widget
 539                   :buttons (cons child (widget-get widget :buttons))))))
 540
 541 (defun custom-face-value-create (widget)
 542   ;; Create a list of the display specifications.
 543   (unless (eq (preceding-char) ?\n)
 544     (insert "\n"))
 545   (when (not (eq (widget-get widget :custom-state) 'hidden))
 546     (let* ((symbol (widget-value widget))
 547            (edit (widget-create-child-and-convert
 548                   widget 'editable-list
 549                   :entry-format "%i %d %v"
 550                   :value (or (get symbol 'saved-face)
 551                              (get symbol 'factory-face))
 552                   '(group :format "%v"
 553                           custom-display custom-face-edit))))
 554       (custom-face-state-set widget)
 555       (widget-put widget :children (list edit)))))
 556
 557 (defvar custom-face-menu
 558   '(("Apply" . custom-face-apply)
 559     ("Set Default" . custom-face-set-default)
 560     ("Reset to Default" . custom-face-default)
 561     ("Reset to Factory Setting" . custom-face-factory))
 562   "Alist of actions for the `custom-face' widget.
 563 The key is a string containing the name of the action, the value is a
 564 lisp function taking the widget as an element which will be called
 565 when the action is chosen.")
 566
 567 (defun custom-face-state-set (widget)
 568   "Set the state of WIDGET."
 569   (let ((symbol (widget-value widget)))
 570     (widget-put widget :custom-state (cond ((get symbol 'saved-face)
 571                                             'saved)
 572                                            ((get symbol 'factory-face)
 573                                             'factory)
 574                                            (t
 575                                             'rogue)))))
 576
 577 (defun custom-face-action (widget &optional event)
 578   "Show the menu for `custom-face' WIDGET.
 579 Optional EVENT is the location for the menu."
 580   (when (eq (widget-get widget :custom-state) 'hidden)
 581     (error "You cannot edit a hidden face"))
 582   (let* ((completion-ignore-case t)
 583          (symbol (widget-get widget :value))
 584          (answer (widget-choose (symbol-name symbol) custom-face-menu event)))
 585     (if answer
 586         (funcall answer widget))
 587     (custom-face-state-set widget)
 588     (custom-redraw-magic widget)))
 589
 590 (defun custom-face-apply (widget)
 591   "Make the face attributes in WIDGET take effect."
 592   (let* ((symbol (widget-value widget))
 593          (child (car (widget-get widget :children)))
 594          (value (widget-value child)))
 595     (custom-face-display-set symbol value)))
 596
 597 (defun custom-face-set-default (widget)
 598   "Make the face attributes in WIDGET default."
 599   (let* ((symbol (widget-value widget))
 600          (child (car (widget-get widget :children)))
 601          (value (widget-value child)))
 602     (put symbol 'saved-face value)))
 603
 604 (defun custom-face-default (widget)
 605   "Restore WIDGET to the face's default attributes."
 606   (let* ((symbol (widget-value widget))
 607          (child (car (widget-get widget :children))))
 608     (unless (get symbol 'saved-face)
 609       (error "No saved value for this face")
 610       (widget-value-set child (get symbol 'saved-face)))))
 611
 612 (defun custom-face-factory (widget)
 613   "Restore WIDGET to the face's factory settings."
 614   (let* ((symbol (widget-value widget))
 615          (child (car (widget-get widget :children))))
 616     (unless (get symbol 'factory-face)
 617       (error "No factory default for this face"))
 618     (when (get symbol 'saved-face)
 619       (put symbol 'saved-face nil))
 620     (widget-value-set child (get symbol 'factory-face))))
 621
 622 ;;; The `face' Widget.
 623
 624 (define-widget 'face 'default
 625   "Select and customize a face."
 626   :convert-widget 'widget-item-convert-widget
 627   :format "%[%t%]%v"
 628   :value 'default
 629   :value-create 'widget-face-value-create
 630   :value-delete 'widget-radio-value-delete
 631   :value-get 'widget-item-value-get
 632   :validate 'widget-editable-list-validate
 633   :action 'widget-face-action
 634   :match '(lambda (widget value) (symbolp value)))
 635
 636 (defun widget-face-value-create (widget)
 637   ;; Create a `custom-face' child.
 638   (let* ((symbol (widget-value widget))
 639          (child (widget-create-child-and-convert
 640                  widget 'custom-face
 641                  :custom-level nil
 642                  :tag ""
 643                  :value symbol)))
 644     (custom-magic-reset child)
 645     (widget-put widget :children (list child))))
 646
 647 (defvar face-history nil
 648   "History of entered face names.")
 649
 650 (defun widget-face-action (widget &optional event)
 651   "Prompt for a face."
 652   (let ((answer (completing-read "Face: "
 653                                  (mapcar (lambda (face)
 654                                            (list (symbol-name face)))
 655                                          (face-list))
 656                                  nil nil nil
 657                                  'face-history)))
 658     (unless (zerop (length answer))
 659       (widget-value-set widget (intern answer))
 660       (widget-setup))))
 661
 662 ;;; The `custom-group' Widget.
 663
 664 (define-widget 'custom-group 'custom
 665   "Customize group."
 666   :format "%l%[%t%]:\n%m %h%v"
 667   :documentation-property 'group-documentation
 668   :help-echo "Push me to set or reset all members of this group."
 669   :value-create 'custom-group-value-create
 670   :action 'custom-group-action
 671   :custom-apply 'custom-group-apply
 672   :custom-set-default 'custom-group-set-default
 673   :custom-reset 'custom-group-reset)
 674
 675 (defun custom-group-value-create (widget)
 676   (let* ((state (widget-get widget :custom-state))
 677          (level (widget-get widget :custom-level))
 678          (symbol (widget-value widget))
 679          (members (get symbol 'custom-group)))
 680     (unless (eq state 'hidden)
 681       (let* ((children (mapcar (lambda (entry)
 682                                  (widget-insert "\n")
 683                                  (prog1
 684                                      (widget-create-child-and-convert
 685                                       widget (nth 1 entry)
 686                                       :group widget
 687                                       :custom-level (1+ level)
 688                                       :value (nth 0 entry))
 689                                    (unless (eq (preceding-char) ?\n)
 690                                      (widget-insert "\n"))))
 691                                members)))
 692         (mapcar 'custom-magic-reset children)
 693         (widget-put widget :children children)
 694         (custom-group-state-update widget)))))
 695
 696 (defvar custom-group-menu
 697   '(("Apply" . custom-group-apply)
 698     ("Set Default" . custom-group-set-default)
 699     ("Reset" . custom-group-reset))
 700   "Alist of actions for the `custom-group' widget.
 701 The key is a string containing the name of the action, the value is a
 702 lisp function taking the widget as an element which will be called
 703 when the action is chosen.")
 704
 705 (defun custom-group-action (widget &optional event)
 706   "Show the menu for `custom-group' WIDGET.
 707 Optional EVENT is the location for the menu."
 708   (let* ((completion-ignore-case t)
 709          (answer (widget-choose (symbol-name (widget-get widget :value))
 710                                 custom-group-menu
 711                                 event)))
 712     (if answer
 713         (funcall answer widget))))
 714
 715 (defun custom-group-apply (widget)
 716   "Apply changes in all modified group members."
 717   (let ((children (widget-get widget :children)))
 718     (mapcar (lambda (child)
 719               (when (eq (widget-get child :custom-state) 'modified)
 720                 (widget-apply child :custom-apply)))
 721             children )))
 722
 723 (defun custom-group-set-default (widget)
 724   "Set default in all modified group members."
 725   (let ((children (widget-get widget :children)))
 726     (mapcar (lambda (child)
 727               (when (eq (widget-get child :custom-state) 'modified)
 728                 (widget-apply child :custom-set-default)))
 729             children )))
 730
 731 (defun custom-group-reset (widget)
 732   "Reset all modified group members."
 733   (let ((children (widget-get widget :children)))
 734     (mapcar (lambda (child)
 735               (when (eq (widget-get child :custom-state) 'modified)
 736                 (widget-apply child :custom-reset)))
 737             children )))
 738
 739 (defun custom-group-state-update (widget)
 740   "Update magic."
 741   (unless (eq (widget-get widget :custom-state) 'hidden)
 742     (let* ((children (widget-get widget :children))
 743            (states (mapcar (lambda (child)
 744                              (widget-get child :custom-state))
 745                            children))
 746            (magics custom-magic-alist)
 747            (found 'factory))
 748       (while magics
 749         (let ((magic (car (car magics))))
 750           (if (and (not (eq magic 'hidden))
 751                    (memq magic states))
 752               (setq found magic
 753                     magics nil)
 754             (setq magics (cdr magics)))))
 755       (widget-put widget :custom-state found)))
 756   (custom-magic-reset widget))
 757
 758 ;;; The `custom-save' Command.
 759
 760 (defcustom custom-file "~/.emacs"
 761   "File used for storing customization information.
 762 If you change this from the default \"~/.emacs\" you need to
 763 explicitly load that file for the settings to take effect."
 764   :type 'file
 765   :group 'customize)
 766
 767 (defun custom-save-delete (symbol)
 768   "Delete the call to SYMBOL form `custom-file'.
 769 Leave point at the location of the call, or after the last expression."
 770   (set-buffer (find-file-noselect custom-file))
 771   (goto-char (point-min))
 772   (catch 'found
 773     (while t
 774       (let ((sexp (condition-case nil
 775                       (read (current-buffer))
 776                     (end-of-file (throw 'found nil)))))
 777         (when (and (listp sexp)
 778                    (eq (car sexp) symbol))
 779           (delete-region (save-excursion
 780                            (backward-sexp)
 781                            (point))
 782                          (point))
 783           (throw 'found nil))))))
 784
 785 (defun custom-save-variables ()
 786   "Save all customized variables in `custom-file'."
 787   (save-excursion
 788     (custom-save-delete 'custom-set-variables)
 789     (let ((standard-output (current-buffer)))
 790       (unless (bolp)
 791         (princ "\n"))
 792       (princ "(custom-set-variables")
 793       (mapatoms (lambda (symbol)
 794                   (let ((value (get symbol 'saved-value)))
 795                     (when value
 796                       (princ "\n '")
 797                       (princ symbol)
 798                       (princ " '")
 799                       (prin1 (car value))))))
 800       (princ ")")
 801       (unless (eolp)
 802         (princ "\n")))))
 803
 804 (defun custom-save-faces ()
 805   "Save all customized faces in `custom-file'."
 806   (save-excursion
 807     (custom-save-delete 'custom-set-faces)
 808     (let ((standard-output (current-buffer)))
 809       (unless (bolp)
 810         (princ "\n"))
 811       (princ "(custom-set-faces")
 812       (mapatoms (lambda (symbol)
 813                   (let ((value (get symbol 'saved-face)))
 814                     (when value
 815                       (princ "\n '")
 816                       (princ symbol)
 817                       (princ " '")
 818                       (prin1 value)))))
 819       (princ ")")
 820       (unless (eolp)
 821         (princ "\n")))))
 822
 823 (defun custom-save ()
 824   "Save all customizations in `custom-file'."
 825   (interactive)
 826   (custom-save-variables)
 827   (custom-save-faces)
 828   (save-excursion
 829     (set-buffer (find-file-noselect custom-file))
 830     (save-buffer)))
 831
 832 ;;; The Custom Mode.
 833
 834 (defvar custom-options nil
 835   "Customization widgets in the current buffer.")
 836
 837 (defvar custom-mode-map nil
 838   "Keymap for `custom-mode'.")
 839
 840 (unless custom-mode-map
 841   (setq custom-mode-map (make-sparse-keymap))
 842   (set-keymap-parent custom-mode-map widget-keymap))
 843
 844 (easy-menu-define custom-mode-menu
 845     custom-mode-map
 846   "Menu used in customization buffers."
 847     '("Custom"
 848       ["Apply" custom-apply t]
 849       ["Set Default" custom-set-default t]
 850       ["Reset" custom-reset t]
 851       ["Save" custom-save t]))
 852
 853 (defun custom-mode ()
 854   "Major mode for editing customization buffers.
 855
 856 The following commands are available:
 857
 858 \\[widget-forward]              Move to next button or editable field.
 859 \\[widget-backward]             Move to previous button or editable field.
 860 \\[widget-button-click]         Activate button under the mouse pointer.
 861 \\[widget-button-press]         Activate button under point.
 862 \\[custom-apply]                Apply all modifications.
 863 \\[custom-set-default]          Make all modifications default.
 864 \\[custom-reset]                Undo all modifications.
 865 \\[custom-save]                 Save defaults for future emacs sessions.
 866
 867 Entry to this mode calls the value of `custom-mode-hook'
 868 if that value is non-nil."
 869   (kill-all-local-variables)
 870   (setq major-mode 'custom-mode
 871         mode-name "Custom")
 872   (use-local-map custom-mode-map)
 873   (make-local-variable 'custom-options)
 874   (run-hooks 'custom-mode-hook))
 875
 876 ;;; Custom Mode Commands.
 877
 878 (defun custom-apply ()
 879   "Apply changes in all modified options."
 880   (interactive)
 881   (let ((children custom-options))
 882     (mapcar (lambda (child)
 883               (when (eq (widget-get child :custom-state) 'modified)
 884                 (widget-apply child :custom-apply)))
 885             children)))
 886
 887 (defun custom-set-default ()
 888   "Set default in all modified group members."
 889   (interactive)
 890   (let ((children custom-options))
 891     (mapcar (lambda (child)
 892               (when (eq (widget-get child :custom-state) 'modified)
 893                 (widget-apply child :custom-set-default)))
 894             children)))
 895
 896 (defun custom-reset ()
 897   "Reset all modified group members."
 898   (interactive)
 899   (let ((children custom-options))
 900     (mapcar (lambda (child)
 901               (when (eq (widget-get child :custom-state) 'modified)
 902                 (widget-apply child :custom-reset)))
 903             children)))
 904
 905 ;;; The Customize Commands
 906
 907 ;;;###autoload
 908 (defun customize (symbol)
 909   "Customize SYMBOL, which must be a customization group."
 910   (interactive (list (completing-read "Customize group: (default emacs) "
 911                                       obarray
 912                                       (lambda (symbol)
 913                                         (get symbol 'custom-group))
 914                                       t)))
 915
 916   (when (stringp symbol)
 917     (if (string-equal "" symbol)
 918         (setq symbol 'emacs)
 919       (setq symbol (intern symbol))))
 920   (custom-buffer-create (list (list symbol 'custom-group))))
 921
 922 ;;;###autoload
 923 (defun customize-variable (symbol)
 924   "Customize SYMBOL, which must be a variable."
 925   (interactive
 926    ;; Code stolen from `help.el'.
 927    (let ((v (variable-at-point))
 928          (enable-recursive-minibuffers t)
 929          val)
 930      (setq val (completing-read
 931                 (if v
 932                     (format "Customize variable (default %s): " v)
 933                   "Customize variable: ")
 934                 obarray 'boundp t))
 935      (list (if (equal val "")
 936                v (intern val)))))
 937   (custom-buffer-create (list (list symbol 'custom-variable))))
 938
 939 ;;;###autoload
 940 (defun customize-face (symbol)
 941   "Customize FACE."
 942   (interactive (list (completing-read "Customize face: " obarray 'facep)))
 943   (unless (symbolp symbol)
 944     (error "Should be a symbol %S" symbol))
 945   (custom-buffer-create (list (list symbol 'custom-face))))
 946
 947 ;;;###autoload
 948 (defun customize-apropos (regexp &optional all)
 949   "Customize all user options matching REGEXP.
 950 If ALL (e.g., started with a prefix key), include options which are not
 951 user-settable."
 952   (interactive "sCustomize regexp: \nP")
 953   (let ((found nil))
 954     (mapatoms (lambda (symbol)
 955                 (when (string-match regexp (symbol-name symbol))
 956                   (when (get symbol 'custom-group)
 957                     (setq found (cons (list symbol 'custom-group) found)))
 958                   (when (facep symbol)
 959                     (setq found (cons (list symbol 'custom-face) found)))
 960                   (when (and (boundp symbol)
 961                              (or (get symbol 'default-value)
 962                                  (get symbol 'factory-value)
 963                                  (if all
 964                                      (get symbol 'variable-documentation)
 965                                    (user-variable-p symbol))))
 966                     (setq found
 967                           (cons (list symbol 'custom-variable) found))))))
 968     (if found
 969         (custom-buffer-create found)
 970       (error "No matches"))))
 971
 972 (defun custom-buffer-create (options)
 973   "Create a buffer containing OPTIONS.
 974 OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where
 975 SYMBOL is a customization option, and WIDGET is a widget for editing
 976 that option."
 977   (kill-buffer (get-buffer-create "*Customization*"))
 978   (switch-to-buffer (get-buffer-create "*Customization*"))
 979   (custom-mode)
 980   (widget-insert "This is a customization buffer.
 981 Push RET or click mouse-2 on the word ")
 982   (widget-create 'info-link
 983                  :tag "help"
 984                  :help-echo "Push me for help."
 985                  "(custom)The Customization Buffer")
 986   (widget-insert " for more information.\n\n")
 987   (setq custom-options
 988         (mapcar (lambda (entry)
 989                   (prog1
 990                       (widget-create (nth 1 entry)
 991                                      :value (nth 0 entry))
 992                     (unless (eq (preceding-char) ?\n)
 993                       (widget-insert "\n"))
 994                     (widget-insert "\n")))
 995                 options))
 996   (widget-create 'push-button
 997                  :tag "Apply"
 998                  :help-echo "Push me to apply all modifications."
 999                  :action (lambda (widget &optional event)
1000                            (custom-apply)))
1001   (widget-insert " ")
1002   (widget-create 'push-button
1003                  :tag "Set Default"
1004                  :help-echo "Push me to make the modifications default."
1005                  :action (lambda (widget &optional event)
1006                            (custom-set-default)))
1007   (widget-insert " ")
1008   (widget-create 'push-button
1009                  :tag "Reset"
1010                  :help-echo "Push me to undo all modifications.."
1011                  :action (lambda (widget &optional event)
1012                            (custom-reset)))
1013   (widget-insert " ")
1014   (widget-create 'push-button
1015                  :tag "Save"
1016                  :help-echo "Push me to store the new defaults permanently."
1017                  :action (lambda (widget &optional event)
1018                            (custom-save)))
1019   (widget-insert "\n")
1020   (widget-setup))
1021
1022 ;;; The End.
1023
1024 (provide 'custom-edit)
1025
1026 ;; custom-edit.el ends here