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

   1 ;;; custom.el --- User friendly customization support.
   2
   3 ;; Copyright (C) 1995, 1996 Free Software Foundation, Inc.
   4
   5 ;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
   6 ;; Keywords: help
   7 ;; Version: 0.5
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; WARNING: This package is still under construction and not all of
  29 ;; the features below are implemented.
  30 ;;
  31 ;; This package provides a framework for adding user friendly
  32 ;; customization support to Emacs.  Having to do customization by
  33 ;; editing a text file in some arcane syntax is user hostile in the
  34 ;; extreme, and to most users emacs lisp definitely count as arcane.
  35 ;;
  36 ;; The intent is that authors of emacs lisp packages declare the
  37 ;; variables intended for user customization with `custom-declare'.
  38 ;; Custom can then automatically generate a customization buffer with
  39 ;; `custom-buffer-create' where the user can edit the package
  40 ;; variables in a simple and intuitive way, as well as a menu with
  41 ;; `custom-menu-create' where he can set the more commonly used
  42 ;; variables interactively.
  43 ;;
  44 ;; It is also possible to use custom for modifying the properties of
  45 ;; other objects than the package itself, by specifying extra optional
  46 ;; arguments to `custom-buffer-create'.
  47 ;;
  48 ;; Custom is inspired by OPEN LOOK property windows.
  49
  50 ;;; Todo:
  51 ;;
  52 ;; - Toggle documentation in three states `none', `one-line', `full'.
  53 ;; - Function to generate an XEmacs menu from a CUSTOM.
  54 ;; - Write TeXinfo documentation.
  55 ;; - Make it possible to hide sections by clicking at the level.
  56 ;; - Declare AUC TeX variables.
  57 ;; - Declare (ding) Gnus variables.
  58 ;; - Declare Emacs variables.
  59 ;; - Implement remaining types.
  60 ;; - XEmacs port.
  61 ;; - Allow `URL', `info', and internal hypertext buttons.
  62 ;; - Support meta-variables and goal directed customization.
  63 ;; - Make it easy to declare custom types independently.
  64 ;; - Make it possible to declare default value and type for a single
  65 ;;   variable, storing the data in a symbol property.
  66 ;; - Syntactic sugar for CUSTOM declarations.
  67 ;; - Use W3 for variable documentation.
  68
  69 ;;; Code:
  70
  71 (eval-when-compile
  72   (require 'cl))
  73
  74 ;;; Compatibility:
  75
  76 (defun custom-xmas-add-text-properties (start end props &optional object)
  77   (add-text-properties start end props object)
  78   (put-text-property start end 'start-open t object)
  79   (put-text-property start end 'end-open t object))
  80
  81 (defun custom-xmas-put-text-property (start end prop value &optional object)
  82   (put-text-property start end prop value object)
  83   (put-text-property start end 'start-open t object)
  84   (put-text-property start end 'end-open t object))
  85
  86 (defun custom-xmas-extent-start-open ()
  87   (map-extents (lambda (extent arg)
  88                  (set-extent-property extent 'start-open t))
  89                nil (point) (min (1+ (point)) (point-max))))
  90
  91 (if (string-match "XEmacs\\|Lucid" emacs-version)
  92     (progn
  93       (fset 'custom-add-text-properties 'custom-xmas-add-text-properties)
  94       (fset 'custom-put-text-property 'custom-xmas-put-text-property)
  95       (fset 'custom-extent-start-open 'custom-xmas-extent-start-open)
  96       (fset 'custom-set-text-properties
  97             (if (fboundp 'set-text-properties)
  98                 'set-text-properties))
  99       (fset 'custom-buffer-substring-no-properties
 100             (if (fboundp 'buffer-substring-no-properties)
 101                 'buffer-substring-no-properties
 102               'custom-xmas-buffer-substring-no-properties)))
 103   (fset 'custom-add-text-properties 'add-text-properties)
 104   (fset 'custom-put-text-property 'put-text-property)
 105   (fset 'custom-extent-start-open 'ignore)
 106   (fset 'custom-set-text-properties 'set-text-properties)
 107   (fset 'custom-buffer-substring-no-properties
 108         'buffer-substring-no-properties))
 109
 110 (defun custom-xmas-buffer-substring-no-properties (beg end)
 111   "Return the text from BEG to END, without text properties, as a string."
 112   (let ((string (buffer-substring beg end)))
 113     (custom-set-text-properties 0 (length string) nil string)
 114     string))
 115
 116 ;; XEmacs and Emacs 19.29 facep does different things.
 117 (defalias 'custom-facep
 118   (cond ((fboundp 'find-face)
 119          'find-face)
 120         ((fboundp 'facep)
 121          'facep)
 122         (t
 123          'ignore)))
 124
 125 (if (custom-facep 'underline)
 126     ()
 127   ;; No underline face in XEmacs 19.12.
 128   (and (fboundp 'make-face)
 129        (funcall (intern "make-face") 'underline))
 130   ;; Must avoid calling set-face-underline-p directly, because it
 131   ;; is a defsubst in emacs19, and will make the .elc files non
 132   ;; portable!
 133   (or (and (fboundp 'face-differs-from-default-p)
 134            (face-differs-from-default-p 'underline))
 135       (and (fboundp 'set-face-underline-p)
 136            (funcall 'set-face-underline-p 'underline t))))
 137
 138 (defun custom-xmas-set-text-properties (start end props &optional buffer)
 139   (if (null buffer)
 140       (if props
 141           (while props
 142             (custom-put-text-property
 143              start end (car props) (nth 1 props) buffer)
 144             (setq props (nthcdr 2 props)))
 145         (remove-text-properties start end ()))))
 146
 147 (or (fboundp 'event-point)
 148     ;; Missing in Emacs 19.29.
 149     (defun event-point (event)
 150       "Return the character position of the given mouse-motion, button-press,
 151 or button-release event.  If the event did not occur over a window, or did
 152 not occur over text, then this returns nil.  Otherwise, it returns an index
 153 into the buffer visible in the event's window."
 154       (posn-point (event-start event))))
 155
 156 (eval-when-compile
 157   (defvar x-colors nil)
 158   (defvar custom-button-face nil)
 159   (defvar custom-field-uninitialized-face nil)
 160   (defvar custom-field-invalid-face nil)
 161   (defvar custom-field-modified-face nil)
 162   (defvar custom-field-face nil)
 163   (defvar custom-mouse-face nil)
 164   (defvar custom-field-active-face nil))
 165
 166 ;; We can't easily check for a working intangible.
 167 (defconst intangible (if (and (boundp 'emacs-minor-version)
 168                               (or (> emacs-major-version 19)
 169                                   (and (> emacs-major-version 18)
 170                                        (> emacs-minor-version 28))))
 171                          (setq intangible 'intangible)
 172                        (setq intangible 'intangible-if-it-had-been-working))
 173   "The symbol making text intangible.")
 174
 175 (defconst rear-nonsticky (if (string-match "XEmacs" emacs-version)
 176                              'end-open
 177                            'rear-nonsticky)
 178   "The symbol making text properties non-sticky in the rear end.")
 179
 180 (defconst front-sticky (if (string-match "XEmacs" emacs-version)
 181                            'front-closed
 182                          'front-sticky)
 183   "The symbol making text properties sticky in the front.")
 184
 185 (defconst mouse-face (if (string-match "XEmacs" emacs-version)
 186                          'highlight
 187                        'mouse-face)
 188   "Symbol used for highlighting text under mouse.")
 189
 190 ;; Put it in the Help menu, if possible.
 191 (if (string-match "XEmacs" emacs-version)
 192     (if (featurep 'menubar)
 193         ;; XEmacs (disabled because it doesn't work)
 194         (and current-menubar
 195              (add-menu-item '("Help") "Customize..." 'customize t)))
 196   ;; Emacs 19.28 and earlier
 197   (global-set-key [ menu-bar help customize ]
 198                   '("Customize..." . customize))
 199   ;; Emacs 19.29 and later
 200   (global-set-key [ menu-bar help-menu customize ]
 201                   '("Customize..." . customize)))
 202
 203 ;; XEmacs popup-menu stolen from w3.el.
 204 (defun custom-x-really-popup-menu (pos title menudesc)
 205   "My hacked up function to do a blocking popup menu..."
 206   (let ((echo-keystrokes 0)
 207         event menu)
 208     (while menudesc
 209       (setq menu (cons (vector (car (car menudesc))
 210                                (list (car (car menudesc))) t) menu)
 211             menudesc (cdr menudesc)))
 212     (setq menu (cons title menu))
 213     (popup-menu menu)
 214     (catch 'popup-done
 215       (while t
 216         (setq event (next-command-event event))
 217         (cond ((and (misc-user-event-p event) (stringp (car-safe                                                   (event-object event))))
 218                (throw 'popup-done (event-object event)))
 219               ((and (misc-user-event-p event)
 220                     (or (eq (event-object event) 'abort)
 221                         (eq (event-object event) 'menu-no-selection-hook)))
 222                nil)
 223               ((not (popup-menu-up-p))
 224                (throw 'popup-done nil))
 225               ((button-release-event-p event);; don't beep twice
 226                nil)
 227               (t
 228                (beep)
 229                (message "please make a choice from the menu.")))))))
 230
 231 ;;; Categories:
 232 ;;
 233 ;; XEmacs use inheritable extents for the same purpose as Emacs uses
 234 ;; the category text property.
 235
 236 (if (string-match "XEmacs" emacs-version)
 237     (progn
 238       ;; XEmacs categories.
 239       (defun custom-category-create (name)
 240         (set name (make-extent nil nil))
 241         "Create a text property category named NAME.")
 242
 243       (defun custom-category-put (name property value)
 244         "In CATEGORY set PROPERTY to VALUE."
 245         (set-extent-property (symbol-value name) property value))
 246
 247       (defun custom-category-get (name property)
 248         "In CATEGORY get PROPERTY."
 249         (extent-property (symbol-value name) property))
 250
 251       (defun custom-category-set (from to category)
 252         "Make text between FROM and TWO have category CATEGORY."
 253         (let ((extent (make-extent from to)))
 254           (set-extent-parent extent (symbol-value category)))))
 255
 256   ;; Emacs categories.
 257   (defun custom-category-create (name)
 258     "Create a text property category named NAME."
 259     (set name name))
 260
 261   (defun custom-category-put (name property value)
 262     "In CATEGORY set PROPERTY to VALUE."
 263     (put name property value))
 264
 265   (defun custom-category-get (name property)
 266     "In CATEGORY get PROPERTY."
 267     (get name property))
 268
 269   (defun custom-category-set (from to category)
 270     "Make text between FROM and TWO have category CATEGORY."
 271     (custom-put-text-property from to 'category category)))
 272
 273 ;;; External Data:
 274 ;;
 275 ;; The following functions and variables defines the interface for
 276 ;; connecting a CUSTOM with an external entity, by default an emacs
 277 ;; lisp variable.
 278
 279 (defvar custom-external 'default-value
 280   "Function returning the external value of NAME.")
 281
 282 (defvar custom-external-set 'set-default
 283   "Function setting the external value of NAME to VALUE.")
 284
 285 (defun custom-external (name)
 286   "Get the external value associated with NAME."
 287   (funcall custom-external name))
 288
 289 (defun custom-external-set (name value)
 290   "Set the external value associated with NAME to VALUE."
 291   (funcall custom-external-set name value))
 292
 293 (defvar custom-name-fields nil
 294   "Alist of custom names and their associated editing field.")
 295 (make-variable-buffer-local 'custom-name-fields)
 296
 297 (defun custom-name-enter (name field)
 298   "Associate NAME with FIELD."
 299   (if (null name)
 300       ()
 301     (custom-assert 'field)
 302     (setq custom-name-fields (cons (cons name field) custom-name-fields))))
 303
 304 (defun custom-name-field (name)
 305   "The editing field associated with NAME."
 306   (cdr (assq name custom-name-fields)))
 307
 308 (defun custom-name-value (name)
 309   "The value currently displayed for NAME in the customization buffer."
 310   (let* ((field (custom-name-field name))
 311          (custom (custom-field-custom field)))
 312     (custom-field-parse field)
 313     (funcall (custom-property custom 'export) custom
 314              (car (custom-field-extract custom field)))))
 315
 316 (defvar custom-save 'custom-save
 317   "Function that will save current customization buffer.")
 318
 319 ;;; Custom Functions:
 320 ;;
 321 ;; The following functions are part of the public interface to the
 322 ;; CUSTOM datastructure.  Each CUSTOM describes a group of variables,
 323 ;; a single variable, or a component of a structured variable.  The
 324 ;; CUSTOM instances are part of two hierarchies, the first is the
 325 ;; `part-of' hierarchy in which each CUSTOM is a component of another
 326 ;; CUSTOM, except for the top level CUSTOM which is contained in
 327 ;; `custom-data'.  The second hierarchy is a `is-a' type hierarchy
 328 ;; where each CUSTOM is a leaf in the hierarchy defined by the `type'
 329 ;; property and `custom-type-properties'.
 330
 331 (defvar custom-file "~/.custom.el"
 332   "Name of file with customization information.")
 333
 334 (defconst custom-data
 335   '((tag . "Emacs")
 336     (doc . "The extensible self-documenting text editor.")
 337     (type . group)
 338     (data "\n"
 339           ((header . nil)
 340            (compact . t)
 341            (type . group)
 342            (doc . "\
 343 Press [Save] to save any changes permanently after you are done editing.
 344 You can load customization information from other files by editing the
 345 `File' field and pressing the [Load] button.  When you press [Save] the
 346 customization information of all files you have loaded, plus any
 347 changes you might have made manually, will be stored in the file
 348 specified by the `File' field.")
 349            (data ((tag . "Load")
 350                   (type . button)
 351                   (query . custom-load))
 352                  ((tag . "Save")
 353                   (type . button)
 354                   (query . custom-save))
 355                  ((name . custom-file)
 356                   (default . "~/.custom.el")
 357                   (doc . "Name of file with customization information.\n")
 358                   (tag . "File")
 359                   (type . file))))))
 360   "The global customization information.
 361 A custom association list.")
 362
 363 (defun custom-declare (path custom)
 364   "Declare variables for customization.
 365 PATH is a list of tags leading to the place in the customization
 366 hierarchy the new entry should be added.  CUSTOM is the entry to add."
 367   (custom-initialize custom)
 368   (let ((current (custom-travel-path custom-data path)))
 369     (or (member custom (custom-data current))
 370         (nconc (custom-data current) (list custom)))))
 371
 372 (put 'custom-declare 'lisp-indent-hook 1)
 373
 374 (defconst custom-type-properties
 375   '((repeat (type . default)
 376             ;; See `custom-match'.
 377             (import . custom-repeat-import)
 378             (eval . custom-repeat-eval)
 379             (quote . custom-repeat-quote)
 380             (accept . custom-repeat-accept)
 381             (extract . custom-repeat-extract)
 382             (validate . custom-repeat-validate)
 383             (insert . custom-repeat-insert)
 384             (match . custom-repeat-match)
 385             (query . custom-repeat-query)
 386             (prefix . "")
 387             (del-tag . "[DEL]")
 388             (add-tag . "[INS]"))
 389     (pair (type . group)
 390           ;; A cons-cell.
 391           (accept . custom-pair-accept)
 392           (eval . custom-pair-eval)
 393           (import . custom-pair-import)
 394           (quote . custom-pair-quote)
 395           (valid . (lambda (c d) (consp d)))
 396           (extract . custom-pair-extract))
 397     (list (type . group)
 398           ;; A lisp list.
 399           (quote . custom-list-quote)
 400           (valid . (lambda (c d)
 401                      (listp d)))
 402           (extract . custom-list-extract))
 403     (group (type . default)
 404            ;; See `custom-match'.
 405            (face-tag . nil)
 406            (eval . custom-group-eval)
 407            (import . custom-group-import)
 408            (initialize . custom-group-initialize)
 409            (apply . custom-group-apply)
 410            (reset . custom-group-reset)
 411            (factory-reset . custom-group-factory-reset)
 412            (extract . nil)
 413            (validate . custom-group-validate)
 414            (query . custom-toggle-hide)
 415            (accept . custom-group-accept)
 416            (insert . custom-group-insert)
 417            (find . custom-group-find))
 418     (toggle (type . choice)
 419             ;; Booleans.
 420             (data ((type . const)
 421                    (tag . "On ")
 422                    (default . t))
 423                   ((type . const)
 424                    (tag . "Off")
 425                    (default . nil))))
 426     (triggle (type . choice)
 427              ;; On/Off/Default.
 428              (data ((type . const)
 429                     (tag . "On ")
 430                     (default . t))
 431                    ((type . const)
 432                     (tag . "Off")
 433                     (default . nil))
 434                    ((type . const)
 435                     (tag . "Def")
 436                     (default . custom:asis))))
 437     (choice (type . default)
 438             ;; See `custom-match'.
 439             (query . custom-choice-query)
 440             (accept . custom-choice-accept)
 441             (extract . custom-choice-extract)
 442             (validate . custom-choice-validate)
 443             (insert . custom-choice-insert)
 444             (none (tag . "Unknown")
 445                   (default . __uninitialized__)
 446                   (type . const)))
 447     (const (type . default)
 448            ;; A `const' only matches a single lisp value.
 449            (extract . (lambda (c f) (list (custom-default c))))
 450            (validate . (lambda (c f) nil))
 451            (valid . custom-const-valid)
 452            (update . custom-const-update)
 453            (insert . custom-const-insert))
 454     (face-doc (type . doc)
 455               ;; A variable containing a face.
 456               (doc . "\
 457 You can customize the look of Emacs by deciding which faces should be
 458 used when.  If you push one of the face buttons below, you will be
 459 given a choice between a number of standard faces.  The name of the
 460 selected face is shown right after the face button, and it is
 461 displayed its own face so you can see how it looks.  If you know of
 462 another standard face not listed and want to use it, you can select
 463 `Other' and write the name in the editing field.
 464
 465 If none of the standard faces suits you, you can select `Customize' to
 466 create your own face.  This will make six fields appear under the face
 467 button.  The `Fg' and `Bg' fields are the foreground and background
 468 colors for the face, respectively.  You should type the name of the
 469 color in the field.  You can use any X11 color name.  A list of X11
 470 color names may be available in the file `/usr/lib/X11/rgb.txt' on
 471 your system.  The special color name `default' means that the face
 472 will not change the color of the text.  The `Stipple' field is weird,
 473 so just ignore it.  The three remaining fields are toggles, which will
 474 make the text `bold', `italic', or `underline' respectively.  For some
 475 fonts `bold' or `italic' will not make any visible change."))
 476     (face (type . choice)
 477           (eval . custom-face-eval)
 478           (import . custom-face-import)
 479           (data ((tag . "None")
 480                  (default . nil)
 481                  (type . const))
 482                 ((tag . "Default")
 483                  (default . default)
 484                  (face . custom-const-face)
 485                  (type . const))
 486                 ((tag . "Bold")
 487                  (default . bold)
 488                  (face . custom-const-face)
 489                  (type . const))
 490                 ((tag . "Bold-italic")
 491                  (default . bold-italic)
 492                  (face . custom-const-face)
 493                  (type . const))
 494                 ((tag . "Italic")
 495                  (default . italic)
 496                  (face . custom-const-face)
 497                  (type . const))
 498                 ((tag . "Underline")
 499                  (default . underline)
 500                  (face . custom-const-face)
 501                  (type . const))
 502                 ((tag . "Highlight")
 503                  (default . highlight)
 504                  (face . custom-const-face)
 505                  (type . const))
 506                 ((tag . "Modeline")
 507                  (default . modeline)
 508                  (face . custom-const-face)
 509                  (type . const))
 510                 ((tag . "Region")
 511                  (default . region)
 512                  (face . custom-const-face)
 513                  (type . const))
 514                 ((tag . "Secondary Selection")
 515                  (default . secondary-selection)
 516                  (face . custom-const-face)
 517                  (type . const))
 518                 ((tag . "Customized")
 519                  (compact . t)
 520                  (face-tag . custom-face-hack)
 521                  (eval . custom-face-eval)
 522                  (data ((hidden . t)
 523                         (tag . "")
 524                         (doc . "\
 525 Select the properties you want this face to have.")
 526                         (default . custom-face-lookup)
 527                         (type . const))
 528                        "\n"
 529                        ((tag . "Fg")
 530                         (hidden . t)
 531                         (default . "default")
 532                         (width . 20)
 533                         (type . string))
 534                        ((tag . "Bg")
 535                         (default . "default")
 536                         (width . 20)
 537                         (type . string))
 538                        ((tag . "Stipple")
 539                         (default . "default")
 540                         (width . 20)
 541                         (type . string))
 542                        "\n"
 543                        ((tag . "Bold")
 544                         (default . custom:asis)
 545                         (type . triggle))
 546                        "              "
 547                        ((tag . "Italic")
 548                         (default . custom:asis)
 549                         (type . triggle))
 550                        "             "
 551                        ((tag . "Underline")
 552                         (hidden . t)
 553                         (default . custom:asis)
 554                         (type . triggle)))
 555                  (default . (custom-face-lookup "default" "default" "default"
 556                                                 nil nil nil))
 557                  (type . list))
 558                 ((prompt . "Other")
 559                  (face . custom-field-value)
 560                  (default . __uninitialized__)
 561                  (type . symbol))))
 562     (file (type . string)
 563           ;; A string containing a file or directory name.
 564           (directory . nil)
 565           (default-file . nil)
 566           (query . custom-file-query))
 567     (sexp (type . default)
 568           ;; Any lisp expression.
 569           (width . 40)
 570           (default . (__uninitialized__ . "Uninitialized"))
 571           (read . custom-sexp-read)
 572           (write . custom-sexp-write))
 573     (symbol (type . sexp)
 574             ;; A lisp symbol.
 575             (width . 40)
 576             (valid . (lambda (c d) (symbolp d))))
 577     (integer (type . sexp)
 578              ;; A lisp integer.
 579              (width . 10)
 580              (valid . (lambda (c d) (integerp d))))
 581     (string (type . default)
 582             ;; A lisp string.
 583             (width . 40)
 584             (valid . (lambda (c d) (stringp d)))
 585             (read . custom-string-read)
 586             (write . custom-string-write))
 587     (button (type . default)
 588             ;; Push me.
 589             (accept . ignore)
 590             (extract . nil)
 591             (validate . ignore)
 592             (insert . custom-button-insert))
 593     (doc (type . default)
 594          ;; A documentation only entry with no value.
 595          (header . nil)
 596          (reset . ignore)
 597          (extract . nil)
 598          (validate . ignore)
 599          (insert . custom-documentation-insert))
 600     (default (width . 20)
 601              (valid . (lambda (c v) t))
 602              (insert . custom-default-insert)
 603              (update . custom-default-update)
 604              (query . custom-default-query)
 605              (tag . nil)
 606              (prompt . nil)
 607              (doc . nil)
 608              (header . t)
 609              (padding . ? )
 610              (quote . custom-default-quote)
 611              (eval . (lambda (c v) nil))
 612              (export . custom-default-export)
 613              (import . (lambda (c v) (list v)))
 614              (synchronize . ignore)
 615              (initialize . custom-default-initialize)
 616              (extract . custom-default-extract)
 617              (validate . custom-default-validate)
 618              (apply . custom-default-apply)
 619              (reset . custom-default-reset)
 620              (factory-reset . custom-default-factory-reset)
 621              (accept . custom-default-accept)
 622              (match . custom-default-match)
 623              (name . nil)
 624              (compact . nil)
 625              (hidden . nil)
 626              (face . custom-default-face)
 627              (data . nil)
 628              (calculate . nil)
 629              (default . __uninitialized__)))
 630   "Alist of default properties for type symbols.
 631 The format is `((SYMBOL (PROPERTY . VALUE)... )... )'.")
 632
 633 (defconst custom-local-type-properties nil
 634   "Local type properties.
 635 Entries in this list take precedence over `custom-type-properties'.")
 636
 637 (make-variable-buffer-local 'custom-local-type-properties)
 638
 639 (defconst custom-nil '__uninitialized__
 640   "Special value representing an uninitialized field.")
 641
 642 (defconst custom-invalid '__invalid__
 643   "Special value representing an invalid field.")
 644
 645 (defconst custom:asis 'custom:asis)
 646 ;; Bad, ugly, and horrible kludge.
 647
 648 (defun custom-property (custom property)
 649   "Extract from CUSTOM property PROPERTY."
 650   (let ((entry (assq property custom)))
 651     (while (null entry)
 652       ;; Look in superclass.
 653       (let ((type (custom-type custom)))
 654         (setq custom (cdr (or (assq type custom-local-type-properties)
 655                               (assq type custom-type-properties)))
 656               entry (assq property custom))
 657         (custom-assert 'custom)))
 658     (cdr entry)))
 659
 660 (defun custom-super (custom property)
 661   "Extract from CUSTOM property PROPERTY.  Start with CUSTOM's superclass."
 662   (let ((entry nil))
 663     (while (null entry)
 664       ;; Look in superclass.
 665       (let ((type (custom-type custom)))
 666         (setq custom (cdr (or (assq type custom-local-type-properties)
 667                               (assq type custom-type-properties)))
 668               entry (assq property custom))
 669         (custom-assert 'custom)))
 670     (cdr entry)))
 671
 672 (defun custom-property-set (custom property value)
 673   "Set CUSTOM PROPERTY to VALUE by side effect.
 674 CUSTOM must have at least one property already."
 675   (let ((entry (assq property custom)))
 676     (if entry
 677         (setcdr entry value)
 678       (setcdr custom (cons (cons property value) (cdr custom))))))
 679
 680 (defun custom-type (custom)
 681   "Extract `type' from CUSTOM."
 682   (cdr (assq 'type custom)))
 683
 684 (defun custom-name (custom)
 685   "Extract `name' from CUSTOM."
 686   (custom-property custom 'name))
 687
 688 (defun custom-tag (custom)
 689   "Extract `tag' from CUSTOM."
 690   (custom-property custom 'tag))
 691
 692 (defun custom-face-tag (custom)
 693   "Extract `face-tag' from CUSTOM."
 694   (custom-property custom 'face-tag))
 695
 696 (defun custom-prompt (custom)
 697   "Extract `prompt' from CUSTOM.
 698 If none exist, default to `tag' or, failing that, `type'."
 699   (or (custom-property custom 'prompt)
 700       (custom-property custom 'tag)
 701       (capitalize (symbol-name (custom-type custom)))))
 702
 703 (defun custom-default (custom)
 704   "Extract `default' from CUSTOM."
 705   (let ((value (custom-property custom 'calculate)))
 706     (if value
 707         (eval value)
 708       (custom-property custom 'default))))
 709
 710 (defun custom-data (custom)
 711   "Extract the `data' from CUSTOM."
 712   (custom-property custom 'data))
 713
 714 (defun custom-documentation (custom)
 715   "Extract `doc' from CUSTOM."
 716   (custom-property custom 'doc))
 717
 718 (defun custom-width (custom)
 719   "Extract `width' from CUSTOM."
 720   (custom-property custom 'width))
 721
 722 (defun custom-compact (custom)
 723   "Extract `compact' from CUSTOM."
 724   (custom-property custom 'compact))
 725
 726 (defun custom-padding (custom)
 727   "Extract `padding' from CUSTOM."
 728   (custom-property custom 'padding))
 729
 730 (defun custom-valid (custom value)
 731   "Non-nil if CUSTOM may validly be set to VALUE."
 732   (and (not (and (listp value) (eq custom-invalid (car value))))
 733        (funcall (custom-property custom 'valid) custom value)))
 734
 735 (defun custom-import (custom value)
 736   "Import CUSTOM VALUE from external variable.
 737
 738 This function change VALUE into a form that makes it easier to edit
 739 internally.  What the internal form is exactly depends on CUSTOM.
 740 The internal form is returned."
 741   (if (eq custom-nil value)
 742       (list custom-nil)
 743     (funcall (custom-property custom 'import) custom value)))
 744
 745 (defun custom-eval (custom value)
 746   "Return non-nil if CUSTOM's VALUE needs to be evaluated."
 747   (funcall (custom-property custom 'eval) custom value))
 748
 749 (defun custom-quote (custom value)
 750   "Quote CUSTOM's VALUE if necessary."
 751   (funcall (custom-property custom 'quote) custom value))
 752
 753 (defun custom-write (custom value)
 754   "Convert CUSTOM VALUE to a string."
 755   (cond ((eq value custom-nil)
 756          "")
 757         ((and (listp value) (eq (car value) custom-invalid))
 758          (cdr value))
 759         (t
 760          (funcall (custom-property custom 'write) custom value))))
 761
 762 (defun custom-read (custom string)
 763   "Convert CUSTOM field content STRING into lisp."
 764   (condition-case nil
 765       (funcall (custom-property custom 'read) custom string)
 766     (error (cons custom-invalid string))))
 767
 768 (defun custom-match (custom values)
 769   "Match CUSTOM with a list of VALUES.
 770
 771 Return a cons-cell where the car is the sublist of VALUES matching CUSTOM,
 772 and the cdr is the remaining VALUES.
 773
 774 A CUSTOM is actually a regular expression over the alphabet of lisp
 775 types.  Most CUSTOM types are just doing a literal match, e.g. the
 776 `symbol' type matches any lisp symbol.  The exceptions are:
 777
 778 group:    which corresponds to a `(' and `)' group in a regular expression.
 779 choice:   which corresponds to a group of `|' in a regular expression.
 780 repeat:   which corresponds to a `*' in a regular expression.
 781 optional: which corresponds to a `?', and isn't implemented yet."
 782   (if (memq values (list custom-nil nil))
 783       ;; Nothing matches the uninitialized or empty list.
 784       (cons custom-nil nil)
 785     (funcall (custom-property custom 'match) custom values)))
 786
 787 (defun custom-initialize (custom)
 788   "Initialize `doc' and `default' attributes of CUSTOM."
 789   (funcall (custom-property custom 'initialize) custom))
 790
 791 (defun custom-find (custom tag)
 792   "Find child in CUSTOM with `tag' TAG."
 793   (funcall (custom-property custom 'find) custom tag))
 794
 795 (defun custom-travel-path (custom path)
 796   "Find decedent of CUSTOM by looking through PATH."
 797   (if (null path)
 798       custom
 799     (custom-travel-path (custom-find custom (car path)) (cdr path))))
 800
 801 (defun custom-field-extract (custom field)
 802   "Extract CUSTOM's value in FIELD."
 803   (if (stringp custom)
 804       nil
 805     (funcall (custom-property (custom-field-custom field) 'extract)
 806              custom field)))
 807
 808 (defun custom-field-validate (custom field)
 809   "Validate CUSTOM's value in FIELD.
 810 Return nil if valid, otherwise return a cons-cell where the car is the
 811 position of the error, and the cdr is a text describing the error."
 812   (if (stringp custom)
 813       nil
 814     (funcall (custom-property custom 'validate) custom field)))
 815
 816 ;;; Field Functions:
 817 ;;
 818 ;; This section defines the public functions for manipulating the
 819 ;; FIELD datatype.  The FIELD instance hold information about a
 820 ;; specific editing field in the customization buffer.
 821 ;;
 822 ;; Each FIELD can be seen as an instantiation of a CUSTOM.
 823
 824 (defvar custom-field-last nil)
 825 ;; Last field containing point.
 826 (make-variable-buffer-local 'custom-field-last)
 827
 828 (defvar custom-modified-list nil)
 829 ;; List of modified fields.
 830 (make-variable-buffer-local 'custom-modified-list)
 831
 832 (defun custom-field-create (custom value)
 833   "Create a field structure of type CUSTOM containing VALUE.
 834
 835 A field structure is an array [ CUSTOM VALUE ORIGINAL START END ], where
 836 CUSTOM defines the type of the field,
 837 VALUE is the current value of the field,
 838 ORIGINAL is the original value when created, and
 839 START and END are markers to the start and end of the field."
 840   (vector custom value custom-nil nil nil))
 841
 842 (defun custom-field-custom (field)
 843   "Return the `custom' attribute of FIELD."
 844   (aref field 0))
 845
 846 (defun custom-field-value (field)
 847   "Return the `value' attribute of FIELD."
 848   (aref field 1))
 849
 850 (defun custom-field-original (field)
 851   "Return the `original' attribute of FIELD."
 852   (aref field 2))
 853
 854 (defun custom-field-start (field)
 855   "Return the `start' attribute of FIELD."
 856   (aref field 3))
 857
 858 (defun custom-field-end (field)
 859   "Return the `end' attribute of FIELD."
 860   (aref field 4))
 861
 862 (defun custom-field-value-set (field value)
 863   "Set the `value' attribute of FIELD to VALUE."
 864   (aset field 1 value))
 865
 866 (defun custom-field-original-set (field original)
 867   "Set the `original' attribute of FIELD to ORIGINAL."
 868   (aset field 2 original))
 869
 870 (defun custom-field-move (field start end)
 871   "Set the `start'and `end' attributes of FIELD to START and END."
 872   (set-marker (or (aref field 3) (aset field 3 (make-marker))) start)
 873   (set-marker (or (aref field 4) (aset field 4 (make-marker))) end))
 874
 875 (defun custom-field-query (field)
 876   "Query user for content of current field."
 877   (funcall (custom-property (custom-field-custom field) 'query) field))
 878
 879 (defun custom-field-accept (field value &optional original)
 880   "Store a new value into field FIELD, taking it from VALUE.
 881 If optional ORIGINAL is non-nil, consider VALUE for the original value."
 882   (let ((inhibit-point-motion-hooks t))
 883     (funcall (custom-property (custom-field-custom field) 'accept)
 884              field value original)))
 885
 886 (defun custom-field-face (field)
 887   "The face used for highlighting FIELD."
 888   (let ((custom (custom-field-custom field)))
 889     (if (stringp custom)
 890         nil
 891       (let ((face (funcall (custom-property custom 'face) field)))
 892         (if (custom-facep face) face nil)))))
 893
 894 (defun custom-field-update (field)
 895   "Update the screen appearance of FIELD to correspond with the field's value."
 896   (let ((custom (custom-field-custom field)))
 897     (if (stringp custom)
 898         nil
 899       (funcall (custom-property custom 'update) field))))
 900
 901 ;;; Types:
 902 ;;
 903 ;; The following functions defines type specific actions.
 904
 905 (defun custom-repeat-eval (custom value)
 906   "Non-nil if CUSTOM's VALUE needs to be evaluated."
 907   (if (eq value custom-nil)
 908       nil
 909     (let ((child (custom-data custom))
 910           (found nil))
 911       (mapcar (lambda (v) (if (custom-eval child v) (setq found t)))
 912               value))))
 913
 914 (defun custom-repeat-quote (custom value)
 915   "A list of CUSTOM's VALUEs quoted."
 916   (let ((child (custom-data custom)))
 917     (apply 'append (mapcar (lambda (v) (custom-quote child v))
 918                            value))))
 919
 920
 921 (defun custom-repeat-import (custom value)
 922   "Modify CUSTOM's VALUE to match internal expectations."
 923   (let ((child (custom-data custom)))
 924     (apply 'append (mapcar (lambda (v) (custom-import child v))
 925                            value))))
 926
 927 (defun custom-repeat-accept (field value &optional original)
 928   "Store a new value into field FIELD, taking it from VALUE."
 929   (let ((values (copy-sequence (custom-field-value field)))
 930         (all (custom-field-value field))
 931         (start (custom-field-start field))
 932         current new)
 933     (if original
 934         (custom-field-original-set field value))
 935     (while (consp value)
 936       (setq new (car value)
 937             value (cdr value))
 938       (if values
 939           ;; Change existing field.
 940           (setq current (car values)
 941                 values (cdr values))
 942         ;; Insert new field if series has grown.
 943         (goto-char start)
 944         (setq current (custom-repeat-insert-entry field))
 945         (setq all (custom-insert-before all nil current))
 946         (custom-field-value-set field all))
 947       (custom-field-accept current new original))
 948     (while (consp values)
 949       ;; Delete old field if series has scrunk.
 950       (setq current (car values)
 951             values (cdr values))
 952       (let ((pos (custom-field-start current))
 953             data)
 954         (while (not data)
 955           (setq pos (previous-single-property-change pos 'custom-data))
 956           (custom-assert 'pos)
 957           (setq data (get-text-property pos 'custom-data))
 958           (or (and (arrayp data)
 959                    (> (length data) 1)
 960                    (eq current (aref data 1)))
 961               (setq data nil)))
 962         (custom-repeat-delete data)))))
 963
 964 (defun custom-repeat-insert (custom level)
 965   "Insert field for CUSTOM at nesting LEVEL in customization buffer."
 966   (let* ((field (custom-field-create custom nil))
 967          (add-tag (custom-property custom 'add-tag))
 968          (start (make-marker))
 969          (data (vector field nil start nil)))
 970     (custom-text-insert "\n")
 971     (let ((pos (point)))
 972       (custom-text-insert (custom-property custom 'prefix))
 973       (custom-tag-insert add-tag 'custom-repeat-add data)
 974       (set-marker start pos))
 975     (custom-field-move field start (point))
 976     (custom-documentation-insert custom)
 977     field))
 978
 979 (defun custom-repeat-insert-entry (repeat)
 980   "Insert entry at point in the REPEAT field."
 981   (let* ((inhibit-point-motion-hooks t)
 982          (inhibit-read-only t)
 983          (before-change-functions nil)
 984          (after-change-functions nil)
 985          (custom (custom-field-custom repeat))
 986          (add-tag (custom-property custom 'add-tag))
 987          (del-tag (custom-property custom 'del-tag))
 988          (start (make-marker))
 989          (end (make-marker))
 990          (data (vector repeat nil start end))
 991          field)
 992     (custom-extent-start-open)
 993     (insert-before-markers "\n")
 994     (backward-char 1)
 995     (set-marker start (point))
 996     (custom-text-insert " ")
 997     (aset data 1 (setq field (custom-insert (custom-data custom) nil)))
 998     (custom-text-insert " ")
 999     (set-marker end (point))
1000     (goto-char start)
1001     (custom-text-insert (custom-property custom 'prefix))
1002     (custom-tag-insert add-tag 'custom-repeat-add data)
1003     (custom-text-insert " ")
1004     (custom-tag-insert del-tag 'custom-repeat-delete data)
1005     (forward-char 1)
1006     field))
1007
1008 (defun custom-repeat-add (data)
1009   "Add list entry."
1010   (let ((parent (aref data 0))
1011         (field (aref data 1))
1012         (at (aref data 2))
1013         new)
1014     (goto-char at)
1015     (setq new (custom-repeat-insert-entry parent))
1016     (custom-field-value-set parent
1017                             (custom-insert-before (custom-field-value parent)
1018                                                   field new))))
1019
1020 (defun custom-repeat-delete (data)
1021   "Delete list entry."
1022   (let ((inhibit-point-motion-hooks t)
1023         (inhibit-read-only t)
1024         (before-change-functions nil)
1025         (after-change-functions nil)
1026         (parent (aref data 0))
1027         (field (aref data 1)))
1028     (delete-region (aref data 2) (1+ (aref data 3)))
1029     (custom-field-untouch (aref data 1))
1030     (custom-field-value-set parent
1031                             (delq field (custom-field-value parent)))))
1032
1033 (defun custom-repeat-match (custom values)
1034   "Match CUSTOM with VALUES."
1035   (let* ((child (custom-data custom))
1036          (match (custom-match child values))
1037          matches)
1038     (while (not (eq (car match) custom-nil))
1039       (setq matches (cons (car match) matches)
1040             values (cdr match)
1041             match (custom-match child values)))
1042     (cons (nreverse matches) values)))
1043
1044 (defun custom-repeat-extract (custom field)
1045   "Extract list of children's values."
1046   (let ((values (custom-field-value field))
1047         (data (custom-data custom))
1048         result)
1049     (if (eq values custom-nil)
1050         ()
1051       (while values
1052         (setq result (append result (custom-field-extract data (car values)))
1053               values (cdr values))))
1054     result))
1055
1056 (defun custom-repeat-validate (custom field)
1057   "Validate children."
1058   (let ((values (custom-field-value field))
1059         (data (custom-data custom))
1060         result)
1061     (if (eq values custom-nil)
1062         (setq result (cons (custom-field-start field) "Uninitialized list")))
1063     (while (and values (not result))
1064       (setq result (custom-field-validate data (car values))
1065             values (cdr values)))
1066     result))
1067
1068 (defun custom-pair-accept (field value &optional original)
1069   "Store a new value into field FIELD, taking it from VALUE."
1070   (custom-group-accept field (list (car value) (cdr value)) original))
1071
1072 (defun custom-pair-eval (custom value)
1073   "Non-nil if CUSTOM's VALUE needs to be evaluated."
1074   (custom-group-eval custom (list (car value) (cdr value))))
1075
1076 (defun custom-pair-import (custom value)
1077   "Modify CUSTOM's VALUE to match internal expectations."
1078   (let ((result (car (custom-group-import custom
1079                                           (list (car value) (cdr value))))))
1080     (custom-assert '(eq (length result) 2))
1081     (list (cons (nth 0 result) (nth 1 result)))))
1082
1083 (defun custom-pair-quote (custom value)
1084   "Quote CUSTOM's VALUE if necessary."
1085   (if (custom-eval custom value)
1086       (let ((v (car (custom-group-quote custom
1087                                         (list (car value) (cdr value))))))
1088         (list (list 'cons (nth 0 v) (nth 1 v))))
1089     (custom-default-quote custom value)))
1090
1091 (defun custom-pair-extract (custom field)
1092   "Extract cons of children's values."
1093   (let ((values (custom-field-value field))
1094         (data (custom-data custom))
1095         result)
1096     (custom-assert '(eq (length values) (length data)))
1097     (while values
1098       (setq result (append result
1099                            (custom-field-extract (car data) (car values)))
1100             data (cdr data)
1101             values (cdr values)))
1102     (custom-assert '(null data))
1103     (list (cons (nth 0 result) (nth 1 result)))))
1104
1105 (defun custom-list-quote (custom value)
1106   "Quote CUSTOM's VALUE if necessary."
1107   (if (custom-eval custom value)
1108       (let ((v (car (custom-group-quote custom value))))
1109         (list (cons 'list v)))
1110     (custom-default-quote custom value)))
1111
1112 (defun custom-list-extract (custom field)
1113   "Extract list of children's values."
1114   (let ((values (custom-field-value field))
1115         (data (custom-data custom))
1116         result)
1117     (custom-assert '(eq (length values) (length data)))
1118     (while values
1119       (setq result (append result
1120                            (custom-field-extract (car data) (car values)))
1121             data (cdr data)
1122             values (cdr values)))
1123     (custom-assert '(null data))
1124     (list result)))
1125
1126 (defun custom-group-validate (custom field)
1127   "Validate children."
1128   (let ((values (custom-field-value field))
1129         (data (custom-data custom))
1130         result)
1131     (if (eq values custom-nil)
1132         (setq result (cons (custom-field-start field) "Uninitialized list"))
1133       (custom-assert '(eq (length values) (length data))))
1134     (while (and values (not result))
1135       (setq result (custom-field-validate (car data) (car values))
1136             data (cdr data)
1137             values (cdr values)))
1138     result))
1139
1140 (defun custom-group-eval (custom value)
1141   "Non-nil if CUSTOM's VALUE needs to be evaluated."
1142   (let ((found nil))
1143     (mapcar (lambda (c)
1144               (or (stringp c)
1145                   (let ((match (custom-match c value)))
1146                     (if (custom-eval c (car match))
1147                         (setq found t))
1148                     (setq value (cdr match)))))
1149             (custom-data custom))
1150     found))
1151
1152 (defun custom-group-quote (custom value)
1153   "A list of CUSTOM's VALUE members, quoted."
1154   (list (apply 'append
1155                (mapcar (lambda (c)
1156                          (if (stringp c)
1157                              ()
1158                            (let ((match (custom-match c value)))
1159                              (prog1 (custom-quote c (car match))
1160                                (setq value (cdr match))))))
1161                        (custom-data custom)))))
1162
1163 (defun custom-group-import (custom value)
1164   "Modify CUSTOM's VALUE to match internal expectations."
1165   (list (apply 'append
1166                (mapcar (lambda (c)
1167                          (if (stringp c)
1168                              ()
1169                            (let ((match (custom-match c value)))
1170                              (prog1 (custom-import c (car match))
1171                                (setq value (cdr match))))))
1172                        (custom-data custom)))))
1173
1174 (defun custom-group-initialize (custom)
1175   "Initialize `doc' and `default' entries in CUSTOM."
1176   (if (custom-name custom)
1177       (custom-default-initialize custom)
1178     (mapcar 'custom-initialize (custom-data custom))))
1179
1180 (defun custom-group-apply (field)
1181   "Reset `value' in FIELD to `original'."
1182   (let ((custom (custom-field-custom field))
1183         (values (custom-field-value field)))
1184     (if (custom-name custom)
1185         (custom-default-apply field)
1186       (mapcar 'custom-field-apply values))))
1187
1188 (defun custom-group-reset (field)
1189   "Reset `value' in FIELD to `original'."
1190   (let ((custom (custom-field-custom field))
1191         (values (custom-field-value field)))
1192     (if (custom-name custom)
1193         (custom-default-reset field)
1194       (mapcar 'custom-field-reset values))))
1195
1196 (defun custom-group-factory-reset (field)
1197   "Reset `value' in FIELD to `default'."
1198   (let ((custom (custom-field-custom field))
1199         (values (custom-field-value field)))
1200     (if (custom-name custom)
1201         (custom-default-factory-reset field)
1202       (mapcar 'custom-field-factory-reset values))))
1203
1204 (defun custom-group-find (custom tag)
1205   "Find child in CUSTOM with `tag' TAG."
1206   (let ((data (custom-data custom))
1207         (result nil))
1208     (while (not result)
1209       (custom-assert 'data)
1210       (if (equal (custom-tag (car data)) tag)
1211           (setq result (car data))
1212         (setq data (cdr data))))))
1213
1214 (defun custom-group-accept (field value &optional original)
1215   "Store a new value into field FIELD, taking it from VALUE."
1216   (let* ((values (custom-field-value field))
1217          (custom (custom-field-custom field))
1218          (from (custom-field-start field))
1219          (face-tag (custom-face-tag custom))
1220          current)
1221     (if face-tag
1222         (custom-put-text-property from (+ from (length (custom-tag custom)))
1223                                   'face (funcall face-tag field value)))
1224     (if original
1225         (custom-field-original-set field value))
1226     (while values
1227       (setq current (car values)
1228             values (cdr values))
1229       (if current
1230           (let* ((custom (custom-field-custom current))
1231                  (match (custom-match custom value)))
1232             (setq value (cdr match))
1233             (custom-field-accept current (car match) original))))))
1234
1235 (defun custom-group-insert (custom level)
1236   "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1237   (let* ((field (custom-field-create custom nil))
1238          fields hidden
1239          (from (point))
1240          (compact (custom-compact custom))
1241          (tag (custom-tag custom))
1242          (face-tag (custom-face-tag custom)))
1243     (cond (face-tag (custom-text-insert tag))
1244           (tag (custom-tag-insert tag field)))
1245     (or compact (custom-documentation-insert custom))
1246     (or compact (custom-text-insert "\n"))
1247     (let ((data (custom-data custom)))
1248       (while data
1249         (setq fields (cons (custom-insert (car data) (if level (1+ level)))
1250                            fields))
1251         (setq hidden (or (stringp (car data))
1252                          (custom-property (car data) 'hidden)))
1253         (setq data (cdr data))
1254         (if data (custom-text-insert (cond (hidden "")
1255                                            (compact " ")
1256                                            (t "\n"))))))
1257     (if compact (custom-documentation-insert custom))
1258     (custom-field-value-set field (nreverse fields))
1259     (custom-field-move field from (point))
1260     field))
1261
1262 (defun custom-choice-insert (custom level)
1263   "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1264   (let* ((field (custom-field-create custom nil))
1265          (from (point)))
1266     (custom-text-insert "lars er en nisse")
1267     (custom-field-move field from (point))
1268     (custom-documentation-insert custom)
1269     (custom-field-reset field)
1270     field))
1271
1272 (defun custom-choice-accept (field value &optional original)
1273   "Store a new value into field FIELD, taking it from VALUE."
1274   (let ((custom (custom-field-custom field))
1275         (start (custom-field-start field))
1276         (end (custom-field-end field))
1277         (inhibit-read-only t)
1278         (before-change-functions nil)
1279         (after-change-functions nil)
1280         from)
1281     (cond (original
1282            (setq custom-modified-list (delq field custom-modified-list))
1283            (custom-field-original-set field value))
1284           ((equal value (custom-field-original field))
1285            (setq custom-modified-list (delq field custom-modified-list)))
1286           (t
1287            (add-to-list 'custom-modified-list field)))
1288     (custom-field-untouch (custom-field-value field))
1289     (delete-region start end)
1290     (goto-char start)
1291     (setq from (point))
1292     (insert-before-markers " ")
1293     (backward-char 1)
1294     (custom-category-set (point) (1+ (point)) 'custom-hidden-properties)
1295     (custom-tag-insert (custom-tag custom) field)
1296     (custom-text-insert ": ")
1297     (let ((data (custom-data custom))
1298           found begin)
1299       (while (and data (not found))
1300         (if (not (custom-valid (car data) value))
1301             (setq data (cdr data))
1302           (setq found (custom-insert (car data) nil))
1303           (setq data nil)))
1304       (if found
1305           ()
1306         (setq begin (point)
1307               found (custom-insert (custom-property custom 'none) nil))
1308         (custom-add-text-properties
1309          begin (point)
1310          (list rear-nonsticky t
1311                'face custom-field-uninitialized-face)))
1312       (or original
1313           (custom-field-original-set found (custom-field-original field)))
1314       (custom-field-accept found value original)
1315       (custom-field-value-set field found)
1316       (custom-field-move field from end))))
1317
1318 (defun custom-choice-extract (custom field)
1319   "Extract child's value."
1320   (let ((value (custom-field-value field)))
1321     (custom-field-extract (custom-field-custom value) value)))
1322
1323 (defun custom-choice-validate (custom field)
1324   "Validate child's value."
1325   (let ((value (custom-field-value field))
1326         (custom (custom-field-custom field)))
1327     (if (or (eq value custom-nil)
1328             (eq (custom-field-custom value) (custom-property custom 'none)))
1329         (cons (custom-field-start field) "Make a choice")
1330       (custom-field-validate (custom-field-custom value) value))))
1331
1332 (defun custom-choice-query (field)
1333   "Choose a child."
1334   (let* ((custom (custom-field-custom field))
1335          (old (custom-field-custom (custom-field-value field)))
1336          (default (custom-prompt old))
1337          (tag (custom-prompt custom))
1338          (data (custom-data custom))
1339          current alist)
1340     (if (eq (length data) 2)
1341         (custom-field-accept field (custom-default (if (eq (nth 0 data) old)
1342                                                        (nth 1 data)
1343                                                      (nth 0 data))))
1344       (while data
1345         (setq current (car data)
1346               data (cdr data))
1347         (setq alist (cons (cons (custom-prompt current) current) alist)))
1348       (let ((answer (cond ((and (fboundp 'button-press-event-p)
1349                                 (fboundp 'popup-menu)
1350                                 (button-press-event-p last-input-event))
1351                            (cdr (assoc (car (custom-x-really-popup-menu
1352                                              last-input-event tag
1353                                              (reverse alist)))
1354                                        alist)))
1355                           ((listp last-input-event)
1356                            (x-popup-menu last-input-event
1357                                          (list tag (cons "" (reverse alist)))))
1358                           (t
1359                            (let ((choice (completing-read (concat tag
1360                                                                   " (default "
1361                                                                   default
1362                                                                   "): ")
1363                                                           alist nil t)))
1364                              (if (or (null choice) (string-equal choice ""))
1365                                  (setq choice default))
1366                              (cdr (assoc choice alist)))))))
1367         (if answer
1368             (custom-field-accept field (custom-default answer)))))))
1369
1370 (defun custom-file-query (field)
1371   "Prompt for a file name"
1372   (let* ((value (custom-field-value field))
1373          (custom (custom-field-custom field))
1374          (valid (custom-valid custom value))
1375          (directory (custom-property custom 'directory))
1376          (default (and (not valid)
1377                        (custom-property custom 'default-file)))
1378          (tag (custom-tag custom))
1379          (prompt (if default
1380                      (concat tag " (" default "): ")
1381                    (concat tag ": "))))
1382     (custom-field-accept field
1383                          (if (custom-valid custom value)
1384                              (read-file-name prompt
1385                                              (if (file-name-absolute-p value)
1386                                                  ""
1387                                                directory)
1388                                              default nil value)
1389                            (read-file-name prompt directory default)))))
1390
1391 (defun custom-face-eval (custom value)
1392   "Return non-nil if CUSTOM's VALUE needs to be evaluated."
1393   (not (symbolp value)))
1394
1395 (defun custom-face-import (custom value)
1396   "Modify CUSTOM's VALUE to match internal expectations."
1397   (let ((name (or (and (facep value) (symbol-name (face-name value)))
1398                   (symbol-name value))))
1399     (list (if (string-match "\
1400 custom-face-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)"
1401                             name)
1402               (list 'custom-face-lookup
1403                     (match-string 1 name)
1404                     (match-string 2 name)
1405                     (match-string 3 name)
1406                     (intern (match-string 4 name))
1407                     (intern (match-string 5 name))
1408                     (intern (match-string 6 name)))
1409             value))))
1410
1411 (defun custom-face-lookup (&optional fg bg stipple bold italic underline)
1412   "Lookup or create a face with specified attributes."
1413   (let ((name (intern (format "custom-face-%s-%s-%s-%S-%S-%S"
1414                               (or fg "default")
1415                               (or bg "default")
1416                               (or stipple "default")
1417                               bold italic underline))))
1418     (if (and (custom-facep name)
1419              (fboundp 'make-face))
1420         ()
1421       (copy-face 'default name)
1422       (when (and fg
1423                  (not (string-equal fg "default")))
1424         (condition-case ()
1425             (set-face-foreground name fg)
1426           (error nil)))
1427       (when (and bg
1428                  (not (string-equal bg "default")))
1429         (condition-case ()
1430             (set-face-background name bg)
1431           (error nil)))
1432       (when (and stipple
1433                  (not (string-equal stipple "default"))
1434                  (not (eq stipple 'custom:asis))
1435                  (fboundp 'set-face-stipple))
1436         (set-face-stipple name stipple))
1437       (when (and bold
1438                  (not (eq bold 'custom:asis)))
1439         (condition-case ()
1440             (make-face-bold name)
1441           (error nil)))
1442       (when (and italic
1443                  (not (eq italic 'custom:asis)))
1444         (condition-case ()
1445             (make-face-italic name)
1446           (error nil)))
1447       (when (and underline
1448                  (not (eq underline 'custom:asis)))
1449         (condition-case ()
1450             (set-face-underline-p name t)
1451           (error nil))))
1452     name))
1453
1454 (defun custom-face-hack (field value)
1455   "Face that should be used for highlighting FIELD containing VALUE."
1456   (let* ((custom (custom-field-custom field))
1457          (form (funcall (custom-property custom 'export) custom value))
1458          (face (apply (car form) (cdr form))))
1459     (if (custom-facep face) face nil)))
1460
1461 (defun custom-const-insert (custom level)
1462   "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1463   (let* ((field (custom-field-create custom custom-nil))
1464          (face (custom-field-face field))
1465          (from (point)))
1466     (custom-text-insert (custom-tag custom))
1467     (custom-add-text-properties from (point)
1468                                 (list 'face face
1469                                       rear-nonsticky t))
1470     (custom-documentation-insert custom)
1471     (custom-field-move field from (point))
1472     field))
1473
1474 (defun custom-const-update (field)
1475   "Update face of FIELD."
1476   (let ((from (custom-field-start field))
1477         (custom (custom-field-custom field)))
1478     (custom-put-text-property from (+ from (length (custom-tag custom)))
1479                               'face (custom-field-face field))))
1480
1481 (defun custom-const-valid (custom value)
1482   "Non-nil if CUSTOM can validly have the value VALUE."
1483   (equal (custom-default custom) value))
1484
1485 (defun custom-const-face (field)
1486   "Face used for a FIELD."
1487   (custom-default (custom-field-custom field)))
1488
1489 (defun custom-sexp-read (custom string)
1490   "Read from CUSTOM an STRING."
1491   (save-match-data
1492     (save-excursion
1493       (set-buffer (get-buffer-create " *Custom Scratch*"))
1494       (erase-buffer)
1495       (insert string)
1496       (goto-char (point-min))
1497       (prog1 (read (current-buffer))
1498         (or (looking-at
1499              (concat (regexp-quote (char-to-string
1500                                     (custom-padding custom)))
1501                      "*\\'"))
1502             (error "Junk at end of expression"))))))
1503
1504 (autoload 'pp-to-string "pp")
1505
1506 (defun custom-sexp-write (custom sexp)
1507   "Write CUSTOM SEXP as string."
1508   (let ((string (prin1-to-string sexp)))
1509     (if (<= (length string) (custom-width custom))
1510         string
1511       (setq string (pp-to-string sexp))
1512       (string-match "[ \t\n]*\\'" string)
1513       (concat "\n" (substring string 0 (match-beginning 0))))))
1514
1515 (defun custom-string-read (custom string)
1516   "Read string by ignoring trailing padding characters."
1517   (let ((last (length string))
1518         (padding (custom-padding custom)))
1519     (while (and (> last 0)
1520                 (eq (aref string (1- last)) padding))
1521       (setq last (1- last)))
1522     (substring string 0 last)))
1523
1524 (defun custom-string-write (custom string)
1525   "Write raw string."
1526   string)
1527
1528 (defun custom-button-insert (custom level)
1529   "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1530   (custom-tag-insert (concat "[" (custom-tag custom) "]")
1531                      (custom-property custom 'query))
1532   (custom-documentation-insert custom)
1533   nil)
1534
1535 (defun custom-default-export (custom value)
1536   ;; Convert CUSTOM's VALUE to external representation.
1537   ;; See `custom-import'.
1538   (if (custom-eval custom value)
1539       (eval (car (custom-quote custom value)))
1540     value))
1541
1542 (defun custom-default-quote (custom value)
1543   "Quote CUSTOM's VALUE if necessary."
1544   (list (if (and (not (custom-eval custom value))
1545                  (or (and (symbolp value)
1546                           value
1547                           (not (eq t value)))
1548                      (and (listp value)
1549                           value
1550                           (not (memq (car value) '(quote function lambda))))))
1551             (list 'quote value)
1552           value)))
1553
1554 (defun custom-default-initialize (custom)
1555   "Initialize `doc' and `default' entries in CUSTOM."
1556   (let ((name (custom-name custom)))
1557     (if (null name)
1558         ()
1559       (let ((default (custom-default custom))
1560             (doc (custom-documentation custom))
1561             (vdoc (documentation-property name 'variable-documentation t)))
1562         (if doc
1563             (or vdoc (put name 'variable-documentation doc))
1564           (if vdoc (custom-property-set custom 'doc vdoc)))
1565         (if (eq default custom-nil)
1566             (if (boundp name)
1567                 (custom-property-set custom 'default (symbol-value name)))
1568           (or (boundp name)
1569               (set name default)))))))
1570
1571 (defun custom-default-insert (custom level)
1572   "Insert field for CUSTOM at nesting LEVEL in customization buffer."
1573   (let ((field (custom-field-create custom custom-nil))
1574         (tag (custom-tag custom)))
1575     (if (null tag)
1576         ()
1577       (custom-tag-insert tag field)
1578       (custom-text-insert ": "))
1579     (custom-field-insert field)
1580     (custom-documentation-insert custom)
1581     field))
1582
1583 (defun custom-default-accept (field value &optional original)
1584   "Store a new value into field FIELD, taking it from VALUE."
1585   (if original
1586       (custom-field-original-set field value))
1587   (custom-field-value-set field value)
1588   (custom-field-update field))
1589
1590 (defun custom-default-apply (field)
1591   "Apply any changes in FIELD since the last apply."
1592   (let* ((custom (custom-field-custom field))
1593          (name (custom-name custom)))
1594     (if (null name)
1595         (error "This field cannot be applied alone"))
1596     (custom-external-set name (custom-name-value name))
1597     (custom-field-reset field)))
1598
1599 (defun custom-default-reset (field)
1600   "Reset content of editing FIELD to `original'."
1601   (custom-field-accept field (custom-field-original field) t))
1602
1603 (defun custom-default-factory-reset (field)
1604   "Reset content of editing FIELD to `default'."
1605   (let* ((custom (custom-field-custom field))
1606          (default (car (custom-import custom (custom-default custom)))))
1607     (or (eq default custom-nil)
1608         (custom-field-accept field default nil))))
1609
1610 (defun custom-default-query (field)
1611   "Prompt for a FIELD"
1612   (let* ((custom (custom-field-custom field))
1613          (value (custom-field-value field))
1614          (initial (custom-write custom value))
1615          (prompt (concat (custom-prompt custom) ": ")))
1616     (custom-field-accept field
1617                          (custom-read custom
1618                                       (if (custom-valid custom value)
1619                                           (read-string prompt (cons initial 1))
1620                                         (read-string prompt))))))
1621
1622 (defun custom-default-match (custom values)
1623   "Match CUSTOM with VALUES."
1624   values)
1625
1626 (defun custom-default-extract (custom field)
1627   "Extract CUSTOM's content in FIELD."
1628   (list (custom-field-value field)))
1629
1630 (defun custom-default-validate (custom field)
1631   "Validate FIELD."
1632   (let ((value (custom-field-value field))
1633         (start (custom-field-start field)))
1634     (cond ((eq value custom-nil)
1635            (cons start "Uninitialized field"))
1636           ((and (consp value) (eq (car value) custom-invalid))
1637            (cons start "Unparsable field content"))
1638           ((custom-valid custom value)
1639            nil)
1640           (t
1641            (cons start "Wrong type of field content")))))
1642
1643 (defun custom-default-face (field)
1644   "Face used for a FIELD."
1645   (let ((value (custom-field-value field)))
1646     (cond ((eq value custom-nil)
1647            custom-field-uninitialized-face)
1648           ((not (custom-valid (custom-field-custom field) value))
1649            custom-field-invalid-face)
1650           ((not (equal (custom-field-original field) value))
1651            custom-field-modified-face)
1652           (t
1653            custom-field-face))))
1654
1655 (defun custom-default-update (field)
1656   "Update the content of FIELD."
1657   (let ((inhibit-point-motion-hooks t)
1658         (before-change-functions nil)
1659         (after-change-functions nil)
1660         (start (custom-field-start field))
1661         (end (custom-field-end field))
1662         (pos (point)))
1663     ;; Keep track of how many modified fields we have.
1664     (cond ((equal (custom-field-value field) (custom-field-original field))
1665            (setq custom-modified-list (delq field custom-modified-list)))
1666           ((memq field custom-modified-list))
1667           (t
1668            (setq custom-modified-list (cons field custom-modified-list))))
1669     ;; Update the field.
1670     (goto-char end)
1671     (insert-before-markers " ")
1672     (delete-region start (1- end))
1673     (goto-char start)
1674     (custom-field-insert field)
1675     (goto-char end)
1676     (delete-char 1)
1677     (goto-char pos)
1678     (and (<= start pos)
1679          (<= pos end)
1680          (custom-field-enter field))))
1681
1682 ;;; Create Buffer:
1683 ;;
1684 ;; Public functions to create a customization buffer and to insert
1685 ;; various forms of text, fields, and buttons in it.
1686
1687 (defun customize ()
1688   "Customize GNU Emacs.
1689 Create a *Customize* buffer with editable customization information
1690 about GNU Emacs."
1691   (interactive)
1692   (custom-buffer-create "*Customize*")
1693   (custom-reset-all))
1694
1695 (defun custom-buffer-create (name &optional custom types set get save)
1696   "Create a customization buffer named NAME.
1697 If the optional argument CUSTOM is non-nil, use that as the custom declaration.
1698 If the optional argument TYPES is non-nil, use that as the local types.
1699 If the optional argument SET is non-nil, use that to set external data.
1700 If the optional argument GET is non-nil, use that to get external data.
1701 If the optional argument SAVE is non-nil, use that for saving changes."
1702   (switch-to-buffer name)
1703   (buffer-disable-undo (current-buffer))
1704   (custom-mode)
1705   (setq custom-local-type-properties types)
1706   (if (null custom)
1707       ()
1708     (make-local-variable 'custom-data)
1709     (setq custom-data custom))
1710   (if (null set)
1711       ()
1712     (make-local-variable 'custom-external-set)
1713     (setq custom-external-set set))
1714   (if (null get)
1715       ()
1716     (make-local-variable 'custom-external)
1717     (setq custom-external get))
1718   (if (null save)
1719       ()
1720     (make-local-variable 'custom-save)
1721     (setq custom-save save))
1722   (let ((inhibit-point-motion-hooks t)
1723         (before-change-functions nil)
1724         (after-change-functions nil))
1725     (erase-buffer)
1726     (insert "\n")
1727     (goto-char (point-min))
1728     (custom-text-insert "This is a customization buffer.\n")
1729     (custom-help-insert "\n")
1730     (custom-help-button 'custom-forward-field)
1731     (custom-help-button 'custom-backward-field)
1732     (custom-help-button 'custom-enter-value)
1733     (custom-help-button 'custom-field-factory-reset)
1734     (custom-help-button 'custom-field-reset)
1735     (custom-help-button 'custom-field-apply)
1736     (custom-help-button 'custom-save-and-exit)
1737     (custom-help-button 'custom-toggle-documentation)
1738     (custom-help-insert "\nClick mouse-2 on any button to activate it.\n")
1739     (custom-text-insert "\n")
1740     (custom-insert custom-data 0)
1741     (goto-char (point-min))))
1742
1743 (defun custom-insert (custom level)
1744   "Insert custom declaration CUSTOM in current buffer at level LEVEL."
1745   (if (stringp custom)
1746       (progn
1747         (custom-text-insert custom)
1748         nil)
1749     (and level (null (custom-property custom 'header))
1750          (setq level nil))
1751     (and level
1752          (> level 0)
1753          (custom-text-insert (concat "\n" (make-string level ?*) " ")))
1754     (let ((field (funcall (custom-property custom 'insert) custom level)))
1755       (custom-name-enter (custom-name custom) field)
1756       field)))
1757
1758 (defun custom-text-insert (text)
1759   "Insert TEXT in current buffer."
1760   (insert text))
1761
1762 (defun custom-tag-insert (tag field &optional data)
1763   "Insert TAG for FIELD in current buffer."
1764   (let ((from (point)))
1765     (insert tag)
1766     (custom-category-set from (point) 'custom-button-properties)
1767     (custom-put-text-property from (point) 'custom-tag field)
1768     (if data
1769         (custom-add-text-properties from (point) (list 'custom-data data)))))
1770
1771 (defun custom-documentation-insert (custom &rest ignore)
1772   "Insert documentation from CUSTOM in current buffer."
1773   (let ((doc (custom-documentation custom)))
1774     (if (null doc)
1775         ()
1776       (custom-help-insert "\n" doc))))
1777
1778 (defun custom-help-insert (&rest args)
1779   "Insert ARGS as documentation text."
1780   (let ((from (point)))
1781     (apply 'insert args)
1782     (custom-category-set from (point) 'custom-documentation-properties)))
1783
1784 (defun custom-help-button (command)
1785   "Describe how to execute COMMAND."
1786   (let ((from (point)))
1787     (insert "`" (key-description (where-is-internal command nil t)) "'")
1788     (custom-set-text-properties from (point)
1789                                 (list 'face custom-button-face
1790                                       mouse-face custom-mouse-face
1791                                       'custom-jump t ;Make TAB jump over it.
1792                                       'custom-tag command
1793                                       'start-open t
1794                                       'end-open t))
1795     (custom-category-set from (point) 'custom-documentation-properties))
1796   (custom-help-insert ": " (custom-first-line (documentation command)) "\n"))
1797
1798 ;;; Mode:
1799 ;;
1800 ;; The Customization major mode and interactive commands.
1801
1802 (defvar custom-mode-map nil
1803   "Keymap for Custom Mode.")
1804 (if custom-mode-map
1805     nil
1806   (setq custom-mode-map (make-sparse-keymap))
1807   (define-key custom-mode-map (if (string-match "XEmacs" emacs-version) [button2] [mouse-2]) 'custom-push-button)
1808   (define-key custom-mode-map "\t" 'custom-forward-field)
1809   (define-key custom-mode-map "\M-\t" 'custom-backward-field)
1810   (define-key custom-mode-map "\r" 'custom-enter-value)
1811   (define-key custom-mode-map "\C-k" 'custom-kill-line)
1812   (define-key custom-mode-map "\C-c\C-r" 'custom-field-reset)
1813   (define-key custom-mode-map "\C-c\M-\C-r" 'custom-reset-all)
1814   (define-key custom-mode-map "\C-c\C-z" 'custom-field-factory-reset)
1815   (define-key custom-mode-map "\C-c\M-\C-z" 'custom-factory-reset-all)
1816   (define-key custom-mode-map "\C-c\C-a" 'custom-field-apply)
1817   (define-key custom-mode-map "\C-c\M-\C-a" 'custom-apply-all)
1818   (define-key custom-mode-map "\C-c\C-c" 'custom-save-and-exit)
1819   (define-key custom-mode-map "\C-c\C-d" 'custom-toggle-documentation))
1820
1821 ;; C-c keymap ideas: C-a field-beginning, C-e field-end, C-f
1822 ;; forward-field, C-b backward-field, C-n next-field, C-p
1823 ;; previous-field, ? describe-field.
1824
1825 (defun custom-mode ()
1826   "Major mode for doing customizations.
1827
1828 \\{custom-mode-map}"
1829   (kill-all-local-variables)
1830   (setq major-mode 'custom-mode
1831         mode-name "Custom")
1832   (use-local-map custom-mode-map)
1833   (make-local-variable 'before-change-functions)
1834   (setq before-change-functions '(custom-before-change))
1835   (make-local-variable 'after-change-functions)
1836   (setq after-change-functions '(custom-after-change))
1837   (if (not (fboundp 'make-local-hook))
1838       ;; Emacs 19.28 and earlier.
1839       (add-hook 'post-command-hook
1840                 (lambda ()
1841                   (if (eq major-mode 'custom-mode)
1842                       (custom-post-command))))
1843     ;; Emacs 19.29.
1844     (make-local-hook 'post-command-hook)
1845     (add-hook 'post-command-hook 'custom-post-command nil t)))
1846
1847 (defun custom-forward-field (arg)
1848   "Move point to the next field or button.
1849 With optional ARG, move across that many fields."
1850   (interactive "p")
1851   (while (> arg 0)
1852     (let ((next (if (get-text-property (point) 'custom-tag)
1853                     (next-single-property-change (point) 'custom-tag)
1854                   (point))))
1855       (setq next (or (next-single-property-change next 'custom-tag)
1856                      (next-single-property-change (point-min) 'custom-tag)))
1857       (if next
1858           (goto-char next)
1859         (error "No customization fields in this buffer.")))
1860     (or (get-text-property (point) 'custom-jump)
1861         (setq arg (1- arg))))
1862   (while (< arg 0)
1863     (let ((previous (if (get-text-property (1- (point)) 'custom-tag)
1864                         (previous-single-property-change (point) 'custom-tag)
1865                       (point))))
1866       (setq previous
1867             (or (previous-single-property-change previous 'custom-tag)
1868                 (previous-single-property-change (point-max) 'custom-tag)))
1869       (if previous
1870           (goto-char previous)
1871         (error "No customization fields in this buffer.")))
1872     (or (get-text-property (1- (point)) 'custom-jump)
1873         (setq arg (1+ arg)))))
1874
1875 (defun custom-backward-field (arg)
1876   "Move point to the previous field or button.
1877 With optional ARG, move across that many fields."
1878   (interactive "p")
1879   (custom-forward-field (- arg)))
1880
1881 (defun custom-toggle-documentation (&optional arg)
1882   "Toggle display of documentation text.
1883 If the optional argument is non-nil, show text iff the argument is positive."
1884   (interactive "P")
1885   (let ((hide (or (and (null arg)
1886                        (null (custom-category-get
1887                               'custom-documentation-properties 'invisible)))
1888                   (<= (prefix-numeric-value arg) 0))))
1889     (custom-category-put 'custom-documentation-properties 'invisible hide)
1890     (custom-category-put 'custom-documentation-properties intangible hide))
1891   (redraw-display))
1892
1893 (defun custom-enter-value (field data)
1894   "Enter value for current customization field or push button."
1895   (interactive (list (get-text-property (point) 'custom-tag)
1896                      (get-text-property (point) 'custom-data)))
1897   (cond (data
1898          (funcall field data))
1899         ((eq field 'custom-enter-value)
1900          (error "Don't be silly"))
1901         ((and (symbolp field) (fboundp field))
1902          (call-interactively field))
1903         (field
1904          (custom-field-query field))
1905         (t
1906          (message "Nothing to enter here"))))
1907
1908 (defun custom-kill-line ()
1909   "Kill to end of field or end of line, whichever is first."
1910   (interactive)
1911   (let ((field (get-text-property (point) 'custom-field))
1912         (newline (save-excursion (search-forward "\n")))
1913         (next (next-single-property-change (point) 'custom-field)))
1914     (if (and field (> newline next))
1915         (kill-region (point) next)
1916       (call-interactively 'kill-line))))
1917
1918 (defun custom-push-button (event)
1919   "Activate button below mouse pointer."
1920   (interactive "@e")
1921   (let* ((pos (event-point event))
1922          (field (get-text-property pos 'custom-field))
1923          (tag (get-text-property pos 'custom-tag))
1924          (data (get-text-property pos 'custom-data)))
1925     (cond (data
1926            (funcall tag data))
1927           ((and (symbolp tag) (fboundp tag))
1928            (call-interactively tag))
1929           (field
1930            (call-interactively (lookup-key global-map (this-command-keys))))
1931           (tag
1932            (custom-enter-value tag data))
1933           (t
1934            (error "Nothing to click on here.")))))
1935
1936 (defun custom-reset-all ()
1937   "Undo any changes since the last apply in all fields."
1938   (interactive (and custom-modified-list
1939                     (not (y-or-n-p "Discard all changes? "))
1940                     (error "Reset aborted")))
1941   (let ((all custom-name-fields)
1942         current field)
1943     (while all
1944       (setq current (car all)
1945             field (cdr current)
1946             all (cdr all))
1947       (custom-field-reset field))))
1948
1949 (defun custom-field-reset (field)
1950   "Undo any changes in FIELD since the last apply."
1951   (interactive (list (or (get-text-property (point) 'custom-field)
1952                          (get-text-property (point) 'custom-tag))))
1953   (if (arrayp field)
1954       (let* ((custom (custom-field-custom field))
1955              (name (custom-name custom)))
1956         (save-excursion
1957           (if name
1958               (custom-field-original-set
1959                field (car (custom-import custom (custom-external name)))))
1960           (if (not (custom-valid custom (custom-field-original field)))
1961               (error "This field cannot be reset alone")
1962             (funcall (custom-property custom 'reset) field)
1963             (funcall (custom-property custom 'synchronize) field))))))
1964
1965 (defun custom-factory-reset-all ()
1966   "Reset all field to their default values."
1967   (interactive (and custom-modified-list
1968                     (not (y-or-n-p "Discard all changes? "))
1969                     (error "Reset aborted")))
1970   (let ((all custom-name-fields)
1971         field)
1972     (while all
1973       (setq field (cdr (car all))
1974             all (cdr all))
1975       (custom-field-factory-reset field))))
1976
1977 (defun custom-field-factory-reset (field)
1978   "Reset FIELD to its default value."
1979   (interactive (list (or (get-text-property (point) 'custom-field)
1980                          (get-text-property (point) 'custom-tag))))
1981   (if (arrayp field)
1982       (save-excursion
1983         (funcall (custom-property (custom-field-custom field) 'factory-reset)
1984                  field))))
1985
1986 (defun custom-apply-all ()
1987   "Apply any changes since the last reset in all fields."
1988   (interactive (if custom-modified-list
1989                    nil
1990                  (error "No changes to apply.")))
1991   (custom-field-parse custom-field-last)
1992   (let ((all custom-name-fields)
1993         field)
1994     (while all
1995       (setq field (cdr (car all))
1996             all (cdr all))
1997       (let ((error (custom-field-validate (custom-field-custom field) field)))
1998         (if (null error)
1999             ()
2000           (goto-char (car error))
2001           (error (cdr error))))))
2002   (let ((all custom-name-fields)
2003         field)
2004     (while all
2005       (setq field (cdr (car all))
2006             all (cdr all))
2007       (custom-field-apply field))))
2008
2009 (defun custom-field-apply (field)
2010   "Apply any changes in FIELD since the last apply."
2011   (interactive (list (or (get-text-property (point) 'custom-field)
2012                          (get-text-property (point) 'custom-tag))))
2013   (custom-field-parse custom-field-last)
2014   (if (arrayp field)
2015       (let* ((custom (custom-field-custom field))
2016              (error (custom-field-validate custom field)))
2017         (if error
2018             (error (cdr error)))
2019         (funcall (custom-property custom 'apply) field))))
2020
2021 (defun custom-toggle-hide (&rest ignore)
2022   "Hide or show entry."
2023   (interactive)
2024   (error "This button is not yet implemented"))
2025
2026 (defun custom-save-and-exit ()
2027   "Save and exit customization buffer."
2028   (interactive "@")
2029   (save-excursion
2030     (funcall custom-save))
2031   (kill-buffer (current-buffer)))
2032
2033 (defun custom-save ()
2034   "Save customization information."
2035   (interactive)
2036   (custom-apply-all)
2037   (let ((new custom-name-fields))
2038     (set-buffer (find-file-noselect custom-file))
2039     (goto-char (point-min))
2040     (save-excursion
2041       (let ((old (condition-case nil
2042                      (read (current-buffer))
2043                    (end-of-file (append '(setq custom-dummy
2044                                                'custom-dummy) ())))))
2045         (or (eq (car old) 'setq)
2046             (error "Invalid customization file: %s" custom-file))
2047         (while new
2048           (let* ((field (cdr (car new)))
2049                  (custom (custom-field-custom field))
2050                  (value (custom-field-original field))
2051                  (default (car (custom-import custom (custom-default custom))))
2052                  (name (car (car new))))
2053             (setq new (cdr new))
2054             (custom-assert '(eq name (custom-name custom)))
2055             (if (equal default value)
2056                 (setcdr old (custom-plist-delq name (cdr old)))
2057               (setcdr old (plist-put (cdr old) name
2058                                      (car (custom-quote custom value)))))))
2059         (erase-buffer)
2060         (insert ";; " custom-file "\
2061  --- Automatically generated customization information.
2062 ;;
2063 ;; Feel free to edit by hand, but the entire content should consist of
2064 ;; a single setq.  Any other lisp expressions will confuse the
2065 ;; automatic configuration engine.
2066
2067 \(setq ")
2068         (setq old (cdr old))
2069         (while old
2070           (prin1 (car old) (current-buffer))
2071           (setq old (cdr old))
2072           (insert " ")
2073           (pp (car old) (current-buffer))
2074           (setq old (cdr old))
2075           (if old (insert "\n      ")))
2076         (insert ")\n")
2077         (save-buffer)
2078         (kill-buffer (current-buffer))))))
2079
2080 (defun custom-load ()
2081   "Save customization information."
2082   (interactive (and custom-modified-list
2083                     (not (equal (list (custom-name-field 'custom-file))
2084                                 custom-modified-list))
2085                     (not (y-or-n-p "Discard all changes? "))
2086                     (error "Load aborted")))
2087   (load-file (custom-name-value 'custom-file))
2088   (custom-reset-all))
2089
2090 ;;; Field Editing:
2091 ;;
2092 ;; Various internal functions for implementing the direct editing of
2093 ;; fields in the customization buffer.
2094
2095 (defun custom-field-untouch (field)
2096   ;; Remove FIELD and its children from `custom-modified-list'.
2097   (setq custom-modified-list (delq field custom-modified-list))
2098   (if (arrayp field)
2099       (let ((value (custom-field-value field)))
2100         (cond ((null (custom-data (custom-field-custom field))))
2101               ((arrayp value)
2102                (custom-field-untouch value))
2103               ((listp value)
2104                (mapcar 'custom-field-untouch value))))))
2105
2106
2107 (defun custom-field-insert (field)
2108   ;; Insert editing FIELD in current buffer.
2109   (let ((from (point))
2110         (custom (custom-field-custom field))
2111         (value (custom-field-value field)))
2112     (insert (custom-write custom value))
2113     (insert-char (custom-padding custom)
2114                  (- (custom-width custom) (- (point) from)))
2115     (custom-field-move field from (point))
2116     (custom-set-text-properties
2117      from (point)
2118      (list 'custom-field field
2119            'custom-tag field
2120            'face (custom-field-face field)
2121            'start-open t
2122            'end-open t))))
2123
2124 (defun custom-field-read (field)
2125   ;; Read the screen content of FIELD.
2126   (custom-read (custom-field-custom field)
2127                (custom-buffer-substring-no-properties (custom-field-start field)
2128                                                       (custom-field-end field))))
2129
2130 ;; Fields are shown in a special `active' face when point is inside
2131 ;; it.  You activate the field by moving point inside (entering) it
2132 ;; and deactivate the field by moving point outside (leaving) it.
2133
2134 (defun custom-field-leave (field)
2135   ;; Deactivate FIELD.
2136   (let ((before-change-functions nil)
2137         (after-change-functions nil))
2138     (custom-put-text-property (custom-field-start field) (custom-field-end field)
2139                               'face (custom-field-face field))))
2140
2141 (defun custom-field-enter (field)
2142   ;; Activate FIELD.
2143   (let* ((start (custom-field-start field))
2144          (end (custom-field-end field))
2145          (custom (custom-field-custom field))
2146          (padding (custom-padding custom))
2147          (before-change-functions nil)
2148          (after-change-functions nil))
2149     (or (eq this-command 'self-insert-command)
2150         (let ((pos end))
2151           (while (and (< start pos)
2152                       (eq (char-after (1- pos)) padding))
2153             (setq pos (1- pos)))
2154           (if (< pos (point))
2155               (goto-char pos))))
2156     (custom-put-text-property start end 'face custom-field-active-face)))
2157
2158 (defun custom-field-resize (field)
2159   ;; Resize FIELD after change.
2160   (let* ((custom (custom-field-custom field))
2161          (begin (custom-field-start field))
2162          (end (custom-field-end field))
2163          (pos (point))
2164          (padding (custom-padding custom))
2165          (width (custom-width custom))
2166          (size (- end begin)))
2167     (cond ((< size width)
2168            (goto-char end)
2169            (if (fboundp 'insert-before-markers-and-inherit)
2170                ;; Emacs 19.
2171                (insert-before-markers-and-inherit
2172                 (make-string (- width size) padding))
2173              ;; XEmacs:  BUG:  Doesn't work!
2174              (insert-before-markers (make-string (- width size) padding)))
2175            (goto-char pos))
2176           ((> size width)
2177            (let ((start (if (and (< (+ begin width) pos) (<= pos end))
2178                             pos
2179                           (+ begin width))))
2180              (goto-char end)
2181              (while (and (< start (point)) (= (preceding-char) padding))
2182                (backward-delete-char 1))
2183              (goto-char pos))))))
2184
2185 (defvar custom-field-changed nil)
2186 ;; List of fields changed on the screen but whose VALUE attribute has
2187 ;; not yet been updated to reflect the new screen content.
2188 (make-variable-buffer-local 'custom-field-changed)
2189
2190 (defun custom-field-parse (field)
2191   ;; Parse FIELD content iff changed.
2192   (if (memq field custom-field-changed)
2193       (progn
2194         (setq custom-field-changed (delq field custom-field-changed))
2195         (custom-field-value-set field (custom-field-read field))
2196         (custom-field-update field))))
2197
2198 (defun custom-post-command ()
2199   ;; Keep track of their active field.
2200   (custom-assert '(eq major-mode 'custom-mode))
2201   (let ((field (custom-field-property (point))))
2202     (if (eq field custom-field-last)
2203         (if (memq field custom-field-changed)
2204             (custom-field-resize field))
2205       (custom-field-parse custom-field-last)
2206       (if custom-field-last
2207           (custom-field-leave custom-field-last))
2208       (if field
2209           (custom-field-enter field))
2210       (setq custom-field-last field))
2211     (set-buffer-modified-p (or custom-modified-list
2212                                custom-field-changed))))
2213
2214 (defvar custom-field-was nil)
2215 ;; The custom data before the change.
2216 (make-variable-buffer-local 'custom-field-was)
2217
2218 (defun custom-before-change (begin end)
2219   ;; Check that we the modification is allowed.
2220   (if (not (eq major-mode 'custom-mode))
2221       (message "Aargh! Why is custom-before-change called here?")
2222     (let ((from (custom-field-property begin))
2223           (to (custom-field-property end)))
2224       (cond ((or (null from) (null to))
2225              (error "You can only modify the fields"))
2226             ((not (eq from to))
2227              (error "Changes must be limited to a single field."))
2228             (t
2229              (setq custom-field-was from))))))
2230
2231 (defun custom-after-change (begin end length)
2232   ;; Keep track of field content.
2233   (if (not (eq major-mode 'custom-mode))
2234       (message "Aargh! Why is custom-after-change called here?")
2235     (let ((field custom-field-was))
2236       (custom-assert '(prog1 field (setq custom-field-was nil)))
2237       ;; Prevent mixing fields properties.
2238       (custom-put-text-property begin end 'custom-field field)
2239       ;; Update the field after modification.
2240       (if (eq (custom-field-property begin) field)
2241           (let ((field-end (custom-field-end field)))
2242             (if (> end field-end)
2243                 (set-marker field-end end))
2244             (add-to-list 'custom-field-changed field))
2245         ;; We deleted the entire field, reinsert it.
2246         (custom-assert '(eq begin end))
2247         (save-excursion
2248           (goto-char begin)
2249           (custom-field-value-set field
2250                                   (custom-read (custom-field-custom field) ""))
2251           (custom-field-insert field))))))
2252
2253 (defun custom-field-property (pos)
2254   ;; The `custom-field' text property valid for POS.
2255   (or (get-text-property pos 'custom-field)
2256       (and (not (eq pos (point-min)))
2257            (get-text-property (1- pos) 'custom-field))))
2258
2259 ;;; Generic Utilities:
2260 ;;
2261 ;; Some utility functions that are not really specific to custom.
2262
2263 (defun custom-assert (expr)
2264   "Assert that EXPR evaluates to non-nil at this point"
2265   (or (eval expr)
2266       (error "Assertion failed: %S" expr)))
2267
2268 (defun custom-first-line (string)
2269   "Return the part of STRING before the first newline."
2270   (let ((pos 0)
2271         (len (length string)))
2272     (while (and (< pos len) (not (eq (aref string pos) ?\n)))
2273       (setq pos (1+ pos)))
2274     (if (eq pos len)
2275         string
2276       (substring string 0 pos))))
2277
2278 (defun custom-insert-before (list old new)
2279   "In LIST insert before OLD a NEW element."
2280   (cond ((null list)
2281          (list new))
2282         ((null old)
2283          (nconc list (list new)))
2284         ((eq old (car list))
2285          (cons new list))
2286         (t
2287          (let ((list list))
2288            (while (not (eq old (car (cdr list))))
2289              (setq list (cdr list))
2290              (custom-assert '(cdr list)))
2291            (setcdr list (cons new (cdr list))))
2292          list)))
2293
2294 (defun custom-strip-padding (string padding)
2295   "Remove padding from STRING."
2296   (let ((regexp (concat (regexp-quote (char-to-string padding)) "+")))
2297     (while (string-match regexp string)
2298       (setq string (concat (substring string 0 (match-beginning 0))
2299                            (substring string (match-end 0))))))
2300   string)
2301
2302 (defun custom-plist-memq (prop plist)
2303   "Return non-nil if PROP is a property of PLIST.  Comparison done with EQ."
2304   (let (result)
2305     (while plist
2306       (if (eq (car plist) prop)
2307           (setq result plist
2308                 plist nil)
2309         (setq plist (cdr (cdr plist)))))
2310     result))
2311
2312 (defun custom-plist-delq (prop plist)
2313   "Delete property PROP from property list PLIST."
2314   (while (eq (car plist) prop)
2315     (setq plist (cdr (cdr plist))))
2316   (let ((list plist)
2317         (next (cdr (cdr plist))))
2318     (while next
2319       (if (eq (car next) prop)
2320           (progn
2321             (setq next (cdr (cdr next)))
2322             (setcdr (cdr list) next))
2323         (setq list next
2324               next (cdr (cdr next))))))
2325   plist)
2326
2327 ;;; Meta Customization:
2328
2329 (custom-declare '()
2330   '((tag . "Meta Customization")
2331     (doc . "Customization of the customization support.")
2332     (type . group)
2333     (data ((type . face-doc))
2334           ((tag . "Button Face")
2335            (default . bold)
2336            (doc . "Face used for tags in customization buffers.")
2337            (name . custom-button-face)
2338            (synchronize . (lambda (f)
2339                             (custom-category-put 'custom-button-properties
2340                                                  'face custom-button-face)))
2341            (type . face))
2342           ((tag . "Mouse Face")
2343            (default . highlight)
2344            (doc . "\
2345 Face used when mouse is above a button in customization buffers.")
2346            (name . custom-mouse-face)
2347            (synchronize . (lambda (f)
2348                             (custom-category-put 'custom-button-properties
2349                                                  mouse-face
2350                                                  custom-mouse-face)))
2351            (type . face))
2352           ((tag . "Field Face")
2353            (default . italic)
2354            (doc . "Face used for customization fields.")
2355            (name . custom-field-face)
2356            (type . face))
2357           ((tag . "Uninitialized Face")
2358            (default . modeline)
2359            (doc . "Face used for uninitialized customization fields.")
2360            (name . custom-field-uninitialized-face)
2361            (type . face))
2362           ((tag . "Invalid Face")
2363            (default . highlight)
2364            (doc . "\
2365 Face used for customization fields containing invalid data.")
2366            (name . custom-field-invalid-face)
2367            (type . face))
2368           ((tag . "Modified Face")
2369            (default . bold-italic)
2370            (doc . "Face used for modified customization fields.")
2371            (name . custom-field-modified-face)
2372            (type . face))
2373           ((tag . "Active Face")
2374            (default . underline)
2375            (doc . "\
2376 Face used for customization fields while they are being edited.")
2377            (name . custom-field-active-face)
2378            (type . face)))))
2379
2380 ;; custom.el uses two categories.
2381
2382 (custom-category-create 'custom-documentation-properties)
2383 (custom-category-put 'custom-documentation-properties rear-nonsticky t)
2384
2385 (custom-category-create 'custom-button-properties)
2386 (custom-category-put 'custom-button-properties 'face custom-button-face)
2387 (custom-category-put 'custom-button-properties mouse-face custom-mouse-face)
2388 (custom-category-put 'custom-button-properties rear-nonsticky t)
2389
2390 (custom-category-create 'custom-hidden-properties)
2391 (custom-category-put 'custom-hidden-properties 'invisible
2392                      (not (string-match "XEmacs" emacs-version)))
2393 (custom-category-put 'custom-hidden-properties intangible t)
2394
2395 (if (file-readable-p custom-file)
2396     (load-file custom-file))
2397
2398 (provide 'custom)
2399
2400 ;;; custom.el ends here