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