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

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