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.1
   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 ;; - Add description of faces to buffer and mode.
  36 ;; - Function to generate a XEmacs menu from a CUSTOM.
  37 ;; - Add support for customizing packages.
  38 ;; - Make it possible to hide sections by clicling at the level stars.
  39 ;; - Declare AUC TeX variables.
  40 ;; - Declare (ding) Gnus variables.
  41 ;; - Declare Emacs variables.
  42 ;; - Implement remaining types.
  43 ;; - XEmacs port.
  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 ;; We can't easily check for a working intangible.
  70 (if (and (boundp 'emacs-minor-version)
  71          (or (> emacs-major-version 19)
  72              (and (> emacs-major-version 18)
  73                   (> emacs-minor-version 28))))
  74     (setq intangible 'intangible)
  75   (setq intangible 'intangible-if-it-had-been-working))
  76
  77 ;;; Faces:
  78 ;;
  79 ;; The following variables define the faces used in the customization
  80 ;; buffer.
  81
  82 (defvar custom-button-face 'bold
  83   "Face used for tags in customization buffers.")
  84
  85 (defvar custom-field-uninitialized-face 'modeline
  86   "Face used for uninitialized customization fields.")
  87
  88 (defvar custom-field-invalid-face 'highlight
  89   "Face used for customization fields containing invalid data.")
  90
  91 (defvar custom-field-modified-face 'bold-italic
  92   "Face used for modified customization fields.")
  93
  94 (defvar custom-field-active-face 'underline
  95   "Face used for customization fields while they are being edited.")
  96
  97 (defvar custom-field-face 'italic
  98   "Face used for customization fields.")
  99
 100 (defvar custom-mouse-face 'highlight
 101   "Face used for tags in customization buffers.")
 102
 103 (defvar custom-documentation-properties 'custom-documentation-properties
 104   "The properties of this symbol will be in effect for all documentation.")
 105 (put custom-documentation-properties 'rear-nonsticky t)
 106
 107 (defvar custom-button-properties 'custom-button-properties
 108   "The properties of this symbol will be in effect for all buttons.")
 109 (put custom-button-properties 'face custom-button-face)
 110 (put custom-button-properties 'mouse-face custom-mouse-face)
 111 (put custom-button-properties 'rear-nonsticky t)
 112
 113 ;;; External Data:
 114 ;;
 115 ;; The following functions and variables defines the interface for
 116 ;; connecting a CUSTOM with an external entity, by default an emacs
 117 ;; lisp variable.
 118
 119 (defvar custom-external 'default-value
 120   "Function returning the external value of NAME.")
 121
 122 (defvar custom-external-set 'set-default
 123   "Function setting the external value of NAME to VALUE.")
 124
 125 (defun custom-external (name)
 126   "Get the external value associated with NAME."
 127   (funcall custom-external name))
 128
 129 (defun custom-external-set (name value)
 130   "Set the external value associated with NAME to VALUE."
 131   (funcall custom-external-set name value))
 132
 133 (defvar custom-name-fields nil
 134   "Alist of custom names and their associated editing field.")
 135 (make-variable-buffer-local 'custom-name-fields)
 136
 137 (defun custom-name-enter (name field)
 138   "Associate NAME with FIELD."
 139   (if (null name)
 140       ()
 141     (custom-assert 'field)
 142     (setq custom-name-fields (cons (cons name field) custom-name-fields))))
 143
 144 (defun custom-name-value (name)
 145   "The value currently displayed for NAME in the customization buffer."
 146   (let ((field (cdr (assq name custom-name-fields))))
 147     (car (custom-field-extract (custom-field-custom field) field))))
 148
 149 ;;; Custom Functions:
 150 ;;
 151 ;; The following functions are part of the public interface to the
 152 ;; CUSTOM datastructure.  Each CUSTOM describes a group of variables,
 153 ;; a single variable, or a component of a structured variable.  The
 154 ;; CUSTOM instances are part of two hiearachies, the first is the
 155 ;; `part-of' hierarchy in which each CUSTOM is a component of another
 156 ;; CUSTOM, except for the top level CUSTOM which is contained in
 157 ;; `custom-data'.  The second hiearachy is a `is-a' type hierarchy
 158 ;; where each CUSTOM is a leaf in the hierarchy defined by the `type'
 159 ;; property and `custom-type-properties'.
 160
 161 (defconst custom-data
 162   '((tag . "Emacs")
 163     (doc . "The extensible self-documenting text editor.")
 164     (type . group)
 165     (data . nil))
 166   "The global customization information.
 167 A custom association list.")
 168
 169 (defconst custom-type-properties
 170   '((repeat (type . default)
 171             (accept . custom-repeat-accept)
 172             (extract . custom-repeat-extract)
 173             (validate . custom-repeat-validate)
 174             (insert . custom-repeat-insert)
 175             (match . custom-repeat-match)
 176             (query . custom-repeat-query)
 177             (del-tag . "[DEL]")
 178             (add-tag . "[INS]"))
 179     (list (type . group)
 180           (accept . custom-list-accept)
 181           (extract . custom-list-extract)
 182           (validate . custom-list-validate)
 183           (check . custom-list-check))
 184     (group (type . default)
 185            (extract . nil)
 186            (validate . nil)
 187            (query . custom-toggle-hide)
 188            (accept . custom-group-accept)
 189            (insert . custom-group-insert))
 190     (toggle (type . choice)
 191             (data ((type . const)
 192                    (tag . "On")
 193                    (default . t))
 194                   ((type . const)
 195                    (tag . "Off")
 196                    (default . nil))))
 197     (choice (type . default)
 198             (query . custom-choice-query)
 199             (accept . custom-choice-accept)
 200             (extract . custom-choice-extract)
 201             (validate . custom-choice-validate)
 202             (check . custom-choice-check)
 203             (insert . custom-choice-insert)
 204             (none (tag . "Unknown")
 205                   (default . __uninitialized__)
 206                   (type . const)))
 207     (const (type . default)
 208            (accept . ignore)
 209            (extract . (lambda (c f) (list (custom-default c))))
 210            (validate . (lambda (c f) nil))
 211            (valid . custom-const-valid)
 212            (insert . custom-const-insert))
 213     (file (type . string)
 214           (directory . nil)
 215           (default-file . nil)
 216           (query . custom-file-query))
 217     (integer (type . default)
 218              (width . 10)
 219              (valid . (lambda (c d) (integerp d)))
 220              (allow-padding . nil)
 221              (read . custom-integer-read)
 222              (write . custom-integer-write))
 223     (string (type . default)
 224             (width . 40)
 225             (valid . (lambda (c d) (stringp d)))
 226             (read . custom-string-read)
 227             (write . custom-string-write))
 228     (button (type . default)
 229             (accept . ignore)
 230             (extract . nil)
 231             (validate . nil)
 232             (insert . custom-button-insert))
 233     (doc (type . default)
 234          (rest . nil)
 235          (extract . nil)
 236          (validate . nil)
 237          (insert . custom-documentation-insert))
 238     (default (width . 20)
 239              (valid . (lambda (c v) t))
 240              (insert . custom-default-insert)
 241              (query . custom-default-query)
 242              (tag . nil)
 243              (doc . nil)
 244              (header . t)
 245              (padding . ? )
 246              (allow-padding . t)
 247              (extract . custom-default-extract)
 248              (validate . custom-default-validate)
 249              (reset . custom-default-reset)
 250              (accept . custom-default-accept)
 251              (match . custom-default-match)
 252              (name . nil)
 253              (compact . nil)
 254              (default . __uninitialized__)))
 255   "Alist of default properties for type symbols.
 256 The format is `((SYMBOL (PROPERTY . VALUE)... )... )'.")
 257
 258 (defconst custom-local-type-properties nil
 259   "Local type properties.")
 260 (make-variable-buffer-local 'custom-local-type-properties)
 261
 262 (defconst custom-nil '__uninitialized__
 263   "Special value representing an uninitialized field.")
 264
 265 (defun custom-property (custom property)
 266   "Extract from CUSTOM property PROPERTY."
 267   (let ((entry (assq property custom)))
 268     (while (null entry)
 269       ;; Look in superclass.
 270       (let ((type (custom-type custom)))
 271         (setq custom (cdr (or (assq type custom-local-type-properties)
 272                               (assq type custom-type-properties)))
 273               entry (assq property custom))
 274         (custom-assert 'custom)))
 275     (cdr entry)))
 276
 277 (defun custom-type (custom)
 278   "Extract `type' from CUSTOM."
 279   (cdr (assq 'type custom)))
 280
 281 (defun custom-name (custom)
 282   "Extract `name' from CUSTOM."
 283   (custom-property custom 'name))
 284
 285 (defun custom-tag (custom)
 286   "Extract `tag' from CUSTOM."
 287   (custom-property custom 'tag))
 288
 289 (defun custom-tag-or-type (custom)
 290   "Extract `tag' from CUSTOM.  If none exist, create one from `type'"
 291   (or (custom-property custom 'tag)
 292       (capitalize (symbol-name (custom-type custom)))))
 293
 294 (defun custom-default (custom)
 295   "Extract `default' from CUSTOM."
 296   (custom-property custom 'default))
 297
 298 (defun custom-data (custom)
 299   "Extract the `data' from CUSTOM."
 300   (custom-property custom 'data))
 301
 302 (defun custom-documentation (custom)
 303   "Extract `doc' from CUSTOM."
 304   (custom-property custom 'doc))
 305
 306 (defun custom-width (custom)
 307   "Extract `width' from CUSTOM."
 308   (custom-property custom 'width))
 309
 310 (defun custom-compact (custom)
 311   "Extract `compact' from CUSTOM."
 312   (custom-property custom 'compact))
 313
 314 (defun custom-padding (custom)
 315   "Extract `padding' from CUSTOM."
 316   (custom-property custom 'padding))
 317
 318 (defun custom-allow-padding (custom)
 319   "Extract `allow-padding' from CUSTOM."
 320   (custom-property custom 'allow-padding))
 321
 322 (defun custom-valid (custom value)
 323   "Non-nil if CUSTOM may legally be set to VALUE."
 324   (funcall (custom-property custom 'valid) custom value))
 325
 326 (defun custom-write (custom value)
 327   "Convert CUSTOM VALUE to a string."
 328   (if (eq value custom-nil)
 329       ""
 330     (funcall (custom-property custom 'write) custom value)))
 331
 332 (defun custom-read (custom string)
 333   "Convert CUSTOM field content STRING into external form."
 334   (funcall (custom-property custom 'read) custom string))
 335
 336 (defun custom-match (custom values)
 337   "Match CUSTOM with a list of VALUES.
 338 Return a cons-cell where the car is the sublist of VALUES matching CUSTOM,
 339 and the cdr is the remaining VALUES."
 340   (if (memq values (list custom-nil nil))
 341       (cons custom-nil nil)
 342     (funcall (custom-property custom 'match) custom values)))
 343
 344 (defun custom-field-extract (custom field)
 345   "Extract CUSTOM's value in FIELD."
 346   (if (stringp custom)
 347       nil
 348     (funcall (custom-property (custom-field-custom field) 'extract)
 349              custom field)))
 350
 351 (defun custom-field-validate (custom field)
 352   "Validate CUSTOM's value in FIELD.
 353 Return nil if valid, otherwise return a cons-cell where the car is the
 354 position of the error, and the cdr is a text describing the error."
 355   (if (stringp custom)
 356       nil
 357     (funcall (custom-property custom 'validate) custom field)))
 358
 359 ;;; Field Functions:
 360 ;;
 361 ;; This section defines the public functions for manipulating the
 362 ;; FIELD datatype.  The FIELD instance hold information about a
 363 ;; specific editing field in the customization buffer.
 364 ;;
 365 ;; Each FIELD can be seen as an instanciation of a CUSTOM.
 366
 367 (defun custom-field-create (custom value)
 368   "Create a field structure of type CUSTOM containing VALUE.
 369
 370 A field structure is an array [ CUSTOM VALUE ORIGINAL START END ], where
 371 CUSTOM defines the type of the field,
 372 VALUE is the current value of the field,
 373 ORIGINAL is the original value when created, and
 374 START and END are markers to the start and end of the field."
 375   (vector custom value custom-nil nil nil))
 376
 377 (defun custom-field-custom (field)
 378   "Return the `custom' attribute of FIELD."
 379   (aref field 0))
 380
 381 (defun custom-field-value (field)
 382   "Return the `value' attribute of FIELD."
 383   (aref field 1))
 384
 385 (defun custom-field-original (field)
 386   "Return the `original' attribute of FIELD."
 387   (aref field 2))
 388
 389 (defun custom-field-start (field)
 390   "Return the `start' attribute of FIELD."
 391   (aref field 3))
 392
 393 (defun custom-field-end (field)
 394   "Return the `end' attribute of FIELD."
 395   (aref field 4))
 396
 397 (defun custom-field-value-set (field value)
 398   "Set the `value' attribute of FIELD to VALUE."
 399   (aset field 1 value))
 400
 401 (defun custom-field-original-set (field original)
 402   "Set the `original' attribute of FIELD to ORIGINAL."
 403   (aset field 2 original))
 404
 405 (defun custom-field-move (field start end)
 406   "Set the `start'and `end' attributes of FIELD to START and END."
 407   (set-marker (or (aref field 3) (aset field 3 (make-marker))) start)
 408   (set-marker (or (aref field 4) (aset field 4 (make-marker))) end))
 409
 410 (defun custom-field-query (field)
 411   "Query user for content of current field."
 412   (funcall (custom-property (custom-field-custom field) 'query) field))
 413
 414 (defun custom-field-accept (field value &optional original)
 415   "Accept FIELD VALUE.
 416 If optional ORIGINAL is non-nil, concider VALUE for the original value."
 417   (funcall (custom-property (custom-field-custom field) 'accept)
 418            field value original))
 419
 420 ;;; Types:
 421 ;;
 422 ;; The following functions defines type specific actions.
 423
 424 (defun custom-repeat-accept (field value &optional original)
 425   "Enter content of editing FIELD."
 426   (let ((values (copy-sequence (custom-field-value field)))
 427         (all (custom-field-value field))
 428         (start (custom-field-start field))
 429         current new)
 430     (if original
 431         (custom-field-original-set field value))
 432     (while (consp value)
 433       (setq new (car value)
 434             value (cdr value))
 435       (if values
 436           ;; Change existing field.
 437           (setq current (car values)
 438                 values (cdr values))
 439         ;; Insert new field if series has grown.
 440         (goto-char start)
 441         (setq current (custom-repeat-insert-entry field))
 442         (setq all (custom-insert-before all nil current))
 443         (custom-field-value-set field all))
 444       (custom-field-accept current new original))
 445     (while (consp values)
 446       ;; Delete old field if series has scrunk.
 447       (setq current (car values)
 448             values (cdr values))
 449       (let ((pos (custom-field-start current))
 450             data)
 451         (while (not data)
 452           (setq pos (previous-single-property-change pos 'custom-data))
 453           (custom-assert 'pos)
 454           (setq data (get-text-property pos 'custom-data))
 455           (or (and (arrayp data)
 456                    (> (length data) 1)
 457                    (eq current (aref data 1)))
 458               (setq data nil)))
 459         (custom-repeat-delete data)))))
 460
 461 (defun custom-repeat-insert (custom level)
 462   "Insert field for CUSTOM at nesting LEVEL in customization buffer."
 463   (let* ((field (custom-field-create custom nil))
 464          (add-tag (custom-property custom 'add-tag))
 465          (del-tag (custom-property custom 'del-tag))
 466          (start (make-marker))
 467          (data (vector field nil start nil)))
 468     (custom-text-insert "\n")
 469     (let ((pos (point)))
 470       (custom-tag-insert add-tag 'custom-repeat-add data)
 471       (set-marker start pos))
 472     (custom-field-move field start (point))
 473     (custom-documentation-insert custom)
 474     field))
 475
 476 (defun custom-repeat-insert-entry (repeat)
 477   "Insert entry at point in the REPEAT field."
 478   (let* ((inhibit-point-motion-hooks t)
 479          (inhibit-read-only t)
 480          (before-change-function nil)
 481          (after-change-function nil)
 482          (custom (custom-field-custom repeat))
 483          (add-tag (custom-property custom 'add-tag))
 484          (del-tag (custom-property custom 'del-tag))
 485          (start (make-marker))
 486          (end (make-marker))
 487          (data (vector repeat nil start end))
 488          field)
 489     (insert-before-markers "\n")
 490     (backward-char 1)
 491     (set-marker start (point))
 492     (custom-text-insert " ")
 493     (aset data 1 (setq field (custom-insert (custom-data custom) nil)))
 494     (custom-text-insert " ")
 495     (set-marker end (point))
 496     (goto-char start)
 497     (custom-tag-insert add-tag 'custom-repeat-add data)
 498     (custom-text-insert " ")
 499     (custom-tag-insert del-tag 'custom-repeat-delete data)
 500     (forward-char 1)
 501     field))
 502
 503 (defun custom-repeat-add (data)
 504   "Add list entry."
 505   (let ((parent (aref data 0))
 506         (field (aref data 1))
 507         (at (aref data 2))
 508         new)
 509     (goto-char at)
 510     (setq new (custom-repeat-insert-entry parent))
 511     (custom-field-value-set parent
 512                             (custom-insert-before (custom-field-value parent)
 513                                                   field new))))
 514
 515 (defun custom-repeat-delete (data)
 516   "Delete list entry."
 517   (let ((inhibit-point-motion-hooks t)
 518         (inhibit-read-only t)
 519         (before-change-function nil)
 520         (after-change-function nil)
 521         (parent (aref data 0))
 522         (field (aref data 1)))
 523     (delete-region (aref data 2) (1+ (aref data 3)))
 524     (custom-field-untouch (aref data 1))
 525     (custom-field-value-set parent
 526                             (delq field (custom-field-value parent)))))
 527
 528 (defun custom-repeat-match (custom values)
 529   "Match CUSTOM with VALUES."
 530   (let* ((child (custom-data custom))
 531          (match (custom-match child values))
 532          matches)
 533     (while (not (eq (car match) custom-nil))
 534       (setq matches (cons (car match) matches)
 535             values (cdr match)
 536             match (custom-match child values)))
 537     (cons (nreverse matches) values)))
 538
 539 (defun custom-repeat-extract (custom field)
 540   "Extract list of childrens values."
 541   (let ((values (custom-field-value field))
 542         (data (custom-data custom))
 543         result)
 544     (if (eq values custom-nil)
 545         ()
 546       (while values
 547 ;;      (message "Before values = %S result = %S" values result)
 548         (setq result (append result (custom-field-extract data (car values)))
 549               values (cdr values))
 550 ;;      (message "After values = %S result = %S" values result)
 551         ))
 552     result))
 553
 554 (defun custom-repeat-validate (custom field)
 555   "Validate children."
 556   (let ((values (custom-field-value field))
 557         (data (custom-data custom))
 558         result)
 559     (if (eq values custom-nil)
 560         (setq result (cons (custom-field-start field) "Uninitialized list")))
 561     (while (and values (not result))
 562       (setq result (custom-field-validate data (car values))
 563             values (cdr values)))
 564     result))
 565
 566 (defun custom-list-accept (field value &optional original)
 567   "Enter content of editing FIELD with VALUE."
 568   (let ((values (custom-field-value field))
 569         current)
 570     (if original
 571         (custom-field-original-set field value))
 572     (while values
 573       (setq current (car values)
 574             values (cdr values))
 575       (if current
 576           (let* ((custom (custom-field-custom current))
 577                  (match (custom-match custom value)))
 578             (setq value (cdr match))
 579             (custom-field-accept current (car match) original))))))
 580
 581 (defun custom-list-extract (custom field)
 582   "Extract list of childrens values."
 583   (let ((values (custom-field-value field))
 584         (data (custom-data custom))
 585         result)
 586     (custom-assert '(eq (length values) (length data)))
 587     (while values
 588       (setq result (append result
 589                            (custom-field-extract (car data) (car values)))
 590             data (cdr data)
 591             values (cdr values)))
 592     (custom-assert '(null data))
 593     (list result)))
 594
 595 (defun custom-list-validate (custom field)
 596   "Validate children."
 597   (let ((values (custom-field-value field))
 598         (data (custom-data custom))
 599         result)
 600     (if (eq values custom-nil)
 601         (setq result (cons (custom-field-start field) "Uninitialized list"))
 602       (custom-assert '(eq (length values) (length data))))
 603     (while (and values (not result))
 604       (setq result (custom-field-validate (car data) (car values))
 605             data (cdr data)
 606             values (cdr values)))
 607     result))
 608
 609 (defun custom-group-accept (field value &optional original)
 610   "Enter content of editing FIELD with VALUE."
 611   (let ((values (custom-field-value field))
 612         value original)
 613     (if original
 614         (custom-field-original-set field value))
 615     (while values
 616       (setq current (car values)
 617             values (cdr values))
 618       (if (consp originals)
 619           (setq new (car value)
 620                 value (cdr value))
 621         (setq original custom-nil))
 622       (if (null current)
 623           ()
 624         (custom-field-accept current new original)))))
 625
 626 (defun custom-group-insert (custom level)
 627   "Insert field for CUSTOM at nesting LEVEL in customization buffer."
 628   (let* ((field (custom-field-create custom nil))
 629          fields
 630          (from (point))
 631          (compact (custom-compact custom))
 632          (tag (custom-tag custom)))
 633     (if tag (custom-tag-insert tag field))
 634     (or compact (custom-documentation-insert custom))
 635     (or compact (custom-text-insert "\n"))
 636     (let ((data (custom-data custom)))
 637       (while data
 638         (setq fields (cons (custom-insert (car data) (if level (1+ level)))
 639                            fields))
 640         (setq data (cdr data))
 641         (if data (custom-text-insert (if compact " " "\n")))))
 642     (if compact (custom-documentation-insert custom))
 643     (custom-field-value-set field (nreverse fields))
 644     (custom-field-move field from (point))
 645     field))
 646
 647 (defun custom-choice-insert (custom level)
 648   "Insert field for CUSTOM at nesting LEVEL in customization buffer."
 649   (let* ((field (custom-field-create custom nil))
 650          (from (point))
 651          (tag (custom-tag custom)))
 652     (custom-text-insert "lars er en nisse")
 653     (custom-field-move field from (point))
 654     (custom-documentation-insert custom)
 655     (custom-field-reset field)
 656     field))
 657
 658 (defun custom-choice-accept (field value &optional original)
 659   "Reset content of editing FIELD."
 660   (let ((custom (custom-field-custom field))
 661         (start (custom-field-start field))
 662         (end (custom-field-end field))
 663         (inhibit-read-only t)
 664         (before-change-function nil)
 665         (after-change-function nil)
 666         from)
 667     (cond (original
 668            (setq custom-modified-list (delq field custom-modified-list))
 669            (custom-field-original-set field value))
 670           ((equal value (custom-field-original field))
 671            (setq custom-modified-list (delq field custom-modified-list)))
 672           (t
 673            (add-to-list 'custom-modified-list field)))
 674     (custom-field-untouch (custom-field-value field))
 675     (delete-region start end)
 676     (goto-char start)
 677     (setq from (point))
 678     (insert-before-markers " ")
 679     (backward-char 1)
 680     (set-text-properties (point) (1+ (point))
 681                          (list 'invisible t
 682                                intangible t))
 683     (custom-tag-insert (custom-tag custom) field)
 684     (custom-text-insert ": ")
 685     (let ((data (custom-data custom))
 686           found begin)
 687       (while (and data (not found))
 688         (if (not (custom-valid (car data) value))
 689             (setq data (cdr data))
 690           (setq found (custom-insert (car data) nil))
 691           (setq data nil)))
 692       (if found
 693           ()
 694         (setq begin (point)
 695               found (custom-insert (custom-property custom 'none) nil))
 696         (add-text-properties begin (point)
 697                              (list 'rear-nonsticky t
 698                                    'face custom-field-uninitialized-face)))
 699       (custom-field-accept found value original)
 700       (custom-field-value-set field found)
 701       (custom-field-move field from end))))
 702
 703 (defun custom-choice-extract (custom field)
 704   "Extract childs value."
 705   (let ((value (custom-field-value field)))
 706     (custom-field-extract (custom-field-custom value) value)))
 707
 708 (defun custom-choice-validate (custom field)
 709   "Validate childs value."
 710   (let ((value (custom-field-value field))
 711         (custom (custom-field-custom field)))
 712     (if (or (eq value custom-nil)
 713             (eq (custom-field-custom value) (custom-property custom 'none)))
 714         (cons (custom-field-start field) "Make a choice")
 715       (custom-field-validate (custom-field-custom value) value))))
 716
 717 (defun custom-choice-query (field)
 718   "Choose a child."
 719   (let* ((custom (custom-field-custom field))
 720          (default (custom-tag-or-type
 721                    (custom-field-custom (custom-field-value field))))
 722          (tag (custom-tag-or-type custom))
 723          (data (custom-data custom))
 724          current alist)
 725     (while data
 726       (setq current (car data)
 727             data (cdr data))
 728       (setq alist (cons (cons (custom-tag-or-type current) current) alist)))
 729     (let ((answer (if (listp last-input-event)
 730                       (x-popup-menu last-input-event
 731                                     (list tag (cons "" (reverse alist))))
 732                     (let ((choice (completing-read (concat tag " (default "
 733                                                            default "): ")
 734                                                    alist nil t)))
 735                       (if (or (null choice) (string-equal choice ""))
 736                           (setq choice default))
 737                       (cdr (assoc choice alist))))))
 738       (if answer
 739           (custom-field-accept field (custom-default answer))))))
 740
 741 (defun custom-file-query (field)
 742   "Prompt for a file name"
 743   (let* ((value (custom-field-value field))
 744          (custom (custom-field-custom field))
 745          (valid (custom-valid custom value))
 746          (directory (custom-property custom 'directory))
 747          (default (and (not valid)
 748                        (custom-property custom 'default-file)))
 749          (tag (custom-tag custom))
 750          (prompt (if default
 751                      (concat tag " (" default "): ")
 752                    (concat tag ": "))))
 753     (custom-field-accept field
 754                          (if (custom-valid custom value)
 755                              (read-file-name prompt
 756                                              (if (file-name-absolute-p value)
 757                                                  ""
 758                                                directory)
 759                                              default nil value)
 760                            (read-file-name prompt directory default)))))
 761
 762 (defun custom-const-insert (custom level)
 763   "Insert field for CUSTOM at nesting LEVEL in customization buffer."
 764   (let ((field (custom-field-create custom custom-nil))
 765         (from (point)))
 766     (custom-text-insert (custom-tag custom))
 767     (custom-documentation-insert custom)
 768     (custom-field-move field from (point))
 769     field))
 770
 771 (defun custom-const-valid (custom value)
 772   "Non-nil if CUSTOM can legally have the value VALUE."
 773   (equal (custom-default custom) value))
 774
 775 (defun custom-integer-read (custom integer)
 776   "Read from CUSTOM an INTEGER."
 777   (string-to-int (save-match-data
 778                    (custom-strip-padding integer (custom-padding custom)))))
 779
 780 (defun custom-integer-write (custom integer)
 781   "Write CUSTOM INTEGER as string."
 782   (int-to-string integer))
 783
 784 (defun custom-string-read (custom string)
 785   "Read string by ignoring trailing padding characters."
 786   (let ((last (length string))
 787         (padding (custom-padding custom)))
 788     (while (and (> last 0)
 789                 (eq (aref string (1- last)) padding))
 790       (setq last (1- last)))
 791     (substring string 0 last)))
 792
 793 (defun custom-string-write (custom string)
 794   "Write raw string."
 795   string)
 796
 797 (defun custom-button-insert (custom level)
 798   "Insert field for CUSTOM at nesting LEVEL in customization buffer."
 799   (custom-tag-insert (concat "[" (custom-tag custom) "]")
 800                      (custom-property custom 'query))
 801   (custom-documentation-insert custom)
 802   nil)
 803
 804 (defun custom-default-insert (custom level)
 805   "Insert field for CUSTOM at nesting LEVEL in customization buffer."
 806   (let ((field (custom-field-create custom custom-nil))
 807         (tag (custom-tag custom)))
 808     (if (null tag)
 809         ()
 810       (custom-tag-insert tag field)
 811       (custom-text-insert ": "))
 812     (custom-field-insert field)
 813     (custom-documentation-insert custom)
 814     field))
 815
 816 (defun custom-default-accept (field value &optional original)
 817   "Enter into FIELD the value VALUE."
 818   (if original
 819       (custom-field-original-set field value))
 820   (custom-field-value-set field value)
 821   (custom-field-update field))
 822
 823 (defun custom-default-reset (field)
 824   "Reset content of editing FIELD."
 825   (custom-field-accept field (custom-field-original field) t))
 826
 827 (defun custom-default-query (field)
 828   "Prompt for a FIELD"
 829   (let* ((custom (custom-field-custom field))
 830          (value (custom-field-value field))
 831          (initial (custom-write custom value))
 832          (prompt (concat (custom-tag-or-type custom) ": ")))
 833     (custom-field-accept field
 834                          (custom-read custom
 835                                       (if (custom-valid custom value)
 836                                           (read-string prompt (cons initial 1))
 837                                         (read-string prompt))))))
 838
 839 (defun custom-default-match (custom values)
 840   "Match CUSTOM with VALUES."
 841   values)
 842
 843 (defun custom-default-extract (custom field)
 844   "Extract CUSTOM's content in FIELD."
 845   (list (custom-field-value field)))
 846
 847 (defun custom-default-validate (custom field)
 848   "Validate FIELD."
 849   (let ((value (custom-field-value field))
 850         (start (custom-field-start field)))
 851     (cond ((eq value custom-nil)
 852            (cons (custom-field-start field) "Uninitialized field"))
 853           ((custom-valid custom value)
 854            nil)
 855           (t
 856            (const start "Wrong type")))))
 857
 858 ;;; Create Buffer:
 859 ;;
 860 ;; Public functions to create a customization buffer and to insert
 861 ;; various forms of text, fields, and buttons in it.
 862
 863 (defun custom-buffer-create (name &optional custom types set get)
 864   "Create a customization buffer named NAME.
 865 If the optional argument CUSTOM is non-nil, use that as the custom declaration.
 866 If the optional argument TYPES is non-nil, use that as the local types.
 867 If the optional argument SET is non-nil, use that to set external data.
 868 If the optional argument GET is non-nil, use that to get external data."
 869   (switch-to-buffer name)
 870   (buffer-disable-undo)
 871   (custom-mode)
 872   (setq custom-local-type-properties types)
 873   (if (null custom)
 874       ()
 875     (make-local-variable 'custom-data)
 876     (setq custom-data custom))
 877   (if (null set)
 878       ()
 879     (make-local-variable 'custom-external-set)
 880     (setq custom-external-set set))
 881   (if (null get)
 882       ()
 883     (make-local-variable 'custom-external)
 884     (setq custom-external get))
 885   (let ((inhibit-point-motion-hooks t)
 886         (before-change-function nil)
 887         (after-change-function nil))
 888     (erase-buffer)
 889     (insert "\n")
 890     (goto-char (point-min))
 891     (custom-text-insert "This is a customization buffer.\n")
 892     (custom-help-insert "\n")
 893     (custom-help-button 'custom-forward-field)
 894     (custom-help-button 'custom-enter-value)
 895     (custom-help-button 'custom-field-reset)
 896     (custom-help-button 'custom-field-apply)
 897     (custom-help-button 'custom-toggle-documentation)
 898     (custom-help-insert "\nClick mouse-2 on any button to activate it.\n")
 899     (custom-insert custom 1)
 900     (goto-char (point-min))))
 901
 902 (defun custom-insert (custom level)
 903   "Insert custom declaration CUSTOM in current buffer at level LEVEL."
 904   (if (stringp custom)
 905       (progn
 906         (custom-text-insert custom)
 907         nil)
 908     (and level (null (custom-property custom 'header))
 909          (setq level nil))
 910     (if level
 911         (custom-text-insert (concat "\n" (make-string level ?*) " ")))
 912     (let ((field (funcall (custom-property custom 'insert) custom level)))
 913       (custom-name-enter (custom-name custom) field)
 914       field)))
 915
 916 (defun custom-text-insert (text)
 917   "Insert TEXT in current buffer."
 918   (insert text))
 919
 920 (defun custom-tag-insert (tag field &optional data)
 921   "Insert TAG for FIELD in current buffer."
 922   (let ((from (point)))
 923     (insert tag)
 924     (set-text-properties from (point)
 925                          (list 'category custom-button-properties
 926                                'custom-tag field))
 927     (if data
 928         (add-text-properties from (point) (list 'custom-data data)))))
 929
 930 (defun custom-documentation-insert (custom &rest ignore)
 931   "Insert documentation from CUSTOM in current buffer."
 932   (let ((doc (custom-documentation custom)))
 933     (if (null doc)
 934         ()
 935       (custom-help-insert "\n" doc))))
 936
 937 (defun custom-help-insert (&rest args)
 938   "Insert ARGS as documentation text."
 939   (let ((from (point)))
 940     (apply 'insert args)
 941     (set-text-properties from (point)
 942                          (list 'category custom-documentation-properties))))
 943
 944 (defun custom-help-button (command)
 945   "Describe how to execute COMMAND."
 946   (let ((from (point)))
 947     (insert "`" (key-description (where-is-internal command nil t)) "'")
 948     (set-text-properties from (point)
 949                          (list 'category custom-documentation-properties
 950                                'face custom-button-face
 951                                'mouse-face custom-mouse-face
 952                                'custom-tag command)))
 953   (custom-help-insert ": " (custom-first-line (documentation command)) "\n"))
 954
 955 ;;; Mode:
 956 ;;
 957 ;; The Customization major mode and interactive commands.
 958
 959 (defvar custom-mode-map nil
 960   "Keymap for Custum Mode.")
 961 (if custom-mode-map
 962     nil
 963   (setq custom-mode-map (make-sparse-keymap))
 964   (define-key custom-mode-map [ mouse-2 ] 'custom-push-button)
 965   (define-key custom-mode-map "\t" 'custom-forward-field)
 966   (define-key custom-mode-map "\r" 'custom-enter-value)
 967   (define-key custom-mode-map "\C-k" 'custom-kill-line)
 968   (define-key custom-mode-map "\C-c\C-r" 'custom-field-reset)
 969   (define-key custom-mode-map "\C-c\M-\C-r" 'custom-reset-all)
 970   (define-key custom-mode-map "\C-c\C-a" 'custom-field-apply)
 971   (define-key custom-mode-map "\C-c\M-\C-a" 'custom-apply-all)
 972   (define-key custom-mode-map "\C-c\C-d" 'custom-toggle-documentation))
 973
 974 ;; C-c keymap ideas: C-a field-beginning, C-e field-end, C-f
 975 ;; forward-field, C-b backward-field, C-n next-field, C-p
 976 ;; previous-field, ? describe-field.
 977
 978 (defun custom-mode ()
 979   "Major mode for doing customizations.
 980
 981 \\{custom-mode-map}"
 982   (kill-all-local-variables)
 983   (setq major-mode 'custom-mode
 984         mode-name "Custom")
 985   (use-local-map custom-mode-map)
 986   (make-local-variable 'before-change-function)
 987   (setq before-change-function 'custom-before-change)
 988   (make-local-variable 'after-change-function)
 989   (setq after-change-function 'custom-after-change)
 990   (if (not (fboundp 'make-local-hook))
 991       ;; Emacs 19.28 and earlier.
 992       (add-hook 'post-command-hook 'custom-post-command nil)
 993     ;; Emacs 19.29.
 994     (make-local-hook 'post-command-hook)
 995     (add-hook 'post-command-hook 'custom-post-command nil t)))
 996
 997 (defun custom-forward-field (arg)
 998   "Move point to the next field or button.
 999 With optional ARG, move across that many fields."
1000   (interactive "p")
1001   (while (> arg 0)
1002     (setq arg (1- arg))
1003     (let ((next (if (get-text-property (point) 'custom-tag)
1004                     (next-single-property-change (point) 'custom-tag)
1005                   (point))))
1006       (setq next (or (next-single-property-change next 'custom-tag)
1007                      (next-single-property-change (point-min) 'custom-tag)))
1008       (if next
1009           (goto-char next)
1010         (error "No customization fields in this buffer.")))))
1011
1012 (defun custom-toggle-documentation (&optional arg)
1013   "Toggle display of documentation text.
1014 If the optional argument is non-nil, show text iff the argument is positive."
1015   (interactive "P")
1016   (let ((hide (or (and (null arg)
1017                        (null (get custom-documentation-properties 'invisible)))
1018                   (<= (prefix-numeric-value arg) 0))))
1019     (put custom-documentation-properties 'invisible hide)
1020     (put custom-documentation-properties intangible hide))
1021   (redraw-display))
1022
1023 (defun custom-enter-value (field data)
1024   "Enter value for current customization field or push button."
1025   (interactive (list (get-text-property (point) 'custom-tag)
1026                      (get-text-property (point) 'custom-data)))
1027   (cond (data
1028          (funcall field data))
1029         ((eq field 'custom-enter-value)
1030          (error "Don't be silly"))
1031         ((and (symbolp field) (fboundp field))
1032          (call-interactively field))
1033         (field
1034          (custom-field-query field))
1035         (t
1036          (message "Nothing to enter here"))))
1037
1038 (defun custom-kill-line ()
1039   "Kill to end of field or end of line, whichever is first."
1040   (interactive)
1041   (let ((field (get-text-property (point) 'custom-field))
1042         (newline (save-excursion (search-forward "\n")))
1043         (next (next-single-property-change (point) 'custom-field)))
1044     (if (and field (> newline next))
1045         (kill-region (point) next)
1046       (call-interactively 'kill-line))))
1047
1048 (defun custom-push-button (event)
1049   "Activate button below mouse pointer."
1050   (interactive "e")
1051   (set-buffer (window-buffer (posn-window (event-start event))))
1052   (let* ((pos (posn-point (event-start event)))
1053          (field (get-text-property pos 'custom-field))
1054          (tag (get-text-property pos 'custom-tag))
1055          (data (get-text-property pos 'custom-data)))
1056     (cond (data
1057             (funcall tag data))
1058           ((and (symbolp tag) (fboundp tag))
1059            (call-interactively tag))
1060           (field
1061            (call-interactively (lookup-key global-map (this-command-keys))))
1062           (tag
1063            (custom-enter-value tag data))
1064           (t
1065            (error "Nothing to click on here.")))))
1066
1067 (defun custom-reset-all ()
1068   "Undo any changes since the last apply in all fields."
1069   (interactive (and custom-modified-list
1070                     (not (y-or-n-p "Discard all changes? "))
1071                     (error "Reset aborted")))
1072   (let ((all custom-name-fields)
1073         current name field)
1074     (while all
1075       (setq current (car all)
1076             name (car current)
1077             field (cdr current)
1078             all (cdr all))
1079       (custom-field-reset field))))
1080
1081 (defun custom-field-reset (field)
1082   "Undo any changes in FIELD since the last apply."
1083   (interactive (list (or (get-text-property (point) 'custom-field)
1084                          (get-text-property (point) 'custom-tag))))
1085   (if (not (arrayp field))
1086       (error "No field to reset here"))
1087   (let* ((custom (custom-field-custom field))
1088          (name (custom-name custom)))
1089     (save-excursion
1090       (if name
1091           (custom-field-original-set field (custom-external name)))
1092       (funcall (custom-property custom 'reset) field))))
1093
1094 (defun custom-apply-all ()
1095   "Apply any changes since the last reset in all fields."
1096   (interactive (or custom-modified-list
1097                    (error "No changes to apply.")))
1098   (let ((all custom-name-fields)
1099         name field)
1100     (while all
1101       (setq field (cdr (car all))
1102             all (cdr all))
1103       (let ((error (custom-field-validate (custom-field-custom field) field)))
1104         (if (null error)
1105             ()
1106           (goto-char (car error))
1107           (error (cdr error))))))
1108   (let ((all custom-name-fields)
1109         current name field)
1110     (while all
1111       (setq field (cdr (car all))
1112             all (cdr all))
1113       (custom-field-apply field))))
1114
1115 (defun custom-field-apply (field)
1116   "Apply any changes in FIELD since the last apply."
1117   (interactive (list (or (get-text-property (point) 'custom-field)
1118                          (get-text-property (point) 'custom-tag))))
1119   (if (not (arrayp field))
1120       (error "No field to reset here"))
1121   (let* ((custom (custom-field-custom field))
1122          (name (custom-name custom))
1123          (error (custom-field-validate custom field)))
1124     (cond ((null name)
1125            (error "This field cannot be applied alone"))
1126           (error
1127            (error (cdr error)))
1128           (t
1129            (custom-external-set name (car (custom-field-extract custom field)))
1130            (custom-field-reset field)))))
1131
1132 (defun custom-toggle-hide (&rest ignore)
1133   "Hide or show entry."
1134   (interactive)
1135   (error "This button is not yet implemented"))
1136
1137 ;;; Field Editing:
1138 ;;
1139 ;; Various internal functions for implementing the direct editing of
1140 ;; fields in the customization buffer.
1141
1142 (defvar custom-modified-list nil)
1143 ;; List of modified fields.
1144 (make-variable-buffer-local 'custom-modified-list)
1145
1146 (defun custom-field-untouch (field)
1147   ;; Remove FIELD and its children from `custom-modified-list'.
1148   (setq custom-modified-list (delq field custom-modified-list))
1149   (if (arrayp field)
1150       (let ((value (custom-field-value field)))
1151         (cond ((arrayp value)
1152                (custom-field-untouch value))
1153               ((listp value)
1154                (mapcar 'custom-field-untouch value))))))
1155
1156
1157 (defun custom-field-insert (field)
1158   ;; Insert editing FIELD in current buffer.
1159   (let ((from (point))
1160         (custom (custom-field-custom field))
1161         (value (custom-field-value field)))
1162     (insert (custom-write custom value))
1163     (insert-char (custom-padding custom)
1164                  (- (custom-width custom) (- (point) from)))
1165     (custom-field-move field from (point))
1166     (set-text-properties
1167      from (point)
1168      (list 'custom-field field
1169            'custom-tag field
1170            'face (custom-field-face field)
1171            'front-sticky t))))
1172
1173 (defun custom-field-update (field)
1174   ;; Update the content of FIELD.
1175   (let ((inhibit-point-motion-hooks t)
1176         (before-change-function nil)
1177         (after-change-function nil)
1178         (start (custom-field-start field))
1179         (end (custom-field-end field))
1180         (pos (point)))
1181     ;; Keep track of how many modified fields we have.
1182     (cond ((equal (custom-field-value field) (custom-field-original field))
1183            (setq custom-modified-list (delq field custom-modified-list)))
1184           ((memq field custom-modified-list))
1185           (t
1186            (setq custom-modified-list (cons field custom-modified-list))))
1187     ;; Update the field.
1188     (goto-char end)
1189     (insert-before-markers " ")
1190     (delete-region start (1- end))
1191     (goto-char start)
1192     (custom-field-insert field)
1193     (goto-char end)
1194     (delete-char 1)
1195     (goto-char pos)
1196     (and (<= start pos)
1197          (<= pos end)
1198          (custom-field-enter field))))
1199
1200 (defun custom-field-read (field)
1201   ;; Read the screen content of FIELD.
1202   (custom-read (custom-field-custom field)
1203                (buffer-substring-no-properties (custom-field-start field)
1204                                                (custom-field-end field))))
1205
1206 (defun custom-field-face (field)
1207   ;; Face used for an inactive field FIELD.
1208   (let ((value (custom-field-value field)))
1209     (cond ((eq value custom-nil)
1210            custom-field-uninitialized-face)
1211           ((not (custom-valid (custom-field-custom field) value))
1212            custom-field-invalid-face)
1213           ((not (equal (custom-field-original field) value))
1214            custom-field-modified-face)
1215           (t
1216            custom-field-face))))
1217
1218 (defun custom-field-leave (field)
1219   ;; Deactivate FIELD.
1220   (let ((before-change-function nil)
1221         (after-change-function nil))
1222     (put-text-property (custom-field-start field) (custom-field-end field)
1223                        'face (custom-field-face field))))
1224
1225 (defun custom-field-enter (field)
1226   ;; Activate FIELD.
1227   (let* ((start (custom-field-start field))
1228          (end (custom-field-end field))
1229          (custom (custom-field-custom field))
1230          (padding (custom-padding custom))
1231          (allow (custom-allow-padding custom))
1232          (before-change-function nil)
1233          (after-change-function nil))
1234     (or (and (eq this-command 'self-insert-command)
1235              allow)
1236         (let ((pos end))
1237           (while (and (< start pos)
1238                       (eq (char-after (1- pos)) padding))
1239             (setq pos (1- pos)))
1240           (if (< pos (point))
1241               (goto-char pos))))
1242     (put-text-property start end 'face custom-field-active-face)))
1243
1244 (defvar custom-field-last nil)
1245 ;; Last field containing point.
1246 (make-variable-buffer-local 'custom-field-last)
1247
1248 (defun custom-post-command ()
1249   ;; Keep track of their active field.
1250   (if (not (eq major-mode 'custom-mode))
1251       ;; BUG: Should have been local!
1252       ()
1253     (let ((field (custom-field-property (point))))
1254       (if (eq field custom-field-last)
1255           ()
1256         (if custom-field-last
1257             (custom-field-leave custom-field-last))
1258         (if field
1259             (custom-field-enter field))
1260         (setq custom-field-last field)))
1261     (set-buffer-modified-p custom-modified-list)))
1262
1263 (defvar custom-field-was nil)
1264 ;; The custom data before the change.
1265 (make-variable-buffer-local 'custom-field-was)
1266
1267 (defun custom-before-change (begin end)
1268   ;; Check that we the modification is allowed.
1269   (if (not (eq major-mode 'custom-mode))
1270       (message "Aargh! Why is custom-before-change called here?")
1271     (let ((from (custom-field-property begin))
1272           (to (custom-field-property end)))
1273       (cond ((or (null from) (null to))
1274              (error "You can only modify the fields"))
1275             ((not (eq from to))
1276              (error "Changes must be limited to a single field."))
1277             (t
1278              (setq custom-field-was from))))))
1279
1280 (defun custom-after-change (begin end length)
1281   ;; Keep track of field content.
1282   (if (not (eq major-mode 'custom-mode))
1283       (message "Aargh! Why is custom-after-change called here?")
1284     (let ((field custom-field-was))
1285       (custom-assert '(prog1 field (setq custom-field-was nil)))
1286       ;; Prevent mixing fields properties.
1287       (put-text-property begin end 'custom-field field)
1288       ;; Update the field after modification.
1289       (if (eq (custom-field-property begin) field)
1290           (let ((field-end (custom-field-end field)))
1291             (if (> end field-end)
1292                 (set-marker field-end end))
1293             (custom-field-value-set field (custom-field-read field))
1294             (custom-field-update field))
1295         ;; We deleted the entire field, reinsert it.
1296         (custom-assert '(eq begin end))
1297         (save-excursion
1298           (goto-char begin)
1299           (custom-field-value-set field
1300                                   (custom-read (custom-field-custom field) ""))
1301           (custom-field-insert field))))))
1302
1303 (defun custom-field-property (pos)
1304   ;; The `custom-field' text property valid for POS.
1305   (or (get-text-property pos 'custom-field)
1306       (and (not (eq pos (point-min)))
1307            (get-text-property (1- pos) 'custom-field))))
1308
1309 ;;; Generic Utilities:
1310 ;;
1311 ;; Some utility functions that are not really specific to custom.
1312
1313 (defun custom-assert (expr)
1314   "Assert that EXPR evaluates to non-nil at this point"
1315   (or (eval expr)
1316       (error "Assertion failed: %S" expr)))
1317
1318 (defun custom-first-line (string)
1319   "Return the part of STRING before the first newline."
1320   (let ((pos 0)
1321         (len (length string)))
1322     (while (and (< pos len) (not (eq (aref string pos) ?\n)))
1323       (setq pos (1+ pos)))
1324     (if (eq pos len)
1325         string
1326     (substring string 0 pos))))
1327
1328 (defun custom-insert-before (list old new)
1329   "In LIST insert before OLD a NEW element."
1330   (cond ((null list)
1331          (list new))
1332         ((null old)
1333          (nconc list (list new)))
1334         ((eq old (car list))
1335          (cons new list))
1336         (t
1337          (let ((list list))
1338            (while (not (eq old (car (cdr list))))
1339              (setq list (cdr list))
1340              (custom-assert '(cdr list)))
1341            (setcdr list (cons new (cdr list))))
1342          list)))
1343
1344 (defun custom-strip-padding (string padding)
1345   "Remove padding from STRING."
1346   (let ((regexp (concat (regexp-quote (char-to-string padding)) "+")))
1347     (while (string-match regexp string)
1348       (setq string (concat (substring string 0 (match-beginning 0))
1349                            (substring string (match-end 0))))))
1350   string)
1351
1352 (provide 'custom)
1353
1354 ;;; custom.el ends here