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