428
+ − 1 ;;; cus-edit.el --- Tools for customizating Emacs and Lisp packages.
+ − 2 ;;
4178
+ − 3 ;; Copyright (C) 2007 Didier Verna
+ − 4 ;; Copyright (C) 2003 Ben Wing
438
+ − 5 ;; Copyright (C) 1996, 1997, 2000 Free Software Foundation, Inc.
428
+ − 6 ;;
+ − 7 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
4178
+ − 8 ;; Maintainer: Didier Verna <didier@xemacs.org>
428
+ − 9 ;; Keywords: help, faces
+ − 10 ;; Version: 1.9960-x
+ − 11 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
+ − 12
+ − 13 ;; This file is part of XEmacs.
+ − 14
+ − 15 ;; XEmacs is free software; you can redistribute it and/or modify
+ − 16 ;; it under the terms of the GNU General Public License as published by
+ − 17 ;; the Free Software Foundation; either version 2, or (at your option)
+ − 18 ;; any later version.
+ − 19
+ − 20 ;; XEmacs is distributed in the hope that it will be useful,
+ − 21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ − 22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ − 23 ;; GNU General Public License for more details.
+ − 24
+ − 25 ;; You should have received a copy of the GNU General Public License
+ − 26 ;; along with XEmacs; see the file COPYING. If not, write to the
+ − 27 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ − 28 ;; Boston, MA 02111-1307, USA.
+ − 29
+ − 30 ;;; Commentary:
+ − 31 ;;
+ − 32 ;; This file implements the code to create and edit customize buffers.
+ − 33 ;;
+ − 34 ;; See `custom.el'.
+ − 35
+ − 36 ;; No commands should have names starting with `custom-' because
+ − 37 ;; that interferes with completion. Use `customize-' for commands
+ − 38 ;; that the user will run with M-x, and `Custom-' for interactive commands.
+ − 39
+ − 40 ;; NOTE: In many places within this file we use `mapatoms', which is
+ − 41 ;; very slow in an average XEmacs because of the large number of
+ − 42 ;; symbols requiring a large number of funcalls -- XEmacs with Gnus
+ − 43 ;; can grow to some 17000 symbols without ever doing anything fancy.
+ − 44 ;; It would probably pay off to make a hash table of symbols known to
+ − 45 ;; Custom, similar to custom-group-hash-table.
+ − 46
+ − 47 ;; This is not top priority, because none of the functions that do
+ − 48 ;; mapatoms are speed-critical (the one that was now uses
+ − 49 ;; custom-group-hash-table), but it would be nice to have.
+ − 50
+ − 51
+ − 52 ;;; Code:
+ − 53
+ − 54 (require 'cus-face)
+ − 55 (require 'wid-edit)
+ − 56 (require 'easymenu)
+ − 57
+ − 58 (require 'cus-load)
+ − 59 (require 'cus-start)
442
+ − 60 (require 'cus-file)
428
+ − 61
+ − 62 ;; Huh? This looks dirty!
+ − 63 (put 'custom-define-hook 'custom-type 'hook)
+ − 64 (put 'custom-define-hook 'standard-value '(nil))
+ − 65 (custom-add-to-group 'customize 'custom-define-hook 'custom-variable)
+ − 66
+ − 67 ;;; Customization Groups.
+ − 68
+ − 69 (defgroup emacs nil
+ − 70 "Customization of the One True Editor."
+ − 71 :link '(custom-manual "(XEmacs)Top"))
+ − 72
+ − 73 ;; Most of these groups are stolen from `finder.el',
+ − 74 (defgroup editing nil
+ − 75 "Basic text editing facilities."
+ − 76 :group 'emacs)
+ − 77
+ − 78 (defgroup matching nil
+ − 79 "Various sorts of searching and matching."
+ − 80 :group 'editing)
+ − 81
+ − 82 (defgroup emulations nil
+ − 83 "Emulations of other editors."
+ − 84 :group 'editing)
+ − 85
+ − 86 (defgroup outlines nil
+ − 87 "Support for hierarchical outlining."
+ − 88 :group 'editing)
+ − 89
+ − 90 (defgroup external nil
+ − 91 "Interfacing to external utilities."
+ − 92 :group 'emacs)
+ − 93
+ − 94 (defgroup bib nil
+ − 95 "Code related to the `bib' bibliography processor."
+ − 96 :tag "Bibliography"
+ − 97 :group 'external)
+ − 98
+ − 99 (defgroup programming nil
+ − 100 "Support for programming in other languages."
+ − 101 :group 'emacs)
+ − 102
+ − 103 (defgroup languages nil
+ − 104 "Specialized modes for editing programming languages."
+ − 105 :group 'programming)
+ − 106
+ − 107 ;; #### This should be in cc-vars.el
+ − 108 (defgroup c nil
+ − 109 "Support for the C language and related languages."
+ − 110 :group 'languages)
+ − 111
+ − 112 (defgroup tools nil
+ − 113 "Programming tools."
+ − 114 :group 'programming)
+ − 115
+ − 116 (defgroup oop nil
+ − 117 "Support for object-oriented programming."
+ − 118 :group 'programming)
+ − 119
+ − 120 (defgroup applications nil
+ − 121 "Applications written in Emacs."
+ − 122 :group 'emacs)
+ − 123
+ − 124 ;; #### This should be in calendar.el
+ − 125 (defgroup calendar nil
+ − 126 "Calendar and time management support."
+ − 127 :group 'applications)
+ − 128
+ − 129 (defgroup mail nil
+ − 130 "Modes for electronic-mail handling."
+ − 131 :group 'applications)
+ − 132
+ − 133 (defgroup news nil
+ − 134 "Support for netnews reading and posting."
+ − 135 :group 'applications)
+ − 136
+ − 137 (defgroup games nil
+ − 138 "Games, jokes and amusements."
+ − 139 :group 'applications)
+ − 140
+ − 141 (defgroup development nil
+ − 142 "Support for further development of Emacs."
+ − 143 :group 'emacs)
+ − 144
+ − 145 (defgroup docs nil
+ − 146 "Support for Emacs documentation."
+ − 147 :group 'development)
+ − 148
+ − 149 (defgroup extensions nil
+ − 150 "Emacs Lisp language extensions."
+ − 151 :group 'development)
+ − 152
+ − 153 (defgroup internal nil
+ − 154 "Code for Emacs internals, build process, defaults."
+ − 155 :group 'development)
+ − 156
+ − 157 (defgroup maint nil
+ − 158 "Maintenance aids for the Emacs development group."
+ − 159 :tag "Maintenance"
+ − 160 :group 'development)
+ − 161
+ − 162 (defgroup environment nil
+ − 163 "Fitting Emacs with its environment."
+ − 164 :group 'emacs)
+ − 165
+ − 166 (defgroup comm nil
+ − 167 "Communications, networking, remote access to files."
+ − 168 :tag "Communication"
+ − 169 :group 'environment)
+ − 170
+ − 171 (defgroup hardware nil
+ − 172 "Support for interfacing with exotic hardware."
+ − 173 :group 'environment)
+ − 174
+ − 175 (defgroup terminals nil
+ − 176 "Support for terminal types."
+ − 177 :group 'environment)
+ − 178
+ − 179 (defgroup unix nil
+ − 180 "Front-ends/assistants for, or emulators of, UNIX features."
+ − 181 :group 'environment)
+ − 182
+ − 183 (defgroup i18n nil
+ − 184 "Internationalization and alternate character-set support."
+ − 185 :group 'environment
+ − 186 :group 'editing)
+ − 187
+ − 188 (defgroup data nil
+ − 189 "Support editing files of data."
+ − 190 :group 'emacs)
+ − 191
+ − 192 (defgroup wp nil
+ − 193 "Word processing."
+ − 194 :group 'emacs)
+ − 195
+ − 196 (defgroup tex nil
+ − 197 "Code related to the TeX formatter."
+ − 198 :group 'wp)
+ − 199
+ − 200 (defgroup hypermedia nil
+ − 201 "Support for links between text or other media types."
+ − 202 :group 'emacs)
+ − 203
+ − 204 (defgroup local nil
+ − 205 "Code local to your site."
+ − 206 :group 'emacs)
+ − 207
+ − 208 (defgroup customize '((widgets custom-group))
+ − 209 "Customization of the Customization support."
+ − 210 :link '(custom-manual "(custom)Top")
+ − 211 :link '(url-link :tag "Development Page"
+ − 212 "http://www.dina.kvl.dk/~abraham/custom/")
+ − 213 :prefix "custom-"
+ − 214 :group 'help)
+ − 215
+ − 216 (defgroup custom-faces nil
+ − 217 "Faces used by customize."
+ − 218 :group 'customize
+ − 219 :group 'faces)
+ − 220
+ − 221 (defgroup custom-browse nil
+ − 222 "Control customize browser."
+ − 223 :prefix "custom-"
+ − 224 :group 'customize)
+ − 225
+ − 226 (defgroup custom-buffer nil
+ − 227 "Control customize buffers."
+ − 228 :prefix "custom-"
+ − 229 :group 'customize)
+ − 230
+ − 231 (defgroup custom-menu nil
+ − 232 "Control customize menus."
+ − 233 :prefix "custom-"
+ − 234 :group 'customize)
+ − 235
+ − 236 (defgroup alloc nil
613
+ − 237 "Storage allocation and gc for XEmacs Lisp interpreter."
428
+ − 238 :tag "Storage Allocation"
+ − 239 :group 'internal)
+ − 240
+ − 241 (defgroup undo nil
+ − 242 "Undoing changes in buffers."
+ − 243 :group 'editing)
+ − 244
+ − 245 (defgroup editing-basics nil
+ − 246 "Most basic editing facilities."
+ − 247 :group 'editing)
+ − 248
+ − 249 (defgroup display nil
+ − 250 "How characters are displayed in buffers."
+ − 251 :group 'environment)
+ − 252
+ − 253 (defgroup installation nil
+ − 254 "The Emacs installation."
+ − 255 :group 'environment)
+ − 256
+ − 257 (defgroup limits nil
+ − 258 "Internal Emacs limits."
+ − 259 :group 'internal)
+ − 260
+ − 261 (defgroup debug nil
+ − 262 "Debugging Emacs itself."
+ − 263 :group 'development)
+ − 264
+ − 265 (defgroup mule nil
+ − 266 "Mule XEmacs internationalization."
+ − 267 :group 'i18n)
+ − 268
+ − 269
+ − 270 ;;; Utilities.
+ − 271
+ − 272 (defun custom-quote (sexp)
+ − 273 "Quote SEXP iff it is not self quoting."
+ − 274 (if (or (memq sexp '(t nil))
+ − 275 (keywordp sexp)
+ − 276 (eq (car-safe sexp) 'lambda)
+ − 277 (stringp sexp)
+ − 278 (numberp sexp)
+ − 279 (characterp sexp)
+ − 280 (vectorp sexp)
+ − 281 (bit-vector-p sexp))
+ − 282 sexp
+ − 283 (list 'quote sexp)))
+ − 284
+ − 285 (defun custom-split-regexp-maybe (regexp)
+ − 286 "If REGEXP is a string, split it to a list at `\\|'.
+ − 287 You can get the original back with from the result with:
+ − 288 (mapconcat #'identity result \"\\|\")
+ − 289
+ − 290 IF REGEXP is not a string, return it unchanged."
+ − 291 (if (stringp regexp)
+ − 292 (split-string regexp "\\\\|")
+ − 293 regexp))
+ − 294
+ − 295 (defun custom-variable-prompt ()
+ − 296 ;; Code stolen from `help.el'.
+ − 297 "Prompt for a variable, defaulting to the variable at point.
+ − 298 Return a list suitable for use in `interactive'."
+ − 299 (let ((v (variable-at-point))
+ − 300 (enable-recursive-minibuffers t)
+ − 301 val)
+ − 302 (setq val (completing-read
+ − 303 (if (symbolp v)
+ − 304 (format "Customize variable: (default %s) " v)
+ − 305 "Customize variable: ")
+ − 306 obarray (lambda (symbol)
+ − 307 (and (boundp symbol)
+ − 308 (or (get symbol 'custom-type)
476
+ − 309 (user-variable-p symbol))))
4178
+ − 310 t nil nil (and v (symbol-name v))))
428
+ − 311 (list (if (equal val "")
+ − 312 (if (symbolp v) v nil)
+ − 313 (intern val)))))
+ − 314
+ − 315 ;; Here we take not only the actual groups, but the loads, too.
+ − 316 (defun custom-group-prompt (prompt)
+ − 317 "Read group from minibuffer."
+ − 318 (let ((completion-ignore-case t))
+ − 319 (list (completing-read
+ − 320 prompt obarray
+ − 321 (lambda (symbol)
+ − 322 (or (get symbol 'custom-group)
+ − 323 (get symbol 'custom-loads)))
+ − 324 t))))
+ − 325
+ − 326 (defun custom-menu-filter (menu widget)
+ − 327 "Convert MENU to the form used by `widget-choose'.
+ − 328 MENU should be in the same format as `custom-variable-menu'.
+ − 329 WIDGET is the widget to apply the filter entries of MENU on."
+ − 330 (let ((result nil)
+ − 331 current name action filter)
+ − 332 (while menu
+ − 333 (setq current (car menu)
+ − 334 name (nth 0 current)
+ − 335 action (nth 1 current)
+ − 336 filter (nth 2 current)
+ − 337 menu (cdr menu))
+ − 338 (if (or (null filter) (funcall filter widget))
+ − 339 (push (cons name action) result)
+ − 340 (push name result)))
+ − 341 (nreverse result)))
+ − 342
+ − 343
+ − 344 ;;; Unlispify.
+ − 345
+ − 346 (defvar custom-prefix-list nil
+ − 347 "List of prefixes that should be ignored by `custom-unlispify'")
+ − 348
848
+ − 349 (defcustom custom-save-pretty-print t
+ − 350 "Non-nil means pretty-print values of customized variables if available."
+ − 351 :group 'customize
+ − 352 :type 'boolean)
+ − 353
+ − 354
428
+ − 355 (defcustom custom-unlispify-menu-entries t
+ − 356 "Display menu entries as words instead of symbols if non nil."
+ − 357 :group 'custom-menu
+ − 358 :type 'boolean)
+ − 359
+ − 360 (defcustom custom-unlispify-remove-prefixes t
+ − 361 "Non-nil means remove group prefixes from option names in buffers and menus.
+ − 362 This only has an effect when `custom-unlispify-tag-names' or
+ − 363 `custom-unlispify-menu-entries' is on."
+ − 364 :group 'custom-menu
+ − 365 :type 'boolean)
+ − 366
+ − 367 (defun custom-unlispify-menu-entry (symbol &optional no-suffix)
+ − 368 "Convert symbol into a menu entry."
+ − 369 (cond ((not custom-unlispify-menu-entries)
+ − 370 (symbol-name symbol))
+ − 371 ((get symbol 'custom-tag)
+ − 372 (if no-suffix
+ − 373 (get symbol 'custom-tag)
+ − 374 (concat (get symbol 'custom-tag) "...")))
+ − 375 (t
+ − 376 (with-current-buffer (get-buffer-create " *Custom-Work*")
+ − 377 (erase-buffer)
+ − 378 (princ symbol (current-buffer))
+ − 379 (goto-char (point-min))
+ − 380 (when (and (eq (get symbol 'custom-type) 'boolean)
+ − 381 (re-search-forward "-p\\'" nil t))
+ − 382 (replace-match "" t t)
+ − 383 (goto-char (point-min)))
+ − 384 (when custom-unlispify-remove-prefixes
+ − 385 (let ((prefixes custom-prefix-list)
+ − 386 prefix)
+ − 387 (while prefixes
+ − 388 (setq prefix (car prefixes))
+ − 389 (if (search-forward prefix (+ (point) (length prefix)) t)
+ − 390 (progn
+ − 391 (setq prefixes nil)
+ − 392 (delete-region (point-min) (point)))
+ − 393 (setq prefixes (cdr prefixes))))))
+ − 394 (subst-char-in-region (point-min) (point-max) ?- ?\ t)
+ − 395 (capitalize-region (point-min) (point-max))
+ − 396 (unless no-suffix
+ − 397 (goto-char (point-max))
+ − 398 (insert "..."))
+ − 399 (buffer-string)))))
+ − 400
+ − 401 (defcustom custom-unlispify-tag-names t
+ − 402 "Display tag names as words instead of symbols if non nil."
+ − 403 :group 'custom-buffer
+ − 404 :type 'boolean)
+ − 405
+ − 406 (defun custom-unlispify-tag-name (symbol)
+ − 407 "Convert symbol into a menu entry."
+ − 408 (let ((custom-unlispify-menu-entries custom-unlispify-tag-names))
+ − 409 (custom-unlispify-menu-entry symbol t)))
+ − 410
+ − 411 (defun custom-prefix-add (symbol prefixes)
440
+ − 412 ;; Add SYMBOL to list of ignored PREFIXES.
428
+ − 413 (cons (or (get symbol 'custom-prefix)
+ − 414 (concat (symbol-name symbol) "-"))
+ − 415 prefixes))
+ − 416
+ − 417
+ − 418 ;;; Guess.
+ − 419
+ − 420 (defcustom custom-guess-name-alist
+ − 421 '(("-p\\'" boolean)
+ − 422 ("-hooks?\\'" hook)
+ − 423 ("-face\\'" face)
+ − 424 ("-file\\'" file)
+ − 425 ("-function\\'" function)
+ − 426 ("-functions\\'" (repeat function))
+ − 427 ("-list\\'" (repeat sexp))
+ − 428 ("-alist\\'" (repeat (cons sexp sexp))))
+ − 429 "Alist of (MATCH TYPE).
+ − 430
+ − 431 MATCH should be a regexp matching the name of a symbol, and TYPE should
+ − 432 be a widget suitable for editing the value of that symbol. The TYPE
+ − 433 of the first entry where MATCH matches the name of the symbol will be
+ − 434 used.
+ − 435
+ − 436 This is used for guessing the type of variables not declared with
+ − 437 customize."
+ − 438 :type '(repeat (group (regexp :tag "Match") (sexp :tag "Type")))
+ − 439 :group 'customize)
+ − 440
+ − 441 (defcustom custom-guess-doc-alist
+ − 442 '(("\\`\\*?Non-nil " boolean))
+ − 443 "Alist of (MATCH TYPE).
+ − 444
+ − 445 MATCH should be a regexp matching a documentation string, and TYPE
+ − 446 should be a widget suitable for editing the value of a variable with
+ − 447 that documentation string. The TYPE of the first entry where MATCH
+ − 448 matches the name of the symbol will be used.
+ − 449
+ − 450 This is used for guessing the type of variables not declared with
+ − 451 customize."
+ − 452 :type '(repeat (group (regexp :tag "Match") (sexp :tag "Type")))
+ − 453 :group 'customize)
+ − 454
+ − 455 (defun custom-guess-type (symbol)
+ − 456 "Guess a widget suitable for editing the value of SYMBOL.
+ − 457 This is done by matching SYMBOL with `custom-guess-name-alist' and
+ − 458 if that fails, the doc string with `custom-guess-doc-alist'."
+ − 459 (let ((name (symbol-name symbol))
+ − 460 (names custom-guess-name-alist)
+ − 461 current found)
+ − 462 (while names
+ − 463 (setq current (car names)
+ − 464 names (cdr names))
+ − 465 (when (string-match (nth 0 current) name)
+ − 466 (setq found (nth 1 current)
+ − 467 names nil)))
+ − 468 (unless found
+ − 469 (let ((doc (documentation-property symbol 'variable-documentation))
+ − 470 (docs custom-guess-doc-alist))
+ − 471 (when doc
+ − 472 (while docs
+ − 473 (setq current (car docs)
+ − 474 docs (cdr docs))
+ − 475 (when (string-match (nth 0 current) doc)
+ − 476 (setq found (nth 1 current)
+ − 477 docs nil))))))
+ − 478 found))
+ − 479
+ − 480
+ − 481 ;;; Sorting.
+ − 482
+ − 483 (defcustom custom-browse-sort-alphabetically nil
+ − 484 "If non-nil, sort members of each customization group alphabetically."
+ − 485 :type 'boolean
+ − 486 :group 'custom-browse)
+ − 487
+ − 488 (defcustom custom-browse-order-groups nil
+ − 489 "If non-nil, order group members within each customization group.
+ − 490 If `first', order groups before non-groups.
+ − 491 If `last', order groups after non-groups."
+ − 492 :type '(choice (const first)
+ − 493 (const last)
+ − 494 (const :tag "none" nil))
+ − 495 :group 'custom-browse)
+ − 496
+ − 497 (defcustom custom-browse-only-groups nil
+ − 498 "If non-nil, show group members only within each customization group."
+ − 499 :type 'boolean
+ − 500 :group 'custom-browse)
+ − 501
+ − 502 (defcustom custom-buffer-sort-alphabetically nil
+ − 503 "If non-nil, sort members of each customization group alphabetically."
+ − 504 :type 'boolean
+ − 505 :group 'custom-buffer)
+ − 506
+ − 507 (defcustom custom-buffer-order-groups 'last
+ − 508 "If non-nil, order group members within each customization group.
+ − 509 If `first', order groups before non-groups.
+ − 510 If `last', order groups after non-groups."
+ − 511 :type '(choice (const first)
+ − 512 (const last)
+ − 513 (const :tag "none" nil))
+ − 514 :group 'custom-buffer)
+ − 515
+ − 516 (defcustom custom-menu-sort-alphabetically nil
+ − 517 "If non-nil, sort members of each customization group alphabetically."
+ − 518 :type 'boolean
+ − 519 :group 'custom-menu)
+ − 520
+ − 521 (defcustom custom-menu-order-groups 'first
+ − 522 "If non-nil, order group members within each customization group.
+ − 523 If `first', order groups before non-groups.
+ − 524 If `last', order groups after non-groups."
+ − 525 :type '(choice (const first)
+ − 526 (const last)
+ − 527 (const :tag "none" nil))
+ − 528 :group 'custom-menu)
+ − 529
+ − 530 (defun custom-sort-items (items sort-alphabetically order-groups)
+ − 531 "Return a sorted copy of ITEMS.
+ − 532 ITEMS should be a `custom-group' property.
+ − 533 If SORT-ALPHABETICALLY non-nil, sort alphabetically.
+ − 534 If ORDER-GROUPS is `first' order groups before non-groups, if `last' order
+ − 535 groups after non-groups, if nil do not order groups at all."
+ − 536 (sort (copy-sequence items)
+ − 537 (lambda (a b)
+ − 538 (let ((typea (nth 1 a)) (typeb (nth 1 b))
+ − 539 (namea (symbol-name (nth 0 a))) (nameb (symbol-name (nth 0 b))))
+ − 540 (cond ((not order-groups)
+ − 541 ;; Since we don't care about A and B order, maybe sort.
+ − 542 (when sort-alphabetically
+ − 543 (string-lessp namea nameb)))
+ − 544 ((eq typea 'custom-group)
+ − 545 ;; If B is also a group, maybe sort. Otherwise, order A and B.
+ − 546 (if (eq typeb 'custom-group)
+ − 547 (when sort-alphabetically
+ − 548 (string-lessp namea nameb))
+ − 549 (eq order-groups 'first)))
+ − 550 ((eq typeb 'custom-group)
+ − 551 ;; Since A cannot be a group, order A and B.
+ − 552 (eq order-groups 'last))
+ − 553 (sort-alphabetically
+ − 554 ;; Since A and B cannot be groups, sort.
+ − 555 (string-lessp namea nameb)))))))
+ − 556
+ − 557
+ − 558 ;;; Custom Mode Commands.
+ − 559
+ − 560 (defvar custom-options nil
+ − 561 "Customization widgets in the current buffer.")
+ − 562
+ − 563 (defun Custom-set ()
+ − 564 "Set changes in all modified options."
+ − 565 (interactive)
+ − 566 (let ((children custom-options))
+ − 567 (mapc (lambda (child)
+ − 568 (when (eq (widget-get child :custom-state) 'modified)
+ − 569 (widget-apply child :custom-set)))
+ − 570 children)))
+ − 571
+ − 572 (defun Custom-save ()
480
+ − 573 "Set all modified options and save them."
428
+ − 574 (interactive)
480
+ − 575 (let ((all-children custom-options)
+ − 576 children)
428
+ − 577 (mapc (lambda (child)
+ − 578 (when (memq (widget-get child :custom-state) '(modified set))
480
+ − 579 (push child children)))
+ − 580 all-children)
+ − 581 (let ((the-children children)
+ − 582 child)
+ − 583 (while (setq child (pop the-children))
+ − 584 (widget-apply child :custom-pre-save)))
+ − 585 (custom-save-all)
+ − 586 (let ((the-children children)
+ − 587 child)
+ − 588 (while (setq child (pop the-children))
+ − 589 (widget-apply child :custom-post-save)))
+ − 590 ))
428
+ − 591
+ − 592 (defvar custom-reset-menu
+ − 593 '(("Current" . Custom-reset-current)
+ − 594 ("Saved" . Custom-reset-saved)
+ − 595 ("Standard Settings" . Custom-reset-standard))
+ − 596 "Alist of actions for the `Reset' button.
+ − 597 The key is a string containing the name of the action, the value is a
+ − 598 lisp function taking the widget as an element which will be called
+ − 599 when the action is chosen.")
+ − 600
+ − 601 (defun custom-reset (event)
+ − 602 "Select item from reset menu."
+ − 603 (let* ((completion-ignore-case t)
+ − 604 (answer (widget-choose "Reset to"
+ − 605 custom-reset-menu
+ − 606 event)))
+ − 607 (if answer
+ − 608 (funcall answer))))
+ − 609
+ − 610 (defun Custom-reset-current (&rest ignore)
+ − 611 "Reset all modified group members to their current value."
+ − 612 (interactive)
+ − 613 (let ((children custom-options))
+ − 614 (mapc (lambda (child)
+ − 615 (when (eq (widget-get child :custom-state) 'modified)
+ − 616 (widget-apply child :custom-reset-current)))
+ − 617 children)))
+ − 618
+ − 619 (defun Custom-reset-saved (&rest ignore)
+ − 620 "Reset all modified or set group members to their saved value."
+ − 621 (interactive)
+ − 622 (let ((children custom-options))
+ − 623 (mapc (lambda (child)
+ − 624 (when (eq (widget-get child :custom-state) 'modified)
+ − 625 (widget-apply child :custom-reset-saved)))
+ − 626 children)))
+ − 627
+ − 628 (defun Custom-reset-standard (&rest ignore)
+ − 629 "Reset all modified, set, or saved group members to their standard settings."
+ − 630 (interactive)
480
+ − 631 (let ((all-children custom-options)
+ − 632 children must-save)
428
+ − 633 (mapc (lambda (child)
476
+ − 634 (when (memq (widget-get child :custom-state) '(modified set saved))
480
+ − 635 (push child children)))
+ − 636 all-children)
+ − 637 (let ((the-children children)
+ − 638 child)
+ − 639 (while (setq child (pop the-children))
+ − 640 (and (widget-apply child :custom-pre-reset-standard)
+ − 641 (setq must-save t))))
+ − 642 (and must-save (custom-save-all))
+ − 643 (let ((the-children children)
+ − 644 child)
+ − 645 (while (setq child (pop the-children))
+ − 646 (widget-apply child :custom-post-reset-standard)))
+ − 647 ))
428
+ − 648
+ − 649
+ − 650 ;;; The Customize Commands
+ − 651
+ − 652 (defun custom-prompt-variable (prompt-var prompt-val &optional comment)
+ − 653 "Prompt for a variable and a value and return them as a list.
+ − 654 PROMPT-VAR is the prompt for the variable, and PROMPT-VAL is the
4178
+ − 655 prompt for the value. A %s escape in PROMPT-VAL is replaced with
+ − 656 the name of the variable. A final colon is appended to both prompts.
428
+ − 657
+ − 658 If the variable has a `variable-interactive' property, that is used as if
+ − 659 it were the arg to `interactive' (which see) to interactively read the value.
+ − 660
+ − 661 If the variable has a `custom-type' property, it must be a widget and the
+ − 662 `:prompt-value' property of that widget will be used for reading the value.
+ − 663
+ − 664 If optional COMMENT argument is non nil, also prompt for a comment and return
+ − 665 it as the third element in the list."
4178
+ − 666 (let* ((var (read-variable (concat prompt-var ": ")))
428
+ − 667 (minibuffer-help-form '(describe-variable var))
+ − 668 (val
+ − 669 (let ((prop (get var 'variable-interactive))
+ − 670 (type (get var 'custom-type))
+ − 671 (prompt (format prompt-val var)))
+ − 672 (unless (listp type)
+ − 673 (setq type (list type)))
+ − 674 (cond (prop
+ − 675 ;; Use VAR's `variable-interactive' property
+ − 676 ;; as an interactive spec for prompting.
+ − 677 (call-interactively (list 'lambda '(arg)
+ − 678 (list 'interactive prop)
+ − 679 'arg)))
+ − 680 (type
+ − 681 (widget-prompt-value type
+ − 682 prompt
+ − 683 (if (boundp var)
+ − 684 (symbol-value var))
+ − 685 (not (boundp var))))
+ − 686 (t
4178
+ − 687 (eval-minibuffer (concat prompt ": ")))))))
428
+ − 688 (if comment
+ − 689 (list var val
+ − 690 (read-string "Comment: " (get var 'variable-comment)))
4178
+ − 691 (list var val))))
428
+ − 692
+ − 693 ;;;###autoload
+ − 694 (defun customize-set-value (var val &optional comment)
+ − 695 "Set VARIABLE to VALUE. VALUE is a Lisp object.
+ − 696
+ − 697 If VARIABLE has a `variable-interactive' property, that is used as if
+ − 698 it were the arg to `interactive' (which see) to interactively read the value.
+ − 699
+ − 700 If VARIABLE has a `custom-type' property, it must be a widget and the
+ − 701 `:prompt-value' property of that widget will be used for reading the value.
+ − 702
+ − 703 If given a prefix (or a COMMENT argument), also prompt for a comment."
4178
+ − 704 (interactive (custom-prompt-variable "Set variable"
+ − 705 "Set value of %s"
428
+ − 706 current-prefix-arg))
+ − 707
+ − 708 (set var val)
+ − 709 (cond ((string= comment "")
+ − 710 (put var 'variable-comment nil))
+ − 711 (comment
+ − 712 (put var 'variable-comment comment))))
+ − 713
+ − 714 ;;;###autoload
444
+ − 715 (defun customize-set-variable (variable value &optional comment)
+ − 716 "Set the default for VARIABLE to VALUE. VALUE is any Lisp object.
428
+ − 717
+ − 718 If VARIABLE has a `custom-set' property, that is used for setting
+ − 719 VARIABLE, otherwise `set-default' is used.
+ − 720
+ − 721 The `customized-value' property of the VARIABLE will be set to a list
+ − 722 with a quoted VALUE as its sole list member.
+ − 723
+ − 724 If VARIABLE has a `variable-interactive' property, that is used as if
+ − 725 it were the arg to `interactive' (which see) to interactively read the value.
+ − 726
+ − 727 If VARIABLE has a `custom-type' property, it must be a widget and the
+ − 728 `:prompt-value' property of that widget will be used for reading the value.
+ − 729
+ − 730 If given a prefix (or a COMMENT argument), also prompt for a comment."
4178
+ − 731 (interactive (custom-prompt-variable "Set variable"
+ − 732 "Set customized value of %s"
428
+ − 733 current-prefix-arg))
444
+ − 734 (funcall (or (get variable 'custom-set) 'set-default) variable value)
+ − 735 (put variable 'customized-value (list (custom-quote value)))
428
+ − 736 (cond ((string= comment "")
444
+ − 737 (put variable 'variable-comment nil)
+ − 738 (put variable 'customized-variable-comment nil))
428
+ − 739 (comment
444
+ − 740 (put variable 'variable-comment comment)
+ − 741 (put variable 'customized-variable-comment comment))))
428
+ − 742
+ − 743
+ − 744 ;;;###autoload
444
+ − 745 (defun customize-save-variable (variable value &optional comment)
428
+ − 746 "Set the default for VARIABLE to VALUE, and save it for future sessions.
+ − 747 If VARIABLE has a `custom-set' property, that is used for setting
+ − 748 VARIABLE, otherwise `set-default' is used.
+ − 749
+ − 750 The `customized-value' property of the VARIABLE will be set to a list
+ − 751 with a quoted VALUE as its sole list member.
+ − 752
+ − 753 If VARIABLE has a `variable-interactive' property, that is used as if
+ − 754 it were the arg to `interactive' (which see) to interactively read the value.
+ − 755
+ − 756 If VARIABLE has a `custom-type' property, it must be a widget and the
+ − 757 `:prompt-value' property of that widget will be used for reading the value.
+ − 758
+ − 759 If given a prefix (or a COMMENT argument), also prompt for a comment."
4178
+ − 760 (interactive (custom-prompt-variable "Set and save variable"
+ − 761 "Set and save value of %s"
428
+ − 762 current-prefix-arg))
444
+ − 763 (funcall (or (get variable 'custom-set) 'set-default) variable value)
+ − 764 (put variable 'saved-value (list (custom-quote value)))
+ − 765 (custom-push-theme 'theme-value variable 'user 'set (list (custom-quote value)))
428
+ − 766 (cond ((string= comment "")
444
+ − 767 (put variable 'variable-comment nil)
+ − 768 (put variable 'saved-variable-comment nil))
428
+ − 769 (comment
444
+ − 770 (put variable 'variable-comment comment)
+ − 771 (put variable 'saved-variable-comment comment)))
428
+ − 772 (custom-save-all))
+ − 773
+ − 774 ;;;###autoload
+ − 775 (defun customize (group)
+ − 776 "Select a customization buffer which you can use to set user options.
+ − 777 User options are structured into \"groups\".
+ − 778 The default group is `Emacs'."
+ − 779 (interactive (custom-group-prompt
+ − 780 "Customize group: (default emacs) "))
+ − 781 (when (stringp group)
+ − 782 (if (string-equal "" group)
+ − 783 (setq group 'emacs)
+ − 784 (setq group (intern group))))
+ − 785 (let ((name (format "*Customize Group: %s*"
+ − 786 (custom-unlispify-tag-name group))))
+ − 787 (if (get-buffer name)
+ − 788 (switch-to-buffer name)
+ − 789 (custom-buffer-create (list (list group 'custom-group))
+ − 790 name
+ − 791 (concat " for group "
+ − 792 (custom-unlispify-tag-name group))))))
+ − 793
+ − 794 ;;;###autoload
+ − 795 (defalias 'customize-group 'customize)
+ − 796
+ − 797 ;;;###autoload
+ − 798 (defun customize-other-window (symbol)
+ − 799 "Customize SYMBOL, which must be a customization group."
+ − 800 (interactive (custom-group-prompt
+ − 801 "Customize group: (default emacs) "))
+ − 802 (when (stringp symbol)
+ − 803 (if (string-equal "" symbol)
+ − 804 (setq symbol 'emacs)
+ − 805 (setq symbol (intern symbol))))
+ − 806 (custom-buffer-create-other-window
+ − 807 (list (list symbol 'custom-group))
+ − 808 (format "*Customize Group: %s*" (custom-unlispify-tag-name symbol))))
+ − 809
+ − 810 ;;;###autoload
+ − 811 (defalias 'customize-group-other-window 'customize-other-window)
+ − 812
+ − 813 ;;;###autoload
+ − 814 (defalias 'customize-option 'customize-variable)
+ − 815
+ − 816 ;;;###autoload
+ − 817 (defun customize-variable (symbol)
+ − 818 "Customize SYMBOL, which must be a user option variable."
+ − 819 (interactive (custom-variable-prompt))
+ − 820 (custom-buffer-create (list (list symbol 'custom-variable))
+ − 821 (format "*Customize Variable: %s*"
+ − 822 (custom-unlispify-tag-name symbol))))
+ − 823
+ − 824 ;;;###autoload
+ − 825 (defun customize-changed-options (since-version)
+ − 826 "Customize all user option variables whose default values changed recently.
+ − 827 This means, in other words, variables defined with a `:version' keyword."
4289
+ − 828 (interactive
+ − 829 "sCustomize options changed, since version (default all versions): ")
428
+ − 830 (if (equal since-version "")
+ − 831 (setq since-version nil))
+ − 832 (let ((found nil))
+ − 833 (mapatoms (lambda (symbol)
+ − 834 (and (boundp symbol)
+ − 835 (let ((version (get symbol 'custom-version)))
+ − 836 (and version
+ − 837 (or (null since-version)
4289
+ − 838 (customize-version-lessp since-version
+ − 839 version))))
428
+ − 840 (push (list symbol 'custom-variable) found))))
+ − 841 (unless found
+ − 842 (error "No user options have changed defaults %s"
+ − 843 (if since-version
+ − 844 (format "since XEmacs %s" since-version)
+ − 845 "in recent Emacs versions")))
+ − 846 (custom-buffer-create (custom-sort-items found t nil)
+ − 847 "*Customize Changed Options*")))
+ − 848
+ − 849 (defun customize-version-lessp (version1 version2)
+ − 850 (let (major1 major2 minor1 minor2)
+ − 851 (string-match "\\([0-9]+\\)[.]\\([0-9]+\\)" version1)
+ − 852 (setq major1 (read (match-string 1 version1)))
+ − 853 (setq minor1 (read (match-string 2 version1)))
+ − 854 (string-match "\\([0-9]+\\)[.]\\([0-9]+\\)" version2)
+ − 855 (setq major2 (read (match-string 1 version2)))
+ − 856 (setq minor2 (read (match-string 2 version2)))
+ − 857 (or (< major1 major2)
+ − 858 (and (= major1 major2)
+ − 859 (< minor1 minor2)))))
+ − 860
+ − 861 ;;;###autoload
+ − 862 (defalias 'customize-variable-other-window 'customize-option-other-window)
+ − 863
+ − 864 ;;;###autoload
+ − 865 (defun customize-option-other-window (symbol)
+ − 866 "Customize SYMBOL, which must be a user option variable.
+ − 867 Show the buffer in another window, but don't select it."
+ − 868 (interactive (custom-variable-prompt))
+ − 869 (custom-buffer-create-other-window
+ − 870 (list (list symbol 'custom-variable))
+ − 871 (format "*Customize Option: %s*" (custom-unlispify-tag-name symbol))))
+ − 872
+ − 873 ;;;###autoload
+ − 874 (defun customize-face (&optional symbol)
+ − 875 "Customize SYMBOL, which should be a face name or nil.
+ − 876 If SYMBOL is nil, customize all faces."
+ − 877 (interactive (list (completing-read "Customize face: (default all) "
+ − 878 obarray 'find-face)))
+ − 879 (if (or (null symbol) (and (stringp symbol) (zerop (length symbol))))
+ − 880 (custom-buffer-create (custom-sort-items
+ − 881 (mapcar (lambda (symbol)
+ − 882 (list symbol 'custom-face))
+ − 883 (face-list))
+ − 884 t nil)
+ − 885 "*Customize Faces*")
+ − 886 (when (stringp symbol)
+ − 887 (setq symbol (intern symbol)))
+ − 888 (check-argument-type 'symbolp symbol)
+ − 889 (custom-buffer-create (list (list symbol 'custom-face))
+ − 890 (format "*Customize Face: %s*"
+ − 891 (custom-unlispify-tag-name symbol)))))
+ − 892
+ − 893 ;;;###autoload
+ − 894 (defun customize-face-other-window (&optional symbol)
+ − 895 "Show customization buffer for FACE in other window."
+ − 896 (interactive (list (completing-read "Customize face: "
+ − 897 obarray 'find-face)))
+ − 898 (if (or (null symbol) (and (stringp symbol) (zerop (length symbol))))
+ − 899 ()
+ − 900 (if (stringp symbol)
+ − 901 (setq symbol (intern symbol)))
+ − 902 (check-argument-type 'symbolp symbol)
+ − 903 (custom-buffer-create-other-window
+ − 904 (list (list symbol 'custom-face))
+ − 905 (format "*Customize Face: %s*" (custom-unlispify-tag-name symbol)))))
+ − 906
+ − 907 ;;;###autoload
+ − 908 (defun customize-customized ()
+ − 909 "Customize all user options set since the last save in this session."
+ − 910 (interactive)
+ − 911 (let ((found nil))
+ − 912 (mapatoms (lambda (symbol)
+ − 913 (and (or (get symbol 'customized-face)
+ − 914 (get symbol 'customized-face-comment))
+ − 915 (find-face symbol)
+ − 916 (push (list symbol 'custom-face) found))
+ − 917 (and (or (get symbol 'customized-value)
+ − 918 (get symbol 'customized-variable-comment))
+ − 919 (boundp symbol)
+ − 920 (push (list symbol 'custom-variable) found))))
+ − 921 (if (not found)
+ − 922 (error "No customized user options")
+ − 923 (custom-buffer-create (custom-sort-items found t nil)
+ − 924 "*Customize Customized*"))))
+ − 925
+ − 926 ;;;###autoload
+ − 927 (defun customize-saved ()
+ − 928 "Customize all already saved user options."
+ − 929 (interactive)
+ − 930 (let ((found nil))
+ − 931 (mapatoms (lambda (symbol)
+ − 932 (and (or (get symbol 'saved-face)
+ − 933 (get symbol 'saved-face-comment))
+ − 934 (find-face symbol)
+ − 935 (push (list symbol 'custom-face) found))
+ − 936 (and (or (get symbol 'saved-value)
+ − 937 (get symbol 'saved-variable-comment))
+ − 938 (boundp symbol)
+ − 939 (push (list symbol 'custom-variable) found))))
+ − 940 (if (not found )
+ − 941 (error "No saved user options")
+ − 942 (custom-buffer-create (custom-sort-items found t nil)
+ − 943 "*Customize Saved*"))))
+ − 944
+ − 945 ;;;###autoload
1655
+ − 946 (defalias 'apropos-customize 'customize-apropos)
+ − 947
+ − 948 ;;;###autoload
428
+ − 949 (defun customize-apropos (regexp &optional all)
+ − 950 "Customize all user options matching REGEXP.
+ − 951 If ALL is `options', include only options.
+ − 952 If ALL is `faces', include only faces.
+ − 953 If ALL is `groups', include only groups.
+ − 954 If ALL is t (interactively, with prefix arg), include options which are not
+ − 955 user-settable, as well as faces and groups."
+ − 956 (interactive "sCustomize regexp: \nP")
+ − 957 (let ((found nil))
+ − 958 (mapatoms (lambda (symbol)
+ − 959 (when (string-match regexp (symbol-name symbol))
+ − 960 (when (and (not (memq all '(faces options)))
+ − 961 (get symbol 'custom-group))
+ − 962 (push (list symbol 'custom-group) found))
+ − 963 (when (and (not (memq all '(options groups)))
+ − 964 (find-face symbol))
+ − 965 (push (list symbol 'custom-face) found))
+ − 966 (when (and (not (memq all '(groups faces)))
+ − 967 (boundp symbol)
+ − 968 (or (get symbol 'saved-value)
+ − 969 (get symbol 'standard-value)
+ − 970 (if (memq all '(nil options))
+ − 971 (user-variable-p symbol)
+ − 972 (get symbol 'variable-documentation))))
+ − 973 (push (list symbol 'custom-variable) found)))))
+ − 974 (if (not found)
+ − 975 (error "No matches")
+ − 976 (custom-buffer-create (custom-sort-items found t
+ − 977 custom-buffer-order-groups)
+ − 978 "*Customize Apropos*"))))
+ − 979
+ − 980 ;;;###autoload
+ − 981 (defun customize-apropos-options (regexp &optional arg)
+ − 982 "Customize all user options matching REGEXP.
+ − 983 With prefix arg, include options which are not user-settable."
+ − 984 (interactive "sCustomize regexp: \nP")
+ − 985 (customize-apropos regexp (or arg 'options)))
+ − 986
+ − 987 ;;;###autoload
+ − 988 (defun customize-apropos-faces (regexp)
+ − 989 "Customize all user faces matching REGEXP."
+ − 990 (interactive "sCustomize regexp: \n")
+ − 991 (customize-apropos regexp 'faces))
+ − 992
+ − 993 ;;;###autoload
+ − 994 (defun customize-apropos-groups (regexp)
+ − 995 "Customize all user groups matching REGEXP."
+ − 996 (interactive "sCustomize regexp: \n")
+ − 997 (customize-apropos regexp 'groups))
+ − 998
+ − 999
+ − 1000 ;;; Buffer.
+ − 1001
+ − 1002 (defcustom custom-buffer-style 'links
+ − 1003 "*Control the presentation style for customization buffers.
+ − 1004 The value should be a symbol, one of:
+ − 1005
+ − 1006 brackets: groups nest within each other with big horizontal brackets.
+ − 1007 links: groups have links to subgroups."
+ − 1008 :type '(radio (const :tag "brackets: Groups nest within each others" brackets)
+ − 1009 (const :tag "links: Group have links to subgroups" links))
+ − 1010 :group 'custom-buffer)
+ − 1011
+ − 1012 (defcustom custom-buffer-done-function 'kill-buffer
+ − 1013 "*Function to be used to remove the buffer when the user is done with it.
+ − 1014 Choices include `kill-buffer' (the default) and `bury-buffer'.
+ − 1015 The function will be called with one argument, the buffer to remove."
+ − 1016 :type '(radio (function-item kill-buffer)
+ − 1017 (function-item bury-buffer)
+ − 1018 (function :tag "Other" nil))
+ − 1019 :group 'custom-buffer)
+ − 1020
+ − 1021 (defcustom custom-buffer-indent 3
+ − 1022 "Number of spaces to indent nested groups."
+ − 1023 :type 'integer
+ − 1024 :group 'custom-buffer)
+ − 1025
+ − 1026 ;;;###autoload
+ − 1027 (defun custom-buffer-create (options &optional name description)
+ − 1028 "Create a buffer containing OPTIONS.
+ − 1029 Optional NAME is the name of the buffer.
+ − 1030 OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where
+ − 1031 SYMBOL is a customization option, and WIDGET is a widget for editing
+ − 1032 that option."
+ − 1033 (unless name (setq name "*Customization*"))
+ − 1034 (kill-buffer (get-buffer-create name))
+ − 1035 (switch-to-buffer (get-buffer-create name))
+ − 1036 (custom-buffer-create-internal options description))
+ − 1037
+ − 1038 ;;;###autoload
+ − 1039 (defun custom-buffer-create-other-window (options &optional name description)
+ − 1040 "Create a buffer containing OPTIONS.
+ − 1041 Optional NAME is the name of the buffer.
+ − 1042 OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where
+ − 1043 SYMBOL is a customization option, and WIDGET is a widget for editing
+ − 1044 that option."
+ − 1045 (unless name (setq name "*Customization*"))
+ − 1046 (kill-buffer (get-buffer-create name))
+ − 1047 (let ((window (selected-window)))
+ − 1048 (switch-to-buffer-other-window (get-buffer-create name))
+ − 1049 (custom-buffer-create-internal options description)
+ − 1050 (select-window window)))
+ − 1051
+ − 1052 (defcustom custom-reset-button-menu t
+ − 1053 "If non-nil, only show a single reset button in customize buffers.
+ − 1054 This button will have a menu with all three reset operations."
+ − 1055 :type 'boolean
+ − 1056 :group 'custom-buffer)
+ − 1057
+ − 1058 (defconst custom-skip-messages 5)
+ − 1059
+ − 1060 (defun Custom-buffer-done ()
+ − 1061 "Remove current buffer.
+ − 1062 This works by calling the function specified by
+ − 1063 `custom-buffer-done-function'."
+ − 1064 (interactive)
+ − 1065 (funcall custom-buffer-done-function (current-buffer)))
+ − 1066
+ − 1067 (defun custom-buffer-create-buttons ()
+ − 1068 (message "Creating customization buttons...")
+ − 1069 (widget-insert "\nOperate on everything in this buffer:\n ")
+ − 1070 (widget-create 'push-button
+ − 1071 :tag "Set"
+ − 1072 :help-echo "\
+ − 1073 Make your editing in this buffer take effect for this session"
+ − 1074 :action (lambda (widget &optional event)
+ − 1075 (Custom-set)))
+ − 1076 (widget-insert " ")
+ − 1077 (widget-create 'push-button
+ − 1078 :tag "Save"
+ − 1079 :help-echo "\
+ − 1080 Make your editing in this buffer take effect for future Emacs sessions"
+ − 1081 :action (lambda (widget &optional event)
+ − 1082 (Custom-save)))
+ − 1083 (if custom-reset-button-menu
+ − 1084 (progn
+ − 1085 (widget-insert " ")
+ − 1086 (widget-create 'push-button
+ − 1087 :tag "Reset"
+ − 1088 :tag-glyph '("reset-up" "reset-down")
+ − 1089 :help-echo "Show a menu with reset operations"
+ − 1090 :mouse-down-action (lambda (&rest junk) t)
+ − 1091 :action (lambda (widget &optional event)
+ − 1092 (custom-reset event))))
+ − 1093 (widget-insert " ")
+ − 1094 (widget-create 'push-button
+ − 1095 :tag "Reset"
+ − 1096 :help-echo "\
+ − 1097 Reset all edited text in this buffer to reflect current values"
+ − 1098 :action 'Custom-reset-current)
+ − 1099 (widget-insert " ")
+ − 1100 (widget-create 'push-button
+ − 1101 :tag "Reset to Saved"
+ − 1102 :help-echo "\
+ − 1103 Reset all values in this buffer to their saved settings"
+ − 1104 :action 'Custom-reset-saved)
+ − 1105 (widget-insert " ")
+ − 1106 (widget-create 'push-button
+ − 1107 :tag "Reset to Standard"
+ − 1108 :help-echo "\
+ − 1109 Reset all values in this buffer to their standard settings"
+ − 1110 :action 'Custom-reset-standard))
+ − 1111 (widget-insert " ")
+ − 1112 (widget-create 'push-button
+ − 1113 :tag "Done"
+ − 1114 :help-echo "Remove the buffer"
+ − 1115 :action (lambda (widget &optional event)
+ − 1116 (Custom-buffer-done)))
+ − 1117 (widget-insert "\n"))
+ − 1118
+ − 1119 (defcustom custom-novice t
+ − 1120 "If non-nil, show help message at top of customize buffers."
+ − 1121 :type 'boolean
+ − 1122 :group 'custom-buffer)
+ − 1123
+ − 1124 (defcustom custom-display-global-buttons 'top
+ − 1125 "If `nil' don't display the global buttons. If `top' display at the
+ − 1126 beginning of custom buffers. If `bottom', display at the end."
+ − 1127 :type '(choice (const top)
+ − 1128 (const bottom)
+ − 1129 (const :tag "don't" nil))
+ − 1130 :group 'custom-buffer)
+ − 1131
+ − 1132 (defun custom-buffer-create-internal (options &optional description)
+ − 1133 (message "Creating customization buffer...")
+ − 1134 (custom-mode)
+ − 1135 (widget-insert "This is a customization buffer")
+ − 1136 (if description
+ − 1137 (widget-insert description))
+ − 1138 (when custom-novice
+ − 1139 (widget-insert ".\n\
+ − 1140 Type RET or click button2 on an active field to invoke its action.
+ − 1141 Invoke ")
+ − 1142 (widget-create 'info-link
+ − 1143 :tag "Help"
+ − 1144 :help-echo "Read the online help"
+ − 1145 "(XEmacs)Easy Customization")
+ − 1146 (widget-insert " for more information."))
+ − 1147 (widget-insert "\n")
+ − 1148 (if (equal custom-display-global-buttons 'top)
+ − 1149 (custom-buffer-create-buttons))
+ − 1150 (widget-insert "\n")
+ − 1151 (message "Creating customization items...")
+ − 1152 (setq custom-options
+ − 1153 (if (= (length options) 1)
+ − 1154 (mapcar (lambda (entry)
+ − 1155 (widget-create (nth 1 entry)
+ − 1156 :documentation-shown t
+ − 1157 :custom-state 'unknown
+ − 1158 :tag (custom-unlispify-tag-name
+ − 1159 (nth 0 entry))
+ − 1160 :value (nth 0 entry)))
+ − 1161 options)
+ − 1162 (let ((count 0)
+ − 1163 (length (length options)))
+ − 1164 (mapcar (lambda (entry)
+ − 1165 (prog2
+ − 1166 (display-message
+ − 1167 'progress
+ − 1168 (format "Creating customization items %2d%%..."
+ − 1169 (/ (* 100.0 count) length)))
+ − 1170 (widget-create (nth 1 entry)
+ − 1171 :tag (custom-unlispify-tag-name
+ − 1172 (nth 0 entry))
+ − 1173 :value (nth 0 entry))
+ − 1174 (incf count)
+ − 1175 (unless (eq (preceding-char) ?\n)
+ − 1176 (widget-insert "\n"))
+ − 1177 (widget-insert "\n")))
+ − 1178 options))))
+ − 1179 (unless (eq (preceding-char) ?\n)
+ − 1180 (widget-insert "\n"))
+ − 1181 (if (equal custom-display-global-buttons 'bottom)
+ − 1182 (custom-buffer-create-buttons))
+ − 1183 (display-message 'progress
+ − 1184 (format
+ − 1185 "Creating customization items %2d%%...done" 100))
+ − 1186 (unless (eq custom-buffer-style 'tree)
+ − 1187 (mapc 'custom-magic-reset custom-options))
+ − 1188 (message "Creating customization setup...")
+ − 1189 (widget-setup)
+ − 1190 (goto-char (point-min))
+ − 1191 (message "Creating customization buffer...done"))
+ − 1192
+ − 1193
+ − 1194 ;;; The Tree Browser.
+ − 1195
+ − 1196 ;;;###autoload
+ − 1197 (defun customize-browse (&optional group)
+ − 1198 "Create a tree browser for the customize hierarchy."
+ − 1199 (interactive)
+ − 1200 (unless group
+ − 1201 (setq group 'emacs))
+ − 1202 (let ((name "*Customize Browser*"))
+ − 1203 (kill-buffer (get-buffer-create name))
+ − 1204 (switch-to-buffer (get-buffer-create name)))
+ − 1205 (custom-mode)
+ − 1206 (widget-insert "\
+ − 1207 Square brackets show active fields; type RET or click button2
+ − 1208 on an active field to invoke its action.
+ − 1209 Invoke [+] below to expand a group, and [-] to collapse an expanded group.\n")
+ − 1210 (if custom-browse-only-groups
+ − 1211 (widget-insert "\
+ − 1212 Invoke the [Group] button below to edit that item in another window.\n\n")
+ − 1213 (widget-insert "Invoke the ")
+ − 1214 (widget-create 'item
+ − 1215 :format "%t"
+ − 1216 :tag "[Group]"
+ − 1217 :tag-glyph "folder")
+ − 1218 (widget-insert ", ")
+ − 1219 (widget-create 'item
+ − 1220 :format "%t"
+ − 1221 :tag "[Face]"
+ − 1222 :tag-glyph "face")
+ − 1223 (widget-insert ", and ")
+ − 1224 (widget-create 'item
+ − 1225 :format "%t"
+ − 1226 :tag "[Option]"
+ − 1227 :tag-glyph "option")
+ − 1228 (widget-insert " buttons below to edit that
+ − 1229 item in another window.\n\n"))
+ − 1230 (let ((custom-buffer-style 'tree))
+ − 1231 (widget-create 'custom-group
+ − 1232 :custom-last t
+ − 1233 :custom-state 'unknown
+ − 1234 :tag (custom-unlispify-tag-name group)
+ − 1235 :value group))
+ − 1236 (widget-add-change)
+ − 1237 (goto-char (point-min)))
+ − 1238
+ − 1239 (define-widget 'custom-browse-visibility 'item
2118
+ − 1240 "Control visibility of items in the customize tree browser."
428
+ − 1241 :format "%[[%t]%]"
+ − 1242 :action 'custom-browse-visibility-action)
+ − 1243
+ − 1244 (defun custom-browse-visibility-action (widget &rest ignore)
+ − 1245 (let ((custom-buffer-style 'tree))
+ − 1246 (custom-toggle-parent widget)))
+ − 1247
+ − 1248 (define-widget 'custom-browse-group-tag 'push-button
+ − 1249 "Show parent in other window when activated."
+ − 1250 :tag "Group"
+ − 1251 :tag-glyph "folder"
+ − 1252 :action 'custom-browse-group-tag-action)
+ − 1253
+ − 1254 (defun custom-browse-group-tag-action (widget &rest ignore)
+ − 1255 (let ((parent (widget-get widget :parent)))
+ − 1256 (customize-group-other-window (widget-value parent))))
+ − 1257
+ − 1258 (define-widget 'custom-browse-variable-tag 'push-button
+ − 1259 "Show parent in other window when activated."
+ − 1260 :tag "Option"
+ − 1261 :tag-glyph "option"
+ − 1262 :action 'custom-browse-variable-tag-action)
+ − 1263
+ − 1264 (defun custom-browse-variable-tag-action (widget &rest ignore)
+ − 1265 (let ((parent (widget-get widget :parent)))
+ − 1266 (customize-variable-other-window (widget-value parent))))
+ − 1267
+ − 1268 (define-widget 'custom-browse-face-tag 'push-button
+ − 1269 "Show parent in other window when activated."
+ − 1270 :tag "Face"
+ − 1271 :tag-glyph "face"
+ − 1272 :action 'custom-browse-face-tag-action)
+ − 1273
+ − 1274 (defun custom-browse-face-tag-action (widget &rest ignore)
+ − 1275 (let ((parent (widget-get widget :parent)))
+ − 1276 (customize-face-other-window (widget-value parent))))
+ − 1277
+ − 1278 (defconst custom-browse-alist '((" " "space")
+ − 1279 (" | " "vertical")
+ − 1280 ("-\\ " "top")
+ − 1281 (" |-" "middle")
+ − 1282 (" `-" "bottom")))
+ − 1283
+ − 1284 (defun custom-browse-insert-prefix (prefix)
+ − 1285 "Insert PREFIX. On XEmacs convert it to line graphics."
440
+ − 1286 ;; #### Unfinished.
428
+ − 1287 (if nil ; (string-match "XEmacs" emacs-version)
+ − 1288 (progn
+ − 1289 (insert "*")
+ − 1290 (while (not (string-equal prefix ""))
+ − 1291 (let ((entry (substring prefix 0 3)))
+ − 1292 (setq prefix (substring prefix 3))
+ − 1293 (let ((overlay (make-overlay (1- (point)) (point) nil t nil))
+ − 1294 (name (nth 1 (assoc entry custom-browse-alist))))
+ − 1295 (overlay-put overlay 'end-glyph (widget-glyph-find name entry))
+ − 1296 (overlay-put overlay 'start-open t)
+ − 1297 (overlay-put overlay 'end-open t)))))
+ − 1298 (insert prefix)))
+ − 1299
+ − 1300
+ − 1301 ;;; Modification of Basic Widgets.
+ − 1302 ;;
+ − 1303 ;; We add extra properties to the basic widgets needed here. This is
+ − 1304 ;; fine, as long as we are careful to stay within out own namespace.
+ − 1305 ;;
+ − 1306 ;; We want simple widgets to be displayed by default, but complex
+ − 1307 ;; widgets to be hidden.
+ − 1308
+ − 1309 (widget-put (get 'item 'widget-type) :custom-show t)
+ − 1310 (widget-put (get 'editable-field 'widget-type)
+ − 1311 :custom-show (lambda (widget value)
+ − 1312 ;; This used to call pp-to-string
+ − 1313 (let ((pp (widget-prettyprint-to-string value)))
+ − 1314 (cond ((string-match "\n" pp)
+ − 1315 nil)
+ − 1316 ((> (length pp) 40)
+ − 1317 nil)
+ − 1318 (t t)))))
+ − 1319 (widget-put (get 'menu-choice 'widget-type) :custom-show t)
+ − 1320
+ − 1321 ;;; The `custom-manual' Widget.
+ − 1322
+ − 1323 (define-widget 'custom-manual 'info-link
+ − 1324 "Link to the manual entry for this customization option."
+ − 1325 :tag "Manual")
+ − 1326
+ − 1327 ;;; The `custom-magic' Widget.
+ − 1328
+ − 1329 (defgroup custom-magic-faces nil
+ − 1330 "Faces used by the magic button."
+ − 1331 :group 'custom-faces
+ − 1332 :group 'custom-buffer)
+ − 1333
+ − 1334 (defface custom-invalid-face '((((class color))
+ − 1335 (:foreground "yellow" :background "red"))
+ − 1336 (t
+ − 1337 (:bold t :italic t :underline t)))
+ − 1338 "Face used when the customize item is invalid."
+ − 1339 :group 'custom-magic-faces)
+ − 1340
+ − 1341 (defface custom-rogue-face '((((class color))
+ − 1342 (:foreground "pink" :background "black"))
+ − 1343 (t
+ − 1344 (:underline t)))
+ − 1345 "Face used when the customize item is not defined for customization."
+ − 1346 :group 'custom-magic-faces)
+ − 1347
+ − 1348 (defface custom-modified-face '((((class color))
+ − 1349 (:foreground "white" :background "blue"))
+ − 1350 (t
+ − 1351 (:italic t :bold)))
+ − 1352 "Face used when the customize item has been modified."
+ − 1353 :group 'custom-magic-faces)
+ − 1354
+ − 1355 (defface custom-set-face '((((class color))
+ − 1356 (:foreground "blue" :background "white"))
+ − 1357 (t
+ − 1358 (:italic t)))
+ − 1359 "Face used when the customize item has been set."
+ − 1360 :group 'custom-magic-faces)
+ − 1361
+ − 1362 (defface custom-changed-face '((((class color))
+ − 1363 (:foreground "white" :background "blue"))
+ − 1364 (t
+ − 1365 (:italic t)))
+ − 1366 "Face used when the customize item has been changed."
+ − 1367 :group 'custom-magic-faces)
+ − 1368
+ − 1369 (defface custom-saved-face '((t (:underline t)))
+ − 1370 "Face used when the customize item has been saved."
+ − 1371 :group 'custom-magic-faces)
+ − 1372
+ − 1373 (defconst custom-magic-alist '((nil "#" underline "\
+ − 1374 uninitialized, you should not see this.")
+ − 1375 (unknown "?" italic "\
+ − 1376 unknown, you should not see this.")
+ − 1377 (hidden "-" default "\
+ − 1378 hidden, invoke \"Show\" button in the previous line to show." "\
+ − 1379 group now hidden, invoke the above \"Show\" button to show contents.")
+ − 1380 (invalid "x" custom-invalid-face "\
+ − 1381 the value displayed for this %c is invalid and cannot be set.")
+ − 1382 (modified "*" custom-modified-face "\
+ − 1383 you have edited the value as text, but you have not set the %c." "\
+ − 1384 you have edited something in this group, but not set it.")
+ − 1385 (set "+" custom-set-face "\
+ − 1386 you have set this %c, but not saved it for future sessions." "\
+ − 1387 something in this group has been set, but not saved.")
+ − 1388 (changed ":" custom-changed-face "\
+ − 1389 this %c has been changed outside the customize buffer." "\
+ − 1390 something in this group has been changed outside customize.")
+ − 1391 (saved "!" custom-saved-face "\
+ − 1392 this %c has been set and saved." "\
+ − 1393 something in this group has been set and saved.")
+ − 1394 (rogue "@" custom-rogue-face "\
+ − 1395 this %c has not been changed with customize." "\
+ − 1396 something in this group is not prepared for customization.")
+ − 1397 (standard " " nil "\
+ − 1398 this %c is unchanged from its standard setting." "\
+ − 1399 visible group members are all at standard settings."))
+ − 1400 "Alist of customize option states.
+ − 1401 Each entry is of the form (STATE MAGIC FACE ITEM-DESC [ GROUP-DESC ]), where
+ − 1402
+ − 1403 STATE is one of the following symbols:
+ − 1404
+ − 1405 `nil'
+ − 1406 For internal use, should never occur.
+ − 1407 `unknown'
+ − 1408 For internal use, should never occur.
+ − 1409 `hidden'
+ − 1410 This item is not being displayed.
+ − 1411 `invalid'
+ − 1412 This item is modified, but has an invalid form.
+ − 1413 `modified'
+ − 1414 This item is modified, and has a valid form.
+ − 1415 `set'
+ − 1416 This item has been set but not saved.
+ − 1417 `changed'
+ − 1418 The current value of this item has been changed temporarily.
+ − 1419 `saved'
+ − 1420 This item is marked for saving.
+ − 1421 `rogue'
+ − 1422 This item has no customization information.
+ − 1423 `standard'
+ − 1424 This item is unchanged from the standard setting.
+ − 1425
+ − 1426 MAGIC is a string used to present that state.
+ − 1427
+ − 1428 FACE is a face used to present the state.
+ − 1429
+ − 1430 ITEM-DESC is a string describing the state for options.
+ − 1431
+ − 1432 GROUP-DESC is a string describing the state for groups. If this is
+ − 1433 left out, ITEM-DESC will be used.
+ − 1434
+ − 1435 The string %c in either description will be replaced with the
+ − 1436 category of the item. These are `group'. `option', and `face'.
+ − 1437
+ − 1438 The list should be sorted most significant first.")
+ − 1439
+ − 1440 (defcustom custom-magic-show 'long
+ − 1441 "If non-nil, show textual description of the state.
+ − 1442 If `long', show a full-line description, not just one word."
+ − 1443 :type '(choice (const :tag "no" nil)
+ − 1444 (const short)
+ − 1445 (const long))
+ − 1446 :group 'custom-buffer)
+ − 1447
+ − 1448 (defcustom custom-magic-show-hidden '(option face)
+ − 1449 "Control whether the State button is shown for hidden items.
+ − 1450 The value should be a list with the custom categories where the State
+ − 1451 button should be visible. Possible categories are `group', `option',
+ − 1452 and `face'."
+ − 1453 :type '(set (const group) (const option) (const face))
+ − 1454 :group 'custom-buffer)
+ − 1455
+ − 1456 (defcustom custom-magic-show-button nil
+ − 1457 "Show a \"magic\" button indicating the state of each customization option."
+ − 1458 :type 'boolean
+ − 1459 :group 'custom-buffer)
+ − 1460
+ − 1461 (define-widget 'custom-magic 'default
+ − 1462 "Show and manipulate state for a customization option."
+ − 1463 :format "%v"
+ − 1464 :action 'widget-parent-action
+ − 1465 :notify 'ignore
+ − 1466 :value-get 'ignore
+ − 1467 :value-create 'custom-magic-value-create
+ − 1468 :value-delete 'widget-children-value-delete)
+ − 1469
+ − 1470 (defun widget-magic-mouse-down-action (widget &optional event)
+ − 1471 ;; Non-nil unless hidden.
+ − 1472 (not (eq (widget-get (widget-get (widget-get widget :parent) :parent)
+ − 1473 :custom-state)
+ − 1474 'hidden)))
+ − 1475
+ − 1476 (defun custom-magic-value-create (widget)
+ − 1477 ;; Create compact status report for WIDGET.
+ − 1478 (let* ((parent (widget-get widget :parent))
+ − 1479 (state (widget-get parent :custom-state))
+ − 1480 (hidden (eq state 'hidden))
+ − 1481 (entry (assq state custom-magic-alist))
+ − 1482 (magic (nth 1 entry))
+ − 1483 (face (nth 2 entry))
+ − 1484 (category (widget-get parent :custom-category))
+ − 1485 (text (or (and (eq category 'group)
+ − 1486 (nth 4 entry))
+ − 1487 (nth 3 entry)))
+ − 1488 (form (widget-get parent :custom-form))
+ − 1489 children)
+ − 1490 (while (string-match "\\`\\(.*\\)%c\\(.*\\)\\'" text)
+ − 1491 (setq text (concat (match-string 1 text)
+ − 1492 (symbol-name category)
+ − 1493 (match-string 2 text))))
+ − 1494 (when (and custom-magic-show
+ − 1495 (or (not hidden)
+ − 1496 (memq category custom-magic-show-hidden)))
+ − 1497 (insert " ")
+ − 1498 (when (and (eq category 'group)
+ − 1499 (not (and (eq custom-buffer-style 'links)
+ − 1500 (> (widget-get parent :custom-level) 1))))
+ − 1501 (insert-char ?\ (* custom-buffer-indent
+ − 1502 (widget-get parent :custom-level))))
+ − 1503 (push (widget-create-child-and-convert
+ − 1504 widget 'choice-item
+ − 1505 :help-echo "Change the state of this item"
+ − 1506 :format (if hidden "%t" "%[%t%]")
+ − 1507 :button-prefix 'widget-push-button-prefix
+ − 1508 :button-suffix 'widget-push-button-suffix
+ − 1509 :mouse-down-action 'widget-magic-mouse-down-action
+ − 1510 :tag "State"
+ − 1511 ;;:tag-glyph (or hidden '("state-up" "state-down"))
+ − 1512 )
+ − 1513 children)
+ − 1514 (insert ": ")
+ − 1515 (let ((start (point)))
+ − 1516 (if (eq custom-magic-show 'long)
+ − 1517 (insert text)
+ − 1518 (insert (symbol-name state)))
+ − 1519 (cond ((eq form 'lisp)
+ − 1520 (insert " (lisp)"))
+ − 1521 ((eq form 'mismatch)
+ − 1522 (insert " (mismatch)")))
+ − 1523 (put-text-property start (point) 'face 'custom-state-face))
+ − 1524 (insert "\n"))
+ − 1525 (when (and (eq category 'group)
+ − 1526 (not (and (eq custom-buffer-style 'links)
+ − 1527 (> (widget-get parent :custom-level) 1))))
+ − 1528 (insert-char ?\ (* custom-buffer-indent
+ − 1529 (widget-get parent :custom-level))))
+ − 1530 (when custom-magic-show-button
+ − 1531 (when custom-magic-show
+ − 1532 (let ((indent (widget-get parent :indent)))
+ − 1533 (when indent
+ − 1534 (insert-char ?\ indent))))
+ − 1535 (push (widget-create-child-and-convert
+ − 1536 widget 'choice-item
+ − 1537 :mouse-down-action 'widget-magic-mouse-down-action
+ − 1538 :button-face face
+ − 1539 :button-prefix ""
+ − 1540 :button-suffix ""
+ − 1541 :help-echo "Change the state"
+ − 1542 :format (if hidden "%t" "%[%t%]")
+ − 1543 :tag (if (memq form '(lisp mismatch))
+ − 1544 (concat "(" magic ")")
+ − 1545 (concat "[" magic "]")))
+ − 1546 children)
+ − 1547 (insert " "))
+ − 1548 (widget-put widget :children children)))
+ − 1549
+ − 1550 (defun custom-magic-reset (widget)
+ − 1551 "Redraw the :custom-magic property of WIDGET."
+ − 1552 (let ((magic (widget-get widget :custom-magic)))
+ − 1553 (widget-value-set magic (widget-value magic))))
+ − 1554
+ − 1555 ;;; The `custom' Widget.
+ − 1556
+ − 1557 (defface custom-button-face '((t (:bold t)))
+ − 1558 "Face used for buttons in customization buffers."
+ − 1559 :group 'custom-faces)
+ − 1560
+ − 1561 (defface custom-documentation-face nil
+ − 1562 "Face used for documentation strings in customization buffers."
+ − 1563 :group 'custom-faces)
+ − 1564
+ − 1565 (defface custom-state-face '((((class color)
+ − 1566 (background dark))
+ − 1567 (:foreground "lime green"))
+ − 1568 (((class color)
+ − 1569 (background light))
+ − 1570 (:foreground "dark green"))
+ − 1571 (t nil))
+ − 1572 "Face used for State descriptions in the customize buffer."
+ − 1573 :group 'custom-faces)
+ − 1574
+ − 1575 (define-widget 'custom 'default
+ − 1576 "Customize a user option."
+ − 1577 :format "%v"
+ − 1578 :convert-widget 'custom-convert-widget
+ − 1579 :notify 'custom-notify
+ − 1580 :custom-prefix ""
+ − 1581 :custom-level 1
+ − 1582 :custom-state 'hidden
+ − 1583 :documentation-property 'widget-subclass-responsibility
+ − 1584 :value-create 'widget-subclass-responsibility
+ − 1585 :value-delete 'widget-children-value-delete
+ − 1586 :value-get 'widget-value-value-get
+ − 1587 :validate 'widget-children-validate
+ − 1588 :match (lambda (widget value) (symbolp value)))
+ − 1589
+ − 1590 (defun custom-convert-widget (widget)
+ − 1591 ;; Initialize :value and :tag from :args in WIDGET.
+ − 1592 (let ((args (widget-get widget :args)))
+ − 1593 (when args
+ − 1594 (widget-put widget :value (widget-apply widget
+ − 1595 :value-to-internal (car args)))
+ − 1596 (widget-put widget :tag (custom-unlispify-tag-name (car args)))
+ − 1597 (widget-put widget :args nil)))
+ − 1598 widget)
+ − 1599
+ − 1600 (defun custom-notify (widget &rest args)
+ − 1601 "Keep track of changes."
+ − 1602 (let ((state (widget-get widget :custom-state)))
+ − 1603 (unless (eq state 'modified)
+ − 1604 (unless (memq state '(nil unknown hidden))
+ − 1605 (widget-put widget :custom-state 'modified))
+ − 1606 (custom-magic-reset widget)
+ − 1607 (apply 'widget-default-notify widget args))))
+ − 1608
+ − 1609 (defun custom-redraw (widget)
+ − 1610 "Redraw WIDGET with current settings."
+ − 1611 (let ((line (count-lines (point-min) (point)))
+ − 1612 (column (current-column))
+ − 1613 (pos (point))
+ − 1614 (from (marker-position (widget-get widget :from)))
+ − 1615 (to (marker-position (widget-get widget :to))))
+ − 1616 (save-excursion
+ − 1617 (widget-value-set widget (widget-value widget))
+ − 1618 (custom-redraw-magic widget))
+ − 1619 (when (and (>= pos from) (<= pos to))
+ − 1620 (condition-case nil
+ − 1621 (progn
+ − 1622 (if (> column 0)
+ − 1623 (goto-line line)
+ − 1624 (goto-line (1+ line)))
+ − 1625 (move-to-column column))
+ − 1626 (error nil)))))
+ − 1627
+ − 1628 (defun custom-redraw-magic (widget)
+ − 1629 "Redraw WIDGET state with current settings."
+ − 1630 (while widget
+ − 1631 (let ((magic (widget-get widget :custom-magic)))
+ − 1632 (cond (magic
+ − 1633 (widget-value-set magic (widget-value magic))
+ − 1634 (when (setq widget (widget-get widget :group))
+ − 1635 (custom-group-state-update widget)))
+ − 1636 (t
+ − 1637 (setq widget nil)))))
+ − 1638 (widget-setup))
+ − 1639
+ − 1640 (defun custom-show (widget value)
+ − 1641 "Non-nil if WIDGET should be shown with VALUE by default."
+ − 1642 (let ((show (widget-get widget :custom-show)))
+ − 1643 (cond ((null show)
+ − 1644 nil)
+ − 1645 ((eq t show)
+ − 1646 t)
+ − 1647 (t
+ − 1648 (funcall show widget value)))))
+ − 1649
+ − 1650 (defvar custom-load-recursion nil
+ − 1651 "Hack to avoid recursive dependencies.")
+ − 1652
+ − 1653 (defun custom-load-symbol (symbol)
+ − 1654 "Load all dependencies for SYMBOL."
+ − 1655 (unless custom-load-recursion
+ − 1656 (let ((custom-load-recursion t)
+ − 1657 (loads (get symbol 'custom-loads))
+ − 1658 load)
+ − 1659 (while loads
+ − 1660 (setq load (car loads)
+ − 1661 loads (cdr loads))
2544
+ − 1662 (custom-load-symbol-1 load)))))
+ − 1663
+ − 1664 (defun custom-load-symbol-1 (load)
+ − 1665 (cond ((symbolp load)
+ − 1666 (condition-case nil
+ − 1667 (require load)
+ − 1668 (error nil)))
+ − 1669 ;; Don't reload a file already loaded.
+ − 1670 ((and (boundp 'preloaded-file-list)
+ − 1671 (member load preloaded-file-list)))
+ − 1672 ((assoc load load-history))
+ − 1673 ((assoc (locate-library load) load-history))
+ − 1674 (t
+ − 1675 (condition-case nil
+ − 1676 ;; Without this, we would load cus-edit recursively.
+ − 1677 ;; We are still loading it when we call this,
+ − 1678 ;; and it is not in load-history yet.
+ − 1679 (or (equal load "cus-edit")
+ − 1680 (load-library load))
+ − 1681 (error nil)))))
+ − 1682
+ − 1683 (defvar custom-already-loaded-custom-defines nil
+ − 1684 "List of already-loaded `custom-defines' files.")
+ − 1685 (defvar custom-define-current-source-file nil)
+ − 1686 (defvar custom-warn-when-reloading-necessary nil
+ − 1687 "For package-debugging purposes: Warn when an error hit in custom-defines.el.
+ − 1688 When this happens, the file from which the defcustom or defgroup was taken
+ − 1689 is loaded, and custom-defines.el is then reloaded. This works in most
+ − 1690 cases, but may not be completely safe. It's better if the package itself
+ − 1691 arranges for the necessary functions and variables to be available, using
+ − 1692 \;;;###autoload declarations. When this variable is non-nil, warnings are
+ − 1693 issued (with backtrace), to aid in tracking down the problems.")
+ − 1694
+ − 1695 (defun custom-load-custom-defines (symbol)
+ − 1696 "Load custom-defines for SYMBOL."
+ − 1697 (unless custom-load-recursion
+ − 1698 (let ((custom-load-recursion t)
+ − 1699 (loads (get symbol 'custom-loads))
+ − 1700 load)
+ − 1701 (while loads
+ − 1702 (setq load (car loads)
+ − 1703 loads (cdr loads))
+ − 1704 (let* ((found (locate-library
+ − 1705 (if (symbolp load) (symbol-name load) load)))
+ − 1706 (dir (and found (file-name-directory found))))
+ − 1707 ;; If we find a custom-defines file, assume the package is smart
+ − 1708 ;; enough to have put all its defcustoms and defgroups here, and
+ − 1709 ;; load it instead of the file itself. Otherwise, do it the
+ − 1710 ;; hard way.
+ − 1711 (if (and found (or (file-exists-p
+ − 1712 (expand-file-name "custom-defines.elc" dir))
+ − 1713 (file-exists-p
+ − 1714 (expand-file-name "custom-defines.el" dir))))
+ − 1715 (when (not (member dir custom-already-loaded-custom-defines))
+ − 1716 (push dir custom-already-loaded-custom-defines)
+ − 1717 (custom-load-custom-defines-1 dir))))))))
+ − 1718
+ − 1719 (defun custom-load-custom-defines-1 (dir)
+ − 1720 ;; Actually load the custom-defines.el file in DIR.
+ − 1721
+ − 1722 ;; If we get an error loading the custom-defines, it may be because of a
+ − 1723 ;; reference to something (e.g. a constant) that hasn't yet been defined
+ − 1724 ;; yet. Properly, these should have been marked, so they either go into
+ − 1725 ;; the custom-defines.el file or are autoloaded. But not everyone is so
+ − 1726 ;; careful, so for the moment we try to load the file that the
+ − 1727 ;; error-generating defcustom came from, and then reload the
+ − 1728 ;; custom-defines.el file. We might loop a number of times if we have
+ − 1729 ;; various files that need loading. If at any point we get an error that
+ − 1730 ;; can't be solved just by loading the appropriate file (e.g. we hit the
+ − 1731 ;; same error as before, the file is already loaded, etc.) then we signal
+ − 1732 ;; it as a real error.
+ − 1733 (let (source)
+ − 1734 ;; here's how this works: if we get an error loading custom-defines,
+ − 1735 ;; the condition handler is called; if we need to reload, we
+ − 1736 ;; `return-from', which throws out of the handler and returns nil from
+ − 1737 ;; the `block', which continues the while statement, executing the
+ − 1738 ;; `load' at the bottom of this function and then entering the block
+ − 1739 ;; again. if the condition handler doesn't throw, but instead returns
+ − 1740 ;; normally, `signal' will continue as if nothing happened, and end up
+ − 1741 ;; signalling the error normally.
+ − 1742 (while
+ − 1743 (not
+ − 1744 (block custom-load
+ − 1745 ;; Use call-with-condition-handler so the error can be seen
+ − 1746 ;; with the stack intact.
+ − 1747 (call-with-condition-handler
+ − 1748 #'(lambda (__custom_load_cd1__)
+ − 1749 (when (and
+ − 1750 custom-define-current-source-file
+ − 1751 (progn
+ − 1752 (setq source (expand-file-name
+ − 1753 custom-define-current-source-file
+ − 1754 dir))
+ − 1755 (let ((nondir (file-name-nondirectory source)))
+ − 1756 (and (file-exists-p source)
+ − 1757 (not (assoc source load-history))
+ − 1758 (not (assoc nondir load-history))
+ − 1759 (not (and (boundp 'preloaded-file-list)
+ − 1760 (member nondir
+ − 1761 preloaded-file-list)))))))
+ − 1762 (if custom-warn-when-reloading-necessary
+ − 1763 (lwarn 'custom-defines 'warning
+ − 1764 "Error while loading custom-defines, fetching source and reloading ...\n
+ − 1765 Error: %s\n
+ − 1766 Source file: %s\n\n
+ − 1767 Backtrace follows:\n\n%s"
+ − 1768 (error-message-string __custom_load_cd1__)
+ − 1769 source
+ − 1770 (backtrace-in-condition-handler-eliminating-handler
+ − 1771 '__custom_load_cd1__)))
+ − 1772 (return-from custom-load nil)))
+ − 1773 #'(lambda ()
+ − 1774 (load (expand-file-name "custom-defines" dir))))))
4178
+ − 1775 ;; we get here only from the `return-from'; see above
2544
+ − 1776 (load source))))
428
+ − 1777
+ − 1778 (defun custom-load-widget (widget)
+ − 1779 "Load all dependencies for WIDGET."
+ − 1780 (custom-load-symbol (widget-value widget)))
+ − 1781
+ − 1782 (defun custom-unloaded-symbol-p (symbol)
+ − 1783 "Return non-nil if the dependencies of SYMBOL has not yet been loaded."
+ − 1784 (let ((found nil)
+ − 1785 (loads (get symbol 'custom-loads))
+ − 1786 load)
+ − 1787 (while loads
+ − 1788 (setq load (car loads)
+ − 1789 loads (cdr loads))
+ − 1790 (cond ((symbolp load)
+ − 1791 (unless (featurep load)
+ − 1792 (setq found t)))
+ − 1793 ((assoc load load-history))
+ − 1794 ((assoc (locate-library load) load-history)
+ − 1795 ;; #### WTF???
+ − 1796 (message nil))
+ − 1797 (t
+ − 1798 (setq found t))))
+ − 1799 found))
+ − 1800
+ − 1801 (defun custom-unloaded-widget-p (widget)
+ − 1802 "Return non-nil if the dependencies of WIDGET has not yet been loaded."
+ − 1803 (custom-unloaded-symbol-p (widget-value widget)))
+ − 1804
+ − 1805 (defun custom-toggle-hide (widget)
+ − 1806 "Toggle visibility of WIDGET."
+ − 1807 (custom-load-widget widget)
+ − 1808 (let ((state (widget-get widget :custom-state)))
+ − 1809 (cond ((memq state '(invalid modified))
+ − 1810 (error "There are unset changes"))
+ − 1811 ((eq state 'hidden)
+ − 1812 (widget-put widget :custom-state 'unknown))
+ − 1813 (t
+ − 1814 (widget-put widget :documentation-shown nil)
+ − 1815 (widget-put widget :custom-state 'hidden)))
+ − 1816 (custom-redraw widget)
+ − 1817 (widget-setup)))
+ − 1818
+ − 1819 (defun custom-toggle-parent (widget &rest ignore)
+ − 1820 "Toggle visibility of parent of WIDGET."
+ − 1821 (custom-toggle-hide (widget-get widget :parent)))
+ − 1822
+ − 1823 (defun custom-add-see-also (widget &optional prefix)
+ − 1824 "Add `See also ...' to WIDGET if there are any links.
+ − 1825 Insert PREFIX first if non-nil."
+ − 1826 (let* ((symbol (widget-get widget :value))
+ − 1827 (links (get symbol 'custom-links))
+ − 1828 (many (> (length links) 2))
+ − 1829 (buttons (widget-get widget :buttons))
+ − 1830 (indent (widget-get widget :indent)))
+ − 1831 (when links
+ − 1832 (when indent
+ − 1833 (insert-char ?\ indent))
+ − 1834 (when prefix
+ − 1835 (insert prefix))
+ − 1836 (insert "See also ")
+ − 1837 (while links
+ − 1838 (push (widget-create-child-and-convert widget (car links))
+ − 1839 buttons)
+ − 1840 (setq links (cdr links))
+ − 1841 (cond ((null links)
+ − 1842 (insert ".\n"))
+ − 1843 ((null (cdr links))
+ − 1844 (if many
+ − 1845 (insert ", and ")
+ − 1846 (insert " and ")))
+ − 1847 (t
+ − 1848 (insert ", "))))
+ − 1849 (widget-put widget :buttons buttons))))
+ − 1850
+ − 1851 (defun custom-add-parent-links (widget &optional initial-string)
+ − 1852 "Add \"Parent groups: ...\" to WIDGET if the group has parents.
+ − 1853 The value if non-nil if any parents were found.
+ − 1854 If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"."
+ − 1855 (let ((name (widget-value widget))
+ − 1856 (type (widget-type widget))
+ − 1857 (buttons (widget-get widget :buttons))
+ − 1858 (start (point))
+ − 1859 found)
+ − 1860 (insert (or initial-string "Parent groups:"))
+ − 1861 (maphash (lambda (group ignore)
+ − 1862 (let ((entry (assq name (get group 'custom-group))))
+ − 1863 (when (eq (nth 1 entry) type)
+ − 1864 (insert " ")
+ − 1865 (push (widget-create-child-and-convert
+ − 1866 widget 'custom-group-link
+ − 1867 :tag (custom-unlispify-tag-name group)
+ − 1868 group)
+ − 1869 buttons)
+ − 1870 (setq found t))))
+ − 1871 custom-group-hash-table)
+ − 1872 (widget-put widget :buttons buttons)
+ − 1873 (if found
+ − 1874 (insert "\n")
+ − 1875 (delete-region start (point)))
+ − 1876 found))
+ − 1877
+ − 1878 ;;; The `custom-comment' Widget.
+ − 1879
+ − 1880 ;; like the editable field
+ − 1881 (defface custom-comment-face '((((class grayscale color)
+ − 1882 (background light))
+ − 1883 (:background "gray85"))
+ − 1884 (((class grayscale color)
+ − 1885 (background dark))
+ − 1886 (:background "dim gray"))
+ − 1887 (t
+ − 1888 (:italic t)))
+ − 1889 "Face used for comments on variables or faces"
+ − 1890 :group 'custom-faces)
+ − 1891
+ − 1892 ;; like font-lock-comment-face
+ − 1893 (defface custom-comment-tag-face
+ − 1894 '((((class color) (background dark)) (:foreground "gray80"))
+ − 1895 (((class color) (background light)) (:foreground "blue4"))
+ − 1896 (((class grayscale) (background light))
+ − 1897 (:foreground "DimGray" :bold t :italic t))
+ − 1898 (((class grayscale) (background dark))
+ − 1899 (:foreground "LightGray" :bold t :italic t))
+ − 1900 (t (:bold t)))
+ − 1901 "Face used for variables or faces comment tags"
+ − 1902 :group 'custom-faces)
+ − 1903
+ − 1904 (define-widget 'custom-comment 'string
+ − 1905 "User comment"
+ − 1906 :tag "Comment"
+ − 1907 :help-echo "Edit a comment here"
+ − 1908 :sample-face 'custom-comment-tag-face
+ − 1909 :value-face 'custom-comment-face
+ − 1910 :value-set 'custom-comment-value-set
+ − 1911 :create 'custom-comment-create
+ − 1912 :delete 'custom-comment-delete)
+ − 1913
+ − 1914 (defun custom-comment-create (widget)
+ − 1915 (let (ext)
+ − 1916 (widget-default-create widget)
+ − 1917 (widget-put widget :comment-extent
+ − 1918 (setq ext (make-extent (widget-get widget :from)
+ − 1919 (widget-get widget :to))))
+ − 1920 (set-extent-property ext 'start-open t)
+ − 1921 (when (equal (widget-get widget :value) "")
+ − 1922 (set-extent-property ext 'invisible t))
+ − 1923 ))
+ − 1924
+ − 1925 (defun custom-comment-delete (widget)
+ − 1926 (widget-default-delete widget)
+ − 1927 (delete-extent (widget-get widget :comment-extent)))
+ − 1928
+ − 1929 (defun custom-comment-value-set (widget value)
+ − 1930 (widget-default-value-set widget value)
+ − 1931 (if (equal value "")
+ − 1932 (set-extent-property (widget-get widget :comment-extent)
+ − 1933 'invisible t)
+ − 1934 (set-extent-property (widget-get widget :comment-extent)
+ − 1935 'invisible nil)))
+ − 1936
+ − 1937 ;; Those functions are for the menu. WIDGET is NOT the comment widget. It's
+ − 1938 ;; the global custom one
+ − 1939 (defun custom-comment-show (widget)
+ − 1940 (set-extent-property
+ − 1941 (widget-get (widget-get widget :comment-widget) :comment-extent)
+ − 1942 'invisible nil))
+ − 1943
+ − 1944 (defun custom-comment-invisible-p (widget)
+ − 1945 (extent-property
+ − 1946 (widget-get (widget-get widget :comment-widget) :comment-extent)
+ − 1947 'invisible))
+ − 1948
+ − 1949 ;;; The `custom-variable' Widget.
+ − 1950
+ − 1951 (defface custom-variable-tag-face '((((class color)
+ − 1952 (background dark))
+ − 1953 (:foreground "light blue" :underline t))
+ − 1954 (((class color)
+ − 1955 (background light))
+ − 1956 (:foreground "blue" :underline t))
+ − 1957 (t (:underline t)))
+ − 1958 "Face used for unpushable variable tags."
+ − 1959 :group 'custom-faces)
+ − 1960
+ − 1961 (defface custom-variable-button-face '((t (:underline t :bold t)))
+ − 1962 "Face used for pushable variable tags."
+ − 1963 :group 'custom-faces)
+ − 1964
+ − 1965 (defcustom custom-variable-default-form 'edit
+ − 1966 "Default form of displaying variable values."
+ − 1967 :type '(choice (const edit)
+ − 1968 (const lisp))
+ − 1969 :group 'custom-buffer)
+ − 1970
+ − 1971 (define-widget 'custom-variable 'custom
+ − 1972 "Customize variable."
+ − 1973 :format "%v"
+ − 1974 :help-echo "Set or reset this variable"
+ − 1975 :documentation-property 'variable-documentation
+ − 1976 :custom-category 'option
+ − 1977 :custom-state nil
+ − 1978 :custom-menu 'custom-variable-menu-create
+ − 1979 :custom-form nil ; defaults to value of `custom-variable-default-form'
+ − 1980 :value-create 'custom-variable-value-create
+ − 1981 :action 'custom-variable-action
+ − 1982 :custom-set 'custom-variable-set
480
+ − 1983 :custom-pre-save 'custom-variable-pre-save
428
+ − 1984 :custom-save 'custom-variable-save
480
+ − 1985 :custom-post-save 'custom-variable-post-save
428
+ − 1986 :custom-reset-current 'custom-redraw
+ − 1987 :custom-reset-saved 'custom-variable-reset-saved
480
+ − 1988 :custom-pre-reset-standard 'custom-variable-pre-reset-standard
+ − 1989 :custom-reset-standard 'custom-variable-reset-standard
+ − 1990 :custom-post-reset-standard 'custom-variable-post-reset-standard)
428
+ − 1991
+ − 1992 (defun custom-variable-type (symbol)
+ − 1993 "Return a widget suitable for editing the value of SYMBOL.
+ − 1994 If SYMBOL has a `custom-type' property, use that.
+ − 1995 Otherwise, look up symbol in `custom-guess-type-alist'."
+ − 1996 (let* ((type (or (get symbol 'custom-type)
+ − 1997 (and (not (get symbol 'standard-value))
+ − 1998 (custom-guess-type symbol))
+ − 1999 'sexp))
+ − 2000 (options (get symbol 'custom-options))
+ − 2001 (tmp (if (listp type)
+ − 2002 (copy-sequence type)
+ − 2003 (list type))))
+ − 2004 (when options
+ − 2005 (widget-put tmp :options options))
+ − 2006 tmp))
+ − 2007
+ − 2008 (defun custom-variable-value-create (widget)
+ − 2009 "Here is where you edit the variables value."
+ − 2010 (custom-load-widget widget)
+ − 2011 (unless (widget-get widget :custom-form)
+ − 2012 (widget-put widget :custom-form custom-variable-default-form))
+ − 2013 (let* ((buttons (widget-get widget :buttons))
+ − 2014 (children (widget-get widget :children))
+ − 2015 (form (widget-get widget :custom-form))
+ − 2016 (state (widget-get widget :custom-state))
+ − 2017 (symbol (widget-get widget :value))
+ − 2018 (tag (widget-get widget :tag))
+ − 2019 (type (custom-variable-type symbol))
+ − 2020 (conv (widget-convert type))
+ − 2021 (get (or (get symbol 'custom-get) 'default-value))
+ − 2022 (prefix (widget-get widget :custom-prefix))
+ − 2023 (last (widget-get widget :custom-last))
+ − 2024 (value (if (default-boundp symbol)
+ − 2025 (funcall get symbol)
+ − 2026 (widget-get conv :value))))
+ − 2027 ;; If the widget is new, the child determine whether it is hidden.
+ − 2028 (cond (state)
+ − 2029 ((custom-show type value)
+ − 2030 (setq state 'unknown))
+ − 2031 (t
+ − 2032 (setq state 'hidden)))
+ − 2033 ;; If we don't know the state, see if we need to edit it in lisp form.
+ − 2034 (when (eq state 'unknown)
+ − 2035 (unless (widget-apply conv :match value)
+ − 2036 ;; (widget-apply (widget-convert type) :match value)
+ − 2037 (setq form 'mismatch)))
+ − 2038 ;; Now we can create the child widget.
+ − 2039 (cond ((eq custom-buffer-style 'tree)
+ − 2040 (insert prefix (if last " `--- " " |--- "))
+ − 2041 (push (widget-create-child-and-convert
+ − 2042 widget 'custom-browse-variable-tag)
+ − 2043 buttons)
+ − 2044 (insert " " tag "\n")
+ − 2045 (widget-put widget :buttons buttons))
+ − 2046 ((eq state 'hidden)
+ − 2047 ;; Indicate hidden value.
+ − 2048 (push (widget-create-child-and-convert
+ − 2049 widget 'item
+ − 2050 :format "%{%t%}: "
+ − 2051 :sample-face 'custom-variable-tag-face
+ − 2052 :tag tag
+ − 2053 :parent widget)
+ − 2054 buttons)
+ − 2055 (push (widget-create-child-and-convert
+ − 2056 widget 'visibility
+ − 2057 :help-echo "Show the value of this option"
+ − 2058 :action 'custom-toggle-parent
+ − 2059 nil)
+ − 2060 buttons))
+ − 2061 ((memq form '(lisp mismatch))
+ − 2062 ;; In lisp mode edit the saved value when possible.
+ − 2063 (let* ((value (cond ((get symbol 'saved-value)
+ − 2064 (car (get symbol 'saved-value)))
+ − 2065 ((get symbol 'standard-value)
+ − 2066 (car (get symbol 'standard-value)))
+ − 2067 ((default-boundp symbol)
+ − 2068 (custom-quote (funcall get symbol)))
+ − 2069 (t
+ − 2070 (custom-quote (widget-get conv :value))))))
+ − 2071 (insert (symbol-name symbol) ": ")
+ − 2072 (push (widget-create-child-and-convert
+ − 2073 widget 'visibility
+ − 2074 :help-echo "Hide the value of this option"
+ − 2075 :action 'custom-toggle-parent
+ − 2076 t)
+ − 2077 buttons)
+ − 2078 (insert " ")
+ − 2079 (push (widget-create-child-and-convert
+ − 2080 widget 'sexp
+ − 2081 :button-face 'custom-variable-button-face
+ − 2082 :format "%v"
+ − 2083 :tag (symbol-name symbol)
+ − 2084 :parent widget
+ − 2085 :value value)
+ − 2086 children)))
+ − 2087 (t
+ − 2088 ;; Edit mode.
+ − 2089 (let* ((format (widget-get type :format))
+ − 2090 tag-format value-format)
+ − 2091 (while (not (string-match ":" format))
+ − 2092 (setq format (signal 'error (list "Bad format" format))))
+ − 2093 (setq tag-format (substring format 0 (match-end 0)))
+ − 2094 (setq value-format (substring format (match-end 0)))
+ − 2095 (push (widget-create-child-and-convert
+ − 2096 widget 'item
+ − 2097 :format tag-format
+ − 2098 :action 'custom-tag-action
+ − 2099 :help-echo "Change value of this option"
+ − 2100 :mouse-down-action 'custom-tag-mouse-down-action
+ − 2101 :button-face 'custom-variable-button-face
+ − 2102 :sample-face 'custom-variable-tag-face
+ − 2103 tag)
+ − 2104 buttons)
+ − 2105 (insert " ")
+ − 2106 (push (widget-create-child-and-convert
+ − 2107 widget 'visibility
+ − 2108 :help-echo "Hide the value of this option"
+ − 2109 :action 'custom-toggle-parent
+ − 2110 t)
+ − 2111 buttons)
+ − 2112 (push (widget-create-child-and-convert
+ − 2113 widget type
+ − 2114 :format value-format
+ − 2115 :value value)
+ − 2116 children))))
+ − 2117 (unless (eq custom-buffer-style 'tree)
+ − 2118 (unless (eq (preceding-char) ?\n)
+ − 2119 (widget-insert "\n"))
+ − 2120 ;; Create the magic button.
+ − 2121 (let ((magic (widget-create-child-and-convert
+ − 2122 widget 'custom-magic nil)))
+ − 2123 (widget-put widget :custom-magic magic)
+ − 2124 (push magic buttons))
+ − 2125 ;; Insert documentation.
440
+ − 2126 ;; #### NOTE: this is ugly!!!! I need to do update the :buttons property
428
+ − 2127 ;; before the call to `widget-default-format-handler'. Otherwise, I
444
+ − 2128 ;; lose my current `buttons'. This function shouldn't be called like
428
+ − 2129 ;; this anyway. The doc string widget should be added like the others.
+ − 2130 ;; --dv
+ − 2131 (widget-put widget :buttons buttons)
+ − 2132 (widget-default-format-handler widget ?h)
+ − 2133 ;; The comment field
+ − 2134 (unless (eq state 'hidden)
+ − 2135 (let* ((comment (get symbol 'variable-comment))
+ − 2136 (comment-widget
+ − 2137 (widget-create-child-and-convert
+ − 2138 widget 'custom-comment
+ − 2139 :parent widget
+ − 2140 :value (or comment ""))))
+ − 2141 (widget-put widget :comment-widget comment-widget)
+ − 2142 ;; Don't push it !!! Custom assumes that the first child is the
+ − 2143 ;; value one.
+ − 2144 (setq children (append children (list comment-widget)))))
2118
+ − 2145 ;; Update the rest of the properties.
428
+ − 2146 (widget-put widget :custom-form form)
+ − 2147 (widget-put widget :children children)
+ − 2148 ;; Now update the state.
+ − 2149 (if (eq state 'hidden)
+ − 2150 (widget-put widget :custom-state state)
+ − 2151 (custom-variable-state-set widget))
+ − 2152 ;; See also.
+ − 2153 (unless (eq state 'hidden)
+ − 2154 (when (eq (widget-get widget :custom-level) 1)
+ − 2155 (custom-add-parent-links widget))
+ − 2156 (custom-add-see-also widget)))))
+ − 2157
+ − 2158 (defun custom-tag-action (widget &rest args)
+ − 2159 "Pass :action to first child of WIDGET's parent."
+ − 2160 (apply 'widget-apply (car (widget-get (widget-get widget :parent) :children))
+ − 2161 :action args))
+ − 2162
+ − 2163 (defun custom-tag-mouse-down-action (widget &rest args)
+ − 2164 "Pass :mouse-down-action to first child of WIDGET's parent."
+ − 2165 (apply 'widget-apply (car (widget-get (widget-get widget :parent) :children))
+ − 2166 :mouse-down-action args))
+ − 2167
+ − 2168 (defun custom-variable-state-set (widget)
+ − 2169 "Set the state of WIDGET."
+ − 2170 (let* ((symbol (widget-value widget))
+ − 2171 (get (or (get symbol 'custom-get) 'default-value))
+ − 2172 (value (if (default-boundp symbol)
+ − 2173 (funcall get symbol)
+ − 2174 (widget-get widget :value)))
+ − 2175 (comment (get symbol 'variable-comment))
+ − 2176 tmp
+ − 2177 temp
+ − 2178 (state (cond ((progn (setq tmp (get symbol 'customized-value))
+ − 2179 (setq temp
+ − 2180 (get symbol 'customized-variable-comment))
+ − 2181 (or tmp temp))
+ − 2182 (if (condition-case nil
+ − 2183 (and (equal value (eval (car tmp)))
+ − 2184 (equal comment temp))
+ − 2185 (error nil))
+ − 2186 'set
+ − 2187 'changed))
+ − 2188 ((progn (setq tmp (get symbol 'saved-value))
+ − 2189 (setq temp (get symbol 'saved-variable-comment))
+ − 2190 (or tmp temp))
+ − 2191 (if (condition-case nil
+ − 2192 (and (equal value (eval (car tmp)))
+ − 2193 (equal comment temp))
+ − 2194 (error nil))
+ − 2195 'saved
+ − 2196 'changed))
+ − 2197 ((setq tmp (get symbol 'standard-value))
+ − 2198 (if (condition-case nil
+ − 2199 (and (equal value (eval (car tmp)))
+ − 2200 (equal comment nil))
+ − 2201 (error nil))
+ − 2202 'standard
+ − 2203 'changed))
+ − 2204 (t 'rogue))))
+ − 2205 (widget-put widget :custom-state state)))
+ − 2206
+ − 2207 (defvar custom-variable-menu
4289
+ − 2208 `(("Set for Current Session" custom-variable-set
+ − 2209 ,#'(lambda (widget)
+ − 2210 (eq (widget-get widget :custom-state) 'modified)))
428
+ − 2211 ("Save for Future Sessions" custom-variable-save
4289
+ − 2212 ,#'(lambda (widget)
+ − 2213 (memq (widget-get widget :custom-state)
+ − 2214 '(modified set changed rogue))))
428
+ − 2215 ("Reset to Current" custom-redraw
4289
+ − 2216 ,#'(lambda (widget)
+ − 2217 (and (default-boundp (widget-value widget))
+ − 2218 (memq (widget-get widget :custom-state) '(modified changed)))))
428
+ − 2219 ("Reset to Saved" custom-variable-reset-saved
4289
+ − 2220 ,#'(lambda (widget)
+ − 2221 (and (or (get (widget-value widget) 'saved-value)
+ − 2222 (get (widget-value widget) 'saved-variable-comment))
+ − 2223 (memq (widget-get widget :custom-state)
+ − 2224 '(modified set changed rogue)))))
428
+ − 2225 ("Reset to Standard Settings" custom-variable-reset-standard
4289
+ − 2226 ,#'(lambda (widget)
+ − 2227 (and (get (widget-value widget) 'standard-value)
+ − 2228 (memq (widget-get widget :custom-state)
+ − 2229 '(modified set changed saved rogue)))))
428
+ − 2230 ("---" ignore ignore)
+ − 2231 ("Add Comment" custom-comment-show custom-comment-invisible-p)
+ − 2232 ("---" ignore ignore)
+ − 2233 ("Don't show as Lisp expression" custom-variable-edit
4289
+ − 2234 ,#'(lambda (widget)
+ − 2235 (eq (widget-get widget :custom-form) 'lisp)))
428
+ − 2236 ("Show as Lisp expression" custom-variable-edit-lisp
4289
+ − 2237 ,#'(lambda (widget)
+ − 2238 (eq (widget-get widget :custom-form) 'edit))))
428
+ − 2239 "Alist of actions for the `custom-variable' widget.
+ − 2240 Each entry has the form (NAME ACTION FILTER) where NAME is the name of
+ − 2241 the menu entry, ACTION is the function to call on the widget when the
+ − 2242 menu is selected, and FILTER is a predicate which takes a `custom-variable'
+ − 2243 widget as an argument, and returns non-nil if ACTION is valid on that
+ − 2244 widget. If FILTER is nil, ACTION is always valid.")
+ − 2245
+ − 2246 (defun custom-variable-action (widget &optional event)
+ − 2247 "Show the menu for `custom-variable' WIDGET.
+ − 2248 Optional EVENT is the location for the menu."
+ − 2249 (if (eq (widget-get widget :custom-state) 'hidden)
+ − 2250 (custom-toggle-hide widget)
+ − 2251 (unless (eq (widget-get widget :custom-state) 'modified)
+ − 2252 (custom-variable-state-set widget))
+ − 2253 ;; Redrawing magic also depresses the state glyph.
+ − 2254 ;(custom-redraw-magic widget)
+ − 2255 (let* ((completion-ignore-case t)
+ − 2256 (answer (widget-choose (concat "Operation on "
+ − 2257 (custom-unlispify-tag-name
+ − 2258 (widget-get widget :value)))
+ − 2259 (custom-menu-filter custom-variable-menu
+ − 2260 widget)
+ − 2261 event)))
+ − 2262 (if answer
+ − 2263 (funcall answer widget)))))
+ − 2264
+ − 2265 (defun custom-variable-edit (widget)
+ − 2266 "Edit value of WIDGET."
+ − 2267 (widget-put widget :custom-state 'unknown)
+ − 2268 (widget-put widget :custom-form 'edit)
+ − 2269 (custom-redraw widget))
+ − 2270
+ − 2271 (defun custom-variable-edit-lisp (widget)
+ − 2272 "Edit the lisp representation of the value of WIDGET."
+ − 2273 (widget-put widget :custom-state 'unknown)
+ − 2274 (widget-put widget :custom-form 'lisp)
+ − 2275 (custom-redraw widget))
+ − 2276
+ − 2277 (defun custom-variable-set (widget)
+ − 2278 "Set the current value for the variable being edited by WIDGET."
+ − 2279 (let* ((form (widget-get widget :custom-form))
+ − 2280 (state (widget-get widget :custom-state))
+ − 2281 (child (car (widget-get widget :children)))
+ − 2282 (symbol (widget-value widget))
+ − 2283 (set (or (get symbol 'custom-set) 'set-default))
+ − 2284 (comment-widget (widget-get widget :comment-widget))
+ − 2285 (comment (widget-value comment-widget))
+ − 2286 val)
+ − 2287 (cond ((eq state 'hidden)
+ − 2288 (error "Cannot set hidden variable"))
+ − 2289 ((setq val (widget-apply child :validate))
+ − 2290 (goto-char (widget-get val :from))
+ − 2291 (error "%s" (widget-get val :error)))
+ − 2292 ((memq form '(lisp mismatch))
+ − 2293 (when (equal comment "")
+ − 2294 (setq comment nil)
+ − 2295 ;; Make the comment invisible by hand if it's empty
+ − 2296 (set-extent-property (widget-get comment-widget :comment-extent)
+ − 2297 'invisible t))
+ − 2298 (funcall set symbol (eval (setq val (widget-value child))))
+ − 2299 (put symbol 'customized-value (list val))
+ − 2300 (put symbol 'variable-comment comment)
+ − 2301 (put symbol 'customized-variable-comment comment))
+ − 2302 (t
+ − 2303 (when (equal comment "")
+ − 2304 (setq comment nil)
+ − 2305 ;; Make the comment invisible by hand if it's empty
+ − 2306 (set-extent-property (widget-get comment-widget :comment-extent)
+ − 2307 'invisible t))
+ − 2308 (funcall set symbol (setq val (widget-value child)))
+ − 2309 (put symbol 'customized-value (list (custom-quote val)))
+ − 2310 (put symbol 'variable-comment comment)
+ − 2311 (put symbol 'customized-variable-comment comment)))
+ − 2312 (custom-variable-state-set widget)
+ − 2313 (custom-redraw-magic widget)))
+ − 2314
480
+ − 2315 (defun custom-variable-pre-save (widget)
+ − 2316 "Prepare for saving the value for the variable being edited by WIDGET."
428
+ − 2317 (let* ((form (widget-get widget :custom-form))
+ − 2318 (state (widget-get widget :custom-state))
+ − 2319 (child (car (widget-get widget :children)))
+ − 2320 (symbol (widget-value widget))
+ − 2321 (set (or (get symbol 'custom-set) 'set-default))
+ − 2322 (comment-widget (widget-get widget :comment-widget))
+ − 2323 (comment (widget-value comment-widget))
+ − 2324 val)
+ − 2325 (cond ((eq state 'hidden)
+ − 2326 (error "Cannot set hidden variable"))
+ − 2327 ((setq val (widget-apply child :validate))
+ − 2328 (goto-char (widget-get val :from))
+ − 2329 (error "%s" (widget-get val :error)))
+ − 2330 ((memq form '(lisp mismatch))
+ − 2331 (when (equal comment "")
+ − 2332 (setq comment nil)
+ − 2333 ;; Make the comment invisible by hand if it's empty
+ − 2334 (set-extent-property (widget-get comment-widget :comment-extent)
+ − 2335 'invisible t))
+ − 2336 (put symbol 'saved-value (list (widget-value child)))
+ − 2337 (custom-push-theme 'theme-value symbol 'user
+ − 2338 'set (list (widget-value child)))
+ − 2339 (funcall set symbol (eval (widget-value child)))
+ − 2340 (put symbol 'variable-comment comment)
+ − 2341 (put symbol 'saved-variable-comment comment))
+ − 2342 (t
+ − 2343 (when (equal comment "")
+ − 2344 (setq comment nil)
+ − 2345 ;; Make the comment invisible by hand if it's empty
+ − 2346 (set-extent-property (widget-get comment-widget :comment-extent)
+ − 2347 'invisible t))
+ − 2348 (put symbol
+ − 2349 'saved-value (list (custom-quote (widget-value
+ − 2350 child))))
+ − 2351 (custom-push-theme 'theme-value symbol 'user
+ − 2352 'set (list (custom-quote (widget-value
480
+ − 2353 child))))
428
+ − 2354 (funcall set symbol (widget-value child))
+ − 2355 (put symbol 'variable-comment comment)
+ − 2356 (put symbol 'saved-variable-comment comment)))
+ − 2357 (put symbol 'customized-value nil)
+ − 2358 (put symbol 'customized-variable-comment nil)
480
+ − 2359 ))
+ − 2360
+ − 2361 (defun custom-variable-post-save (widget)
+ − 2362 "Finish saving the variable being edited by WIDGET."
+ − 2363 (custom-variable-state-set widget)
+ − 2364 (custom-redraw-magic widget))
+ − 2365
+ − 2366 (defun custom-variable-save (widget)
+ − 2367 "Set and save the value for the variable being edited by WIDGET."
+ − 2368 (custom-variable-pre-save widget)
+ − 2369 (custom-save-all)
+ − 2370 (custom-variable-post-save widget))
428
+ − 2371
+ − 2372 (defun custom-variable-reset-saved (widget)
+ − 2373 "Restore the saved value for the variable being edited by WIDGET."
+ − 2374 (let* ((symbol (widget-value widget))
+ − 2375 (set (or (get symbol 'custom-set) 'set-default))
+ − 2376 (value (get symbol 'saved-value))
+ − 2377 (comment (get symbol 'saved-variable-comment)))
+ − 2378 (cond ((or value comment)
+ − 2379 (put symbol 'variable-comment comment)
+ − 2380 (condition-case nil
+ − 2381 (funcall set symbol (eval (car value)))
+ − 2382 (error nil)))
+ − 2383 (t
+ − 2384 (signal 'error (list "No saved value for variable" symbol))))
+ − 2385 (put symbol 'customized-value nil)
+ − 2386 (put symbol 'customized-variable-comment nil)
+ − 2387 (widget-put widget :custom-state 'unknown)
+ − 2388 ;; This call will possibly make the comment invisible
+ − 2389 (custom-redraw widget)))
+ − 2390
480
+ − 2391 ;; This function returns non nil if we need to re-save the options --dv.
+ − 2392 (defun custom-variable-pre-reset-standard (widget)
+ − 2393 "Prepare for restoring the variable being edited by WIDGET to its
+ − 2394 standard setting."
428
+ − 2395 (let* ((symbol (widget-value widget))
442
+ − 2396 (set (or (get symbol 'custom-set) 'set-default)))
428
+ − 2397 (if (get symbol 'standard-value)
+ − 2398 (funcall set symbol (eval (car (get symbol 'standard-value))))
+ − 2399 (signal 'error (list "No standard setting known for variable" symbol)))
+ − 2400 (put symbol 'variable-comment nil)
+ − 2401 (put symbol 'customized-value nil)
+ − 2402 (put symbol 'customized-variable-comment nil)
+ − 2403 (when (or (get symbol 'saved-value) (get symbol 'saved-variable-comment))
+ − 2404 (put symbol 'saved-value nil)
+ − 2405 (custom-push-theme 'theme-value symbol 'user 'reset 'standard)
+ − 2406 ;; As a special optimizations we do not (explictly)
480
+ − 2407 ;; save resets to standard when no theme sets the value.
428
+ − 2408 (if (null (cdr (get symbol 'theme-value)))
+ − 2409 (put symbol 'theme-value nil))
+ − 2410 (put symbol 'saved-variable-comment nil)
480
+ − 2411 widget)
+ − 2412 ))
+ − 2413
+ − 2414 (defun custom-variable-post-reset-standard (widget)
+ − 2415 "Finish resetting the variable being edited by WIDGET to its standard
+ − 2416 value."
+ − 2417 (widget-put widget :custom-state 'unknown)
+ − 2418 ;; This call will possibly make the comment invisible
+ − 2419 (custom-redraw widget))
+ − 2420
+ − 2421 (defun custom-variable-reset-standard (widget)
+ − 2422 "Restore the standard setting for the variable being edited by WIDGET."
+ − 2423 (when (custom-variable-pre-reset-standard widget)
+ − 2424 (custom-save-all))
+ − 2425 (custom-variable-post-reset-standard widget))
+ − 2426
428
+ − 2427
+ − 2428 ;;; The `custom-face-edit' Widget.
+ − 2429
+ − 2430 (define-widget 'custom-face-edit 'checklist
+ − 2431 "Edit face attributes."
+ − 2432 :format "%t: %v"
+ − 2433 :tag "Attributes"
+ − 2434 :extra-offset 12
438
+ − 2435 :button-args '(:help-echo "Control whether this attribute has any effect")
428
+ − 2436 :args (mapcar (lambda (att)
+ − 2437 (list 'group
+ − 2438 :inline t
+ − 2439 :sibling-args (widget-get (nth 1 att) :sibling-args)
+ − 2440 (list 'const :format "" :value (nth 0 att))
+ − 2441 (nth 1 att)))
+ − 2442 custom-face-attributes))
+ − 2443
+ − 2444 ;;; The `custom-display' Widget.
+ − 2445
+ − 2446 (define-widget 'custom-display 'menu-choice
+ − 2447 "Select a display type."
+ − 2448 :tag "Display"
+ − 2449 :value t
+ − 2450 :help-echo "Specify frames where the face attributes should be used"
+ − 2451 :args '((const :tag "all" t)
+ − 2452 (checklist
+ − 2453 :offset 0
+ − 2454 :extra-offset 9
+ − 2455 :args ((group :sibling-args (:help-echo "\
+ − 2456 Only match the specified window systems")
+ − 2457 (const :format "Type: "
+ − 2458 type)
+ − 2459 (checklist :inline t
+ − 2460 :offset 0
+ − 2461 (const :format "X "
+ − 2462 :sibling-args (:help-echo "\
+ − 2463 The X11 Window System")
+ − 2464 x)
555
+ − 2465 (const :format "GTK "
+ − 2466 :sibling-args (:help-echo "\
+ − 2467 The GTK Window System")
+ − 2468 gtk)
428
+ − 2469 (const :format "PM "
+ − 2470 :sibling-args (:help-echo "\
+ − 2471 OS/2 Presentation Manager")
+ − 2472 pm)
+ − 2473 (const :format "MSWindows "
+ − 2474 :sibling-args (:help-echo "\
440
+ − 2475 Microsoft Windows, displays")
428
+ − 2476 mswindows)
440
+ − 2477 (const :format "MSPrinter "
428
+ − 2478 :sibling-args (:help-echo "\
440
+ − 2479 Microsoft Windows, printers")
+ − 2480 msprinter)
428
+ − 2481 (const :format "TTY%n"
+ − 2482 :sibling-args (:help-echo "\
+ − 2483 Plain text terminals")
+ − 2484 tty)))
+ − 2485 (group :sibling-args (:help-echo "\
440
+ − 2486 Only match display or printer devices")
+ − 2487 (const :format "Output: "
+ − 2488 class)
+ − 2489 (checklist :inline t
+ − 2490 :offset 0
+ − 2491 (const :format "Display "
+ − 2492 :sibling-args (:help-echo "\
+ − 2493 Match display devices")
+ − 2494 display)
+ − 2495 (const :format "Printer%n"
+ − 2496 :sibling-args (:help-echo "\
+ − 2497 Match printer devices")
+ − 2498 printer)))
+ − 2499 (group :sibling-args (:help-echo "\
428
+ − 2500 Only match the frames with the specified color support")
440
+ − 2501 (const :format "Color support: "
428
+ − 2502 class)
+ − 2503 (checklist :inline t
+ − 2504 :offset 0
+ − 2505 (const :format "Color "
+ − 2506 :sibling-args (:help-echo "\
+ − 2507 Match color frames")
+ − 2508 color)
+ − 2509 (const :format "Grayscale "
+ − 2510 :sibling-args (:help-echo "\
+ − 2511 Match grayscale frames")
+ − 2512 grayscale)
+ − 2513 (const :format "Monochrome%n"
+ − 2514 :sibling-args (:help-echo "\
+ − 2515 Match frames with no color support")
+ − 2516 mono)))
+ − 2517 (group :sibling-args (:help-echo "\
+ − 2518 Only match frames with the specified intensity")
+ − 2519 (const :format "\
+ − 2520 Background brightness: "
+ − 2521 background)
+ − 2522 (checklist :inline t
+ − 2523 :offset 0
+ − 2524 (const :format "Light "
+ − 2525 :sibling-args (:help-echo "\
+ − 2526 Match frames with light backgrounds")
+ − 2527 light)
+ − 2528 (const :format "Dark\n"
+ − 2529 :sibling-args (:help-echo "\
+ − 2530 Match frames with dark backgrounds")
+ − 2531 dark)))))))
+ − 2532
+ − 2533 ;;; The `custom-face' Widget.
+ − 2534
+ − 2535 (defface custom-face-tag-face '((t (:underline t)))
+ − 2536 "Face used for face tags."
+ − 2537 :group 'custom-faces)
+ − 2538
+ − 2539 (defcustom custom-face-default-form 'selected
+ − 2540 "Default form of displaying face definition."
+ − 2541 :type '(choice (const all)
+ − 2542 (const selected)
+ − 2543 (const lisp))
+ − 2544 :group 'custom-buffer)
+ − 2545
+ − 2546 (define-widget 'custom-face 'custom
+ − 2547 "Customize face."
+ − 2548 :sample-face 'custom-face-tag-face
+ − 2549 :help-echo "Set or reset this face"
4021
+ − 2550 :documentation-property #'(lambda (face)
4178
+ − 2551 (face-doc-string face))
428
+ − 2552 :value-create 'custom-face-value-create
+ − 2553 :action 'custom-face-action
+ − 2554 :custom-category 'face
+ − 2555 :custom-form nil ; defaults to value of `custom-face-default-form'
+ − 2556 :custom-set 'custom-face-set
480
+ − 2557 :custom-pre-save 'custom-face-pre-save
428
+ − 2558 :custom-save 'custom-face-save
480
+ − 2559 :custom-post-save 'custom-face-post-save
428
+ − 2560 :custom-reset-current 'custom-redraw
+ − 2561 :custom-reset-saved 'custom-face-reset-saved
480
+ − 2562 :custom-pre-reset-standard 'custom-face-pre-reset-standard
428
+ − 2563 :custom-reset-standard 'custom-face-reset-standard
480
+ − 2564 :custom-post-reset-standard 'custom-face-post-reset-standard
428
+ − 2565 :custom-menu 'custom-face-menu-create)
+ − 2566
+ − 2567 (define-widget 'custom-face-all 'editable-list
+ − 2568 "An editable list of display specifications and attributes."
+ − 2569 :entry-format "%i %d %v"
+ − 2570 :insert-button-args '(:help-echo "Insert new display specification here")
+ − 2571 :append-button-args '(:help-echo "Append new display specification here")
+ − 2572 :delete-button-args '(:help-echo "Delete this display specification")
+ − 2573 :args '((group :format "%v" custom-display custom-face-edit)))
+ − 2574
+ − 2575 (defconst custom-face-all (widget-convert 'custom-face-all)
+ − 2576 "Converted version of the `custom-face-all' widget.")
+ − 2577
+ − 2578 (define-widget 'custom-display-unselected 'item
+ − 2579 "A display specification that doesn't match the selected display."
+ − 2580 :match 'custom-display-unselected-match)
+ − 2581
+ − 2582 (defun custom-display-unselected-match (widget value)
+ − 2583 "Non-nil if VALUE is an unselected display specification."
+ − 2584 (not (face-spec-set-match-display value (selected-frame))))
+ − 2585
+ − 2586 (define-widget 'custom-face-selected 'group
+ − 2587 "Edit the attributes of the selected display in a face specification."
+ − 2588 :args '((repeat :format ""
+ − 2589 :inline t
+ − 2590 (group custom-display-unselected sexp))
+ − 2591 (group (sexp :format "") custom-face-edit)
+ − 2592 (repeat :format ""
+ − 2593 :inline t
+ − 2594 sexp)))
+ − 2595
+ − 2596 (defconst custom-face-selected (widget-convert 'custom-face-selected)
+ − 2597 "Converted version of the `custom-face-selected' widget.")
+ − 2598
+ − 2599 (defun custom-face-value-create (widget)
+ − 2600 "Create a list of the display specifications for WIDGET."
+ − 2601 (let ((buttons (widget-get widget :buttons))
+ − 2602 children
+ − 2603 (symbol (widget-get widget :value))
+ − 2604 (tag (widget-get widget :tag))
+ − 2605 (state (widget-get widget :custom-state))
+ − 2606 (begin (point))
+ − 2607 (is-last (widget-get widget :custom-last))
+ − 2608 (prefix (widget-get widget :custom-prefix)))
+ − 2609 (unless tag
+ − 2610 (setq tag (prin1-to-string symbol)))
+ − 2611 (cond ((eq custom-buffer-style 'tree)
+ − 2612 (insert prefix (if is-last " `--- " " |--- "))
+ − 2613 (push (widget-create-child-and-convert
+ − 2614 widget 'custom-browse-face-tag)
+ − 2615 buttons)
+ − 2616 (insert " " tag "\n")
+ − 2617 (widget-put widget :buttons buttons))
+ − 2618 (t
+ − 2619 ;; Create tag.
+ − 2620 (insert tag)
+ − 2621 (if (eq custom-buffer-style 'face)
+ − 2622 (insert " ")
+ − 2623 (widget-specify-sample widget begin (point))
+ − 2624 (insert ": "))
+ − 2625 ;; Sample.
+ − 2626 (and (not (find-face symbol))
+ − 2627 ;; XEmacs cannot display uninitialized faces.
+ − 2628 (make-face symbol))
+ − 2629 (push (widget-create-child-and-convert widget 'item
+ − 2630 :format "(%{%t%})"
+ − 2631 :sample-face symbol
+ − 2632 :tag "sample")
+ − 2633 buttons)
+ − 2634 ;; Visibility.
+ − 2635 (insert " ")
+ − 2636 (push (widget-create-child-and-convert
+ − 2637 widget 'visibility
+ − 2638 :help-echo "Hide or show this face"
+ − 2639 :action 'custom-toggle-parent
+ − 2640 (not (eq state 'hidden)))
+ − 2641 buttons)
+ − 2642 ;; Magic.
+ − 2643 (insert "\n")
+ − 2644 (let ((magic (widget-create-child-and-convert
+ − 2645 widget 'custom-magic nil)))
+ − 2646 (widget-put widget :custom-magic magic)
+ − 2647 (push magic buttons))
+ − 2648 ;; Update buttons.
+ − 2649 (widget-put widget :buttons buttons)
+ − 2650 ;; Insert documentation.
+ − 2651 (widget-default-format-handler widget ?h)
+ − 2652 ;; The comment field
+ − 2653 (unless (eq state 'hidden)
+ − 2654 (let* ((comment (get symbol 'face-comment))
+ − 2655 (comment-widget
+ − 2656 (widget-create-child-and-convert
+ − 2657 widget 'custom-comment
+ − 2658 :parent widget
+ − 2659 :value (or comment ""))))
+ − 2660 (widget-put widget :comment-widget comment-widget)
+ − 2661 (push comment-widget children)))
+ − 2662 ;; See also.
+ − 2663 (unless (eq state 'hidden)
+ − 2664 (when (eq (widget-get widget :custom-level) 1)
+ − 2665 (custom-add-parent-links widget))
+ − 2666 (custom-add-see-also widget))
+ − 2667 ;; Editor.
+ − 2668 (unless (eq (preceding-char) ?\n)
+ − 2669 (insert "\n"))
+ − 2670 (unless (eq state 'hidden)
+ − 2671 (message "Creating face editor...")
+ − 2672 (custom-load-widget widget)
+ − 2673 (unless (widget-get widget :custom-form)
+ − 2674 (widget-put widget :custom-form custom-face-default-form))
+ − 2675 (let* ((symbol (widget-value widget))
+ − 2676 (spec (custom-face-get-spec symbol))
+ − 2677 (form (widget-get widget :custom-form))
+ − 2678 (indent (widget-get widget :indent))
+ − 2679 (edit (widget-create-child-and-convert
+ − 2680 widget
+ − 2681 (cond ((and (eq form 'selected)
+ − 2682 (widget-apply custom-face-selected
+ − 2683 :match spec))
+ − 2684 (when indent (insert-char ?\ indent))
+ − 2685 'custom-face-selected)
+ − 2686 ((and (not (eq form 'lisp))
+ − 2687 (widget-apply custom-face-all
+ − 2688 :match spec))
+ − 2689 'custom-face-all)
+ − 2690 (t
+ − 2691 (when indent (insert-char ?\ indent))
+ − 2692 'sexp))
+ − 2693 :value spec)))
+ − 2694 (custom-face-state-set widget)
+ − 2695 (push edit children)
+ − 2696 (widget-put widget :children children))
+ − 2697 (message "Creating face editor...done"))))))
+ − 2698
+ − 2699 (defvar custom-face-menu
4289
+ − 2700 `(("Set for Current Session" custom-face-set)
428
+ − 2701 ("Save for Future Sessions" custom-face-save)
+ − 2702 ("Reset to Saved" custom-face-reset-saved
4289
+ − 2703 ,#'(lambda (widget)
+ − 2704 (or (get (widget-value widget) 'saved-face)
+ − 2705 (get (widget-value widget) 'saved-face-comment))))
428
+ − 2706 ("Reset to Standard Setting" custom-face-reset-standard
4289
+ − 2707 ,#'(lambda (widget)
+ − 2708 (get (widget-value widget) 'face-defface-spec)))
428
+ − 2709 ("---" ignore ignore)
+ − 2710 ("Add Comment" custom-comment-show custom-comment-invisible-p)
+ − 2711 ("---" ignore ignore)
+ − 2712 ("Show all display specs" custom-face-edit-all
4289
+ − 2713 ,#'(lambda (widget)
+ − 2714 (not (eq (widget-get widget :custom-form) 'all))))
428
+ − 2715 ("Just current attributes" custom-face-edit-selected
4289
+ − 2716 ,#'(lambda (widget)
+ − 2717 (not (eq (widget-get widget :custom-form) 'selected))))
428
+ − 2718 ("Show as Lisp expression" custom-face-edit-lisp
4289
+ − 2719 ,#'(lambda (widget)
+ − 2720 (not (eq (widget-get widget :custom-form) 'lisp)))))
428
+ − 2721 "Alist of actions for the `custom-face' widget.
+ − 2722 Each entry has the form (NAME ACTION FILTER) where NAME is the name of
+ − 2723 the menu entry, ACTION is the function to call on the widget when the
+ − 2724 menu is selected, and FILTER is a predicate which takes a `custom-face'
+ − 2725 widget as an argument, and returns non-nil if ACTION is valid on that
+ − 2726 widget. If FILTER is nil, ACTION is always valid.")
+ − 2727
+ − 2728 (defun custom-face-edit-selected (widget)
+ − 2729 "Edit selected attributes of the value of WIDGET."
+ − 2730 (widget-put widget :custom-state 'unknown)
+ − 2731 (widget-put widget :custom-form 'selected)
+ − 2732 (custom-redraw widget))
+ − 2733
+ − 2734 (defun custom-face-edit-all (widget)
+ − 2735 "Edit all attributes of the value of WIDGET."
+ − 2736 (widget-put widget :custom-state 'unknown)
+ − 2737 (widget-put widget :custom-form 'all)
+ − 2738 (custom-redraw widget))
+ − 2739
+ − 2740 (defun custom-face-edit-lisp (widget)
+ − 2741 "Edit the lisp representation of the value of WIDGET."
+ − 2742 (widget-put widget :custom-state 'unknown)
+ − 2743 (widget-put widget :custom-form 'lisp)
+ − 2744 (custom-redraw widget))
+ − 2745
+ − 2746 (defun custom-face-state-set (widget)
+ − 2747 "Set the state of WIDGET."
+ − 2748 (let* ((symbol (widget-value widget))
+ − 2749 (comment (get symbol 'face-comment))
+ − 2750 tmp temp)
+ − 2751 (widget-put widget :custom-state
+ − 2752 (cond ((progn
+ − 2753 (setq tmp (get symbol 'customized-face))
+ − 2754 (setq temp (get symbol 'customized-face-comment))
+ − 2755 (or tmp temp))
+ − 2756 (if (equal temp comment)
+ − 2757 'set
+ − 2758 'changed))
+ − 2759 ((progn
+ − 2760 (setq tmp (get symbol 'saved-face))
+ − 2761 (setq temp (get symbol 'saved-face-comment))
+ − 2762 (or tmp temp))
+ − 2763 (if (equal temp comment)
+ − 2764 'saved
+ − 2765 'changed))
+ − 2766 ((get symbol 'face-defface-spec)
+ − 2767 (if (equal comment nil)
+ − 2768 'standard
+ − 2769 'changed))
+ − 2770 (t
+ − 2771 'rogue)))))
+ − 2772
+ − 2773 (defun custom-face-action (widget &optional event)
+ − 2774 "Show the menu for `custom-face' WIDGET.
+ − 2775 Optional EVENT is the location for the menu."
+ − 2776 (if (eq (widget-get widget :custom-state) 'hidden)
+ − 2777 (custom-toggle-hide widget)
+ − 2778 (let* ((completion-ignore-case t)
+ − 2779 (symbol (widget-get widget :value))
+ − 2780 (answer (widget-choose (concat "Operation on "
+ − 2781 (custom-unlispify-tag-name symbol))
+ − 2782 (custom-menu-filter custom-face-menu
+ − 2783 widget)
+ − 2784 event)))
+ − 2785 (if answer
+ − 2786 (funcall answer widget)))))
+ − 2787
+ − 2788 (defun custom-face-set (widget)
+ − 2789 "Make the face attributes in WIDGET take effect."
+ − 2790 (let* ((symbol (widget-value widget))
+ − 2791 (child (car (widget-get widget :children)))
+ − 2792 (value (widget-value child))
+ − 2793 (comment-widget (widget-get widget :comment-widget))
+ − 2794 (comment (widget-value comment-widget)))
+ − 2795 (when (equal comment "")
+ − 2796 (setq comment nil)
+ − 2797 ;; Make the comment invisible by hand if it's empty
+ − 2798 (set-extent-property (widget-get comment-widget :comment-extent)
+ − 2799 'invisible t))
+ − 2800 (put symbol 'customized-face value)
+ − 2801 (face-spec-set symbol value nil '(custom))
+ − 2802 (put symbol 'customized-face-comment comment)
+ − 2803 (put symbol 'face-comment comment)
+ − 2804 (custom-face-state-set widget)
+ − 2805 (custom-redraw-magic widget)))
+ − 2806
480
+ − 2807 (defun custom-face-pre-save (widget)
+ − 2808 "Prepare for saving the face being edited by WIDGET."
428
+ − 2809 (let* ((symbol (widget-value widget))
+ − 2810 (child (car (widget-get widget :children)))
+ − 2811 (value (widget-value child))
+ − 2812 (comment-widget (widget-get widget :comment-widget))
+ − 2813 (comment (widget-value comment-widget)))
+ − 2814 (when (equal comment "")
+ − 2815 (setq comment nil)
+ − 2816 ;; Make the comment invisible by hand if it's empty
+ − 2817 (set-extent-property (widget-get comment-widget :comment-extent)
+ − 2818 'invisible t))
+ − 2819 (face-spec-set symbol value nil '(custom))
+ − 2820 (put symbol 'saved-face value)
+ − 2821 (custom-push-theme 'theme-face symbol 'user 'set value)
+ − 2822 (put symbol 'customized-face nil)
+ − 2823 (put symbol 'face-comment comment)
+ − 2824 (put symbol 'customized-face-comment nil)
+ − 2825 (put symbol 'saved-face-comment comment)
480
+ − 2826 ))
+ − 2827
+ − 2828 (defun custom-face-post-save (widget)
+ − 2829 "Finish saving the face being edited by WIDGET."
+ − 2830 (custom-face-state-set widget)
+ − 2831 (custom-redraw-magic widget))
+ − 2832
+ − 2833 (defun custom-face-save (widget)
+ − 2834 "Save the face being edited by WIDGET."
+ − 2835 (custom-face-pre-save widget)
+ − 2836 (custom-save-all)
+ − 2837 (custom-face-post-save widget))
428
+ − 2838
+ − 2839 (defun custom-face-reset-saved (widget)
480
+ − 2840 "Reset the face being edited by WIDGET to its saved value."
428
+ − 2841 (let* ((symbol (widget-value widget))
+ − 2842 (child (car (widget-get widget :children)))
+ − 2843 (value (get symbol 'saved-face))
+ − 2844 (comment (get symbol 'saved-face-comment))
+ − 2845 (comment-widget (widget-get widget :comment-widget)))
+ − 2846 (unless (or value comment)
+ − 2847 (signal 'error (list "No saved value for this face" symbol)))
+ − 2848 (put symbol 'customized-face nil)
+ − 2849 (put symbol 'customized-face-comment nil)
+ − 2850 (face-spec-set symbol value nil '(custom))
+ − 2851 (put symbol 'face-comment comment)
+ − 2852 (widget-value-set child value)
+ − 2853 ;; This call manages the comment visibility
+ − 2854 (widget-value-set comment-widget (or comment ""))
+ − 2855 (custom-face-state-set widget)
+ − 2856 (custom-redraw-magic widget)))
+ − 2857
480
+ − 2858 ;; This function returns non nil if we need to re-save the options --dv.
+ − 2859 (defun custom-face-pre-reset-standard (widget)
+ − 2860 "Prepare for restoring the face edited by WIDGET to its standard
+ − 2861 settings."
428
+ − 2862 (let* ((symbol (widget-value widget))
480
+ − 2863 (value (get symbol 'face-defface-spec)))
428
+ − 2864 (unless value
+ − 2865 (signal 'error (list "No standard setting for this face" symbol)))
+ − 2866 (put symbol 'customized-face nil)
+ − 2867 (put symbol 'customized-face-comment nil)
+ − 2868 (when (or (get symbol 'saved-face) (get symbol 'saved-face-comment))
+ − 2869 (put symbol 'saved-face nil)
+ − 2870 (custom-push-theme 'theme-face symbol 'user 'reset 'standard)
+ − 2871 ;; Do not explictly save resets to standards without themes.
+ − 2872 (if (null (cdr (get symbol 'theme-face)))
+ − 2873 (put symbol 'theme-face nil))
+ − 2874 (put symbol 'saved-face-comment nil)
480
+ − 2875 widget)
+ − 2876 ))
+ − 2877
+ − 2878 (defun custom-face-post-reset-standard (widget)
+ − 2879 "Finish restoring the face edited by WIDGET to its standard settings."
+ − 2880 (let* ((symbol (widget-value widget))
+ − 2881 (child (car (widget-get widget :children)))
+ − 2882 (value (get symbol 'face-defface-spec))
+ − 2883 (comment-widget (widget-get widget :comment-widget)))
428
+ − 2884 (face-spec-set symbol value nil '(custom))
+ − 2885 (put symbol 'face-comment nil)
+ − 2886 (widget-value-set child value)
+ − 2887 ;; This call manages the comment visibility
+ − 2888 (widget-value-set comment-widget "")
+ − 2889 (custom-face-state-set widget)
480
+ − 2890 (custom-redraw-magic widget)
+ − 2891 ))
+ − 2892
+ − 2893 (defun custom-face-reset-standard (widget)
+ − 2894 "Restore the face edited by WIDGET to its standard settings."
+ − 2895 (when (custom-face-pre-reset-standard widget)
+ − 2896 (custom-save-all))
+ − 2897 (custom-face-post-reset-standard widget))
+ − 2898
428
+ − 2899
+ − 2900 ;;; The `face' Widget.
+ − 2901
+ − 2902 (define-widget 'face 'default
+ − 2903 "Select and customize a face."
+ − 2904 :convert-widget 'widget-value-convert-widget
+ − 2905 :button-prefix 'widget-push-button-prefix
+ − 2906 :button-suffix 'widget-push-button-suffix
+ − 2907 :format "%t: %[select face%] %v"
+ − 2908 :tag "Face"
+ − 2909 :value 'default
+ − 2910 :value-create 'widget-face-value-create
+ − 2911 :value-delete 'widget-face-value-delete
+ − 2912 :value-get 'widget-value-value-get
+ − 2913 :validate 'widget-children-validate
+ − 2914 :action 'widget-face-action
+ − 2915 :match (lambda (widget value) (symbolp value)))
+ − 2916
+ − 2917 (defun widget-face-value-create (widget)
+ − 2918 ;; Create a `custom-face' child.
+ − 2919 (let* ((symbol (widget-value widget))
+ − 2920 (custom-buffer-style 'face)
+ − 2921 (child (widget-create-child-and-convert
+ − 2922 widget 'custom-face
+ − 2923 :custom-level nil
+ − 2924 :value symbol)))
+ − 2925 (custom-magic-reset child)
+ − 2926 (setq custom-options (cons child custom-options))
+ − 2927 (widget-put widget :children (list child))))
+ − 2928
+ − 2929 (defun widget-face-value-delete (widget)
+ − 2930 ;; Remove the child from the options.
+ − 2931 (let ((child (car (widget-get widget :children))))
+ − 2932 (setq custom-options (delq child custom-options))
+ − 2933 (widget-children-value-delete widget)))
+ − 2934
+ − 2935 (defvar face-history nil
+ − 2936 "History of entered face names.")
+ − 2937
+ − 2938 (defun widget-face-action (widget &optional event)
+ − 2939 "Prompt for a face."
+ − 2940 (let ((answer (completing-read "Face: "
+ − 2941 (mapcar (lambda (face)
+ − 2942 (list (symbol-name face)))
+ − 2943 (face-list))
+ − 2944 nil nil nil
+ − 2945 'face-history)))
+ − 2946 (unless (zerop (length answer))
+ − 2947 (widget-value-set widget (intern answer))
+ − 2948 (widget-apply widget :notify widget event)
+ − 2949 (widget-setup))))
+ − 2950
+ − 2951 ;;; The `hook' Widget.
+ − 2952
+ − 2953 (define-widget 'hook 'list
+ − 2954 "A emacs lisp hook"
+ − 2955 :value-to-internal (lambda (widget value)
+ − 2956 (if (symbolp value)
+ − 2957 (list value)
+ − 2958 value))
+ − 2959 :match (lambda (widget value)
+ − 2960 (or (symbolp value)
+ − 2961 (widget-group-match widget value)))
+ − 2962 :convert-widget 'custom-hook-convert-widget
+ − 2963 :tag "Hook")
+ − 2964
+ − 2965 (defun custom-hook-convert-widget (widget)
438
+ − 2966 ;; Handle `:options'.
428
+ − 2967 (let* ((options (widget-get widget :options))
+ − 2968 (other `(editable-list :inline t
+ − 2969 :entry-format "%i %d%v"
+ − 2970 (function :format " %v")))
+ − 2971 (args (if options
+ − 2972 (list `(checklist :inline t
+ − 2973 ,@(mapcar (lambda (entry)
+ − 2974 `(function-item ,entry))
+ − 2975 options))
+ − 2976 other)
+ − 2977 (list other))))
+ − 2978 (widget-put widget :args args)
+ − 2979 widget))
+ − 2980
+ − 2981 ;;; The `plist' Widget.
+ − 2982
+ − 2983 (define-widget 'plist 'list
+ − 2984 "A property list."
+ − 2985 :match (lambda (widget value)
+ − 2986 (valid-plist-p value))
+ − 2987 :convert-widget 'custom-plist-convert-widget
+ − 2988 :tag "Property List")
+ − 2989
+ − 2990 ;; #### Should handle options better.
+ − 2991 (defun custom-plist-convert-widget (widget)
+ − 2992 (let* ((options (widget-get widget :options))
+ − 2993 (other `(editable-list :inline t
+ − 2994 (group :inline t
+ − 2995 (symbol :format "%t: %v "
+ − 2996 :size 10
+ − 2997 :tag "Property")
+ − 2998 (sexp :tag "Value"))))
+ − 2999 (args
+ − 3000 (if options
+ − 3001 `((checklist :inline t
+ − 3002 ,@(mapcar 'custom-plist-process-option options))
+ − 3003 ,other)
+ − 3004 (list other))))
+ − 3005 (widget-put widget :args args)
+ − 3006 widget))
+ − 3007
+ − 3008 (defun custom-plist-process-option (entry)
+ − 3009 `(group :inline t
+ − 3010 (const :tag "Property"
+ − 3011 :format "%t: %v "
+ − 3012 :size 10
+ − 3013 ,entry)
+ − 3014 (sexp :tag "Value")))
+ − 3015
+ − 3016 ;;; The `custom-group-link' Widget.
+ − 3017
+ − 3018 (define-widget 'custom-group-link 'link
+ − 3019 "Show parent in other window when activated."
+ − 3020 :help-echo 'custom-group-link-help-echo
+ − 3021 :action 'custom-group-link-action)
+ − 3022
+ − 3023 (defun custom-group-link-help-echo (widget)
+ − 3024 (concat "Create customization buffer for the `"
+ − 3025 (custom-unlispify-tag-name (widget-value widget))
+ − 3026 "' group"))
+ − 3027
+ − 3028 (defun custom-group-link-action (widget &rest ignore)
+ − 3029 (customize-group (widget-value widget)))
+ − 3030
+ − 3031 ;;; The `custom-group' Widget.
+ − 3032
+ − 3033 (defcustom custom-group-tag-faces nil
+ − 3034 ;; In XEmacs, this ought to play games with font size.
+ − 3035 "Face used for group tags.
+ − 3036 The first member is used for level 1 groups, the second for level 2,
+ − 3037 and so forth. The remaining group tags are shown with
+ − 3038 `custom-group-tag-face'."
+ − 3039 :type '(repeat face)
+ − 3040 :group 'custom-faces)
+ − 3041
+ − 3042 (defface custom-group-tag-face-1 '((((class color)
+ − 3043 (background dark))
+ − 3044 (:foreground "pink" :underline t))
+ − 3045 (((class color)
+ − 3046 (background light))
+ − 3047 (:foreground "red" :underline t))
+ − 3048 (t (:underline t)))
+ − 3049 "Face used for group tags.")
+ − 3050
+ − 3051 (defface custom-group-tag-face '((((class color)
+ − 3052 (background dark))
+ − 3053 (:foreground "light blue" :underline t))
+ − 3054 (((class color)
+ − 3055 (background light))
+ − 3056 (:foreground "blue" :underline t))
+ − 3057 (t (:underline t)))
+ − 3058 "Face used for low level group tags."
+ − 3059 :group 'custom-faces)
+ − 3060
+ − 3061 (define-widget 'custom-group 'custom
+ − 3062 "Customize group."
+ − 3063 :format "%v"
+ − 3064 :sample-face-get 'custom-group-sample-face-get
+ − 3065 :documentation-property 'group-documentation
+ − 3066 :help-echo "Set or reset all members of this group"
+ − 3067 :value-create 'custom-group-value-create
+ − 3068 :action 'custom-group-action
+ − 3069 :custom-category 'group
+ − 3070 :custom-set 'custom-group-set
480
+ − 3071 :custom-pre-save 'custom-group-pre-save
428
+ − 3072 :custom-save 'custom-group-save
480
+ − 3073 :custom-post-save 'custom-group-post-save
428
+ − 3074 :custom-reset-current 'custom-group-reset-current
+ − 3075 :custom-reset-saved 'custom-group-reset-saved
480
+ − 3076 :custom-pre-reset-standard 'custom-group-pre-reset-standard
428
+ − 3077 :custom-reset-standard 'custom-group-reset-standard
480
+ − 3078 :custom-post-reset-standard 'custom-group-post-reset-standard
428
+ − 3079 :custom-menu 'custom-group-menu-create)
+ − 3080
+ − 3081 (defun custom-group-sample-face-get (widget)
+ − 3082 ;; Use :sample-face.
+ − 3083 (or (nth (1- (widget-get widget :custom-level)) custom-group-tag-faces)
+ − 3084 'custom-group-tag-face))
+ − 3085
+ − 3086 (define-widget 'custom-group-visibility 'visibility
+ − 3087 "An indicator and manipulator for hidden group contents."
+ − 3088 :create 'custom-group-visibility-create)
+ − 3089
+ − 3090 (defun custom-group-visibility-create (widget)
+ − 3091 (let ((visible (widget-value widget)))
+ − 3092 (if visible
+ − 3093 (insert "--------")))
+ − 3094 (widget-default-create widget))
+ − 3095
+ − 3096 (defun custom-group-members (symbol groups-only)
+ − 3097 "Return SYMBOL's custom group members.
+ − 3098 If GROUPS-ONLY non-nil, return only those members that are groups."
+ − 3099 (if (not groups-only)
+ − 3100 (get symbol 'custom-group)
+ − 3101 (let (members)
+ − 3102 (dolist (entry (get symbol 'custom-group) (nreverse members))
+ − 3103 (when (eq (nth 1 entry) 'custom-group)
+ − 3104 (push entry members))))))
+ − 3105
+ − 3106 (defun custom-group-value-create (widget)
+ − 3107 "Insert a customize group for WIDGET in the current buffer."
+ − 3108 (let* ((state (widget-get widget :custom-state))
+ − 3109 (level (widget-get widget :custom-level))
+ − 3110 ;; (indent (widget-get widget :indent))
+ − 3111 (prefix (widget-get widget :custom-prefix))
+ − 3112 (buttons (widget-get widget :buttons))
+ − 3113 (tag (widget-get widget :tag))
+ − 3114 (symbol (widget-value widget))
+ − 3115 (members (custom-group-members symbol
+ − 3116 (and (eq custom-buffer-style 'tree)
+ − 3117 custom-browse-only-groups))))
+ − 3118 (cond ((and (eq custom-buffer-style 'tree)
+ − 3119 (eq state 'hidden)
+ − 3120 (or members (custom-unloaded-widget-p widget)))
+ − 3121 (custom-browse-insert-prefix prefix)
+ − 3122 (push (widget-create-child-and-convert
+ − 3123 widget 'custom-browse-visibility
+ − 3124 ;; :tag-glyph "plus"
+ − 3125 :tag "+")
+ − 3126 buttons)
+ − 3127 (insert "-- ")
+ − 3128 ;; (widget-glyph-insert nil "-- " "horizontal")
+ − 3129 (push (widget-create-child-and-convert
+ − 3130 widget 'custom-browse-group-tag)
+ − 3131 buttons)
+ − 3132 (insert " " tag "\n")
+ − 3133 (widget-put widget :buttons buttons))
+ − 3134 ((and (eq custom-buffer-style 'tree)
+ − 3135 (zerop (length members)))
+ − 3136 (custom-browse-insert-prefix prefix)
+ − 3137 (insert "[ ]-- ")
+ − 3138 ;; (widget-glyph-insert nil "[ ]" "empty")
+ − 3139 ;; (widget-glyph-insert nil "-- " "horizontal")
+ − 3140 (push (widget-create-child-and-convert
+ − 3141 widget 'custom-browse-group-tag)
+ − 3142 buttons)
+ − 3143 (insert " " tag "\n")
+ − 3144 (widget-put widget :buttons buttons))
+ − 3145 ((eq custom-buffer-style 'tree)
+ − 3146 (custom-browse-insert-prefix prefix)
+ − 3147 (custom-load-widget widget)
+ − 3148 (if (zerop (length members))
+ − 3149 (progn
+ − 3150 (custom-browse-insert-prefix prefix)
+ − 3151 (insert "[ ]-- ")
+ − 3152 ;; (widget-glyph-insert nil "[ ]" "empty")
+ − 3153 ;; (widget-glyph-insert nil "-- " "horizontal")
+ − 3154 (push (widget-create-child-and-convert
+ − 3155 widget 'custom-browse-group-tag)
+ − 3156 buttons)
+ − 3157 (insert " " tag "\n")
+ − 3158 (widget-put widget :buttons buttons))
+ − 3159 (push (widget-create-child-and-convert
+ − 3160 widget 'custom-browse-visibility
+ − 3161 ;; :tag-glyph "minus"
+ − 3162 :tag "-")
+ − 3163 buttons)
+ − 3164 (insert "-\\ ")
+ − 3165 ;; (widget-glyph-insert nil "-\\ " "top")
+ − 3166 (push (widget-create-child-and-convert
+ − 3167 widget 'custom-browse-group-tag)
+ − 3168 buttons)
+ − 3169 (insert " " tag "\n")
+ − 3170 (widget-put widget :buttons buttons)
+ − 3171 (message "Creating group...")
+ − 3172 (let* ((members (custom-sort-items members
+ − 3173 custom-browse-sort-alphabetically
+ − 3174 custom-browse-order-groups))
+ − 3175 (prefixes (widget-get widget :custom-prefixes))
+ − 3176 (custom-prefix-list (custom-prefix-add symbol prefixes))
+ − 3177 (extra-prefix (if (widget-get widget :custom-last)
+ − 3178 " "
+ − 3179 " | "))
+ − 3180 (prefix (concat prefix extra-prefix))
+ − 3181 children entry)
+ − 3182 (while members
+ − 3183 (setq entry (car members)
+ − 3184 members (cdr members))
+ − 3185 (push (widget-create-child-and-convert
+ − 3186 widget (nth 1 entry)
+ − 3187 :group widget
+ − 3188 :tag (custom-unlispify-tag-name (nth 0 entry))
+ − 3189 :custom-prefixes custom-prefix-list
+ − 3190 :custom-level (1+ level)
+ − 3191 :custom-last (null members)
+ − 3192 :value (nth 0 entry)
+ − 3193 :custom-prefix prefix)
+ − 3194 children))
+ − 3195 (widget-put widget :children (reverse children)))
+ − 3196 (message "Creating group...done")))
+ − 3197 ;; Nested style.
+ − 3198 ((eq state 'hidden)
+ − 3199 ;; Create level indicator.
+ − 3200 (unless (eq custom-buffer-style 'links)
+ − 3201 (insert-char ?\ (* custom-buffer-indent (1- level)))
+ − 3202 (insert "-- "))
+ − 3203 ;; Create link indicator.
+ − 3204 (when (eq custom-buffer-style 'links)
+ − 3205 (insert " ")
+ − 3206 (push (widget-create-child-and-convert
+ − 3207 widget 'custom-group-link
+ − 3208 :tag "Open"
+ − 3209 :tag-glyph '("open-up" "open-down")
+ − 3210 symbol)
+ − 3211 buttons)
+ − 3212 (insert " "))
+ − 3213 ;; Create tag.
+ − 3214 (let ((begin (point)))
+ − 3215 (insert tag)
+ − 3216 (widget-specify-sample widget begin (point)))
+ − 3217 (insert " group")
+ − 3218 ;; Create visibility indicator.
+ − 3219 (unless (eq custom-buffer-style 'links)
+ − 3220 (insert ": ")
+ − 3221 (push (widget-create-child-and-convert
+ − 3222 widget 'custom-group-visibility
+ − 3223 :help-echo "Show members of this group"
+ − 3224 :action 'custom-toggle-parent
+ − 3225 (not (eq state 'hidden)))
+ − 3226 buttons))
+ − 3227 (insert " \n")
+ − 3228 ;; Create magic button.
+ − 3229 (let ((magic (widget-create-child-and-convert
+ − 3230 widget 'custom-magic nil)))
+ − 3231 (widget-put widget :custom-magic magic)
+ − 3232 (push magic buttons))
+ − 3233 ;; Update buttons.
+ − 3234 (widget-put widget :buttons buttons)
+ − 3235 ;; Insert documentation.
+ − 3236 (if (and (eq custom-buffer-style 'links) (> level 1))
+ − 3237 (widget-put widget :documentation-indent 0))
+ − 3238 (widget-default-format-handler widget ?h))
+ − 3239 ;; Nested style.
+ − 3240 (t ;Visible.
+ − 3241 (custom-load-widget widget)
+ − 3242 ;; Update members
+ − 3243 (setq members (custom-group-members
+ − 3244 symbol (and (eq custom-buffer-style 'tree)
+ − 3245 custom-browse-only-groups)))
+ − 3246 ;; Add parent groups references above the group.
+ − 3247 (if t ;;; This should test that the buffer
+ − 3248 ;;; was made to display a group.
+ − 3249 (when (eq level 1)
+ − 3250 (if (custom-add-parent-links widget
+ − 3251 "Go to parent group:")
+ − 3252 (insert "\n"))))
+ − 3253 ;; Create level indicator.
+ − 3254 (insert-char ?\ (* custom-buffer-indent (1- level)))
+ − 3255 (insert "/- ")
+ − 3256 ;; Create tag.
+ − 3257 (let ((start (point)))
+ − 3258 (insert tag)
+ − 3259 (widget-specify-sample widget start (point)))
+ − 3260 (insert " group: ")
+ − 3261 ;; Create visibility indicator.
+ − 3262 (unless (eq custom-buffer-style 'links)
+ − 3263 (insert "--------")
+ − 3264 (push (widget-create-child-and-convert
+ − 3265 widget 'visibility
+ − 3266 :help-echo "Hide members of this group"
+ − 3267 :action 'custom-toggle-parent
+ − 3268 (not (eq state 'hidden)))
+ − 3269 buttons)
+ − 3270 (insert " "))
+ − 3271 ;; Create more dashes.
+ − 3272 ;; Use 76 instead of 75 to compensate for the temporary "<"
+ − 3273 ;; added by `widget-insert'.
+ − 3274 (insert-char ?- (- 76 (current-column)
+ − 3275 (* custom-buffer-indent level)))
+ − 3276 (insert "\\\n")
+ − 3277 ;; Create magic button.
+ − 3278 (let ((magic (widget-create-child-and-convert
+ − 3279 widget 'custom-magic
+ − 3280 :indent 0
+ − 3281 nil)))
+ − 3282 (widget-put widget :custom-magic magic)
+ − 3283 (push magic buttons))
+ − 3284 ;; Update buttons.
+ − 3285 (widget-put widget :buttons buttons)
+ − 3286 ;; Insert documentation.
+ − 3287 (widget-default-format-handler widget ?h)
+ − 3288 ;; Parent groups.
+ − 3289 (if nil ;;; This should test that the buffer
+ − 3290 ;;; was not made to display a group.
+ − 3291 (when (eq level 1)
+ − 3292 (insert-char ?\ custom-buffer-indent)
+ − 3293 (custom-add-parent-links widget)))
+ − 3294 (custom-add-see-also widget
+ − 3295 (make-string (* custom-buffer-indent level)
+ − 3296 ?\ ))
+ − 3297 ;; Members.
+ − 3298 (message "Creating group...")
+ − 3299 (let* ((members (custom-sort-items members
+ − 3300 custom-buffer-sort-alphabetically
+ − 3301 custom-buffer-order-groups))
+ − 3302 (prefixes (widget-get widget :custom-prefixes))
+ − 3303 (custom-prefix-list (custom-prefix-add symbol prefixes))
+ − 3304 (length (length members))
+ − 3305 (count 0)
+ − 3306 (children (mapcar
+ − 3307 (lambda (entry)
+ − 3308 (widget-insert "\n")
+ − 3309 (when (zerop (% count custom-skip-messages))
+ − 3310 (display-message
+ − 3311 'progress
+ − 3312 (format "\
+ − 3313 Creating group members... %2d%%"
+ − 3314 (/ (* 100.0 count) length))))
+ − 3315 (incf count)
+ − 3316 (prog1
+ − 3317 (widget-create-child-and-convert
+ − 3318 widget (nth 1 entry)
+ − 3319 :group widget
+ − 3320 :tag (custom-unlispify-tag-name
+ − 3321 (nth 0 entry))
+ − 3322 :custom-prefixes custom-prefix-list
+ − 3323 :custom-level (1+ level)
+ − 3324 :value (nth 0 entry))
+ − 3325 (unless (eq (preceding-char) ?\n)
+ − 3326 (widget-insert "\n"))))
+ − 3327 members)))
+ − 3328 (message "Creating group magic...")
+ − 3329 (mapc 'custom-magic-reset children)
+ − 3330 (message "Creating group state...")
+ − 3331 (widget-put widget :children children)
+ − 3332 (custom-group-state-update widget)
+ − 3333 (message "Creating group... done"))
+ − 3334 ;; End line
+ − 3335 (insert "\n")
+ − 3336 (insert-char ?\ (* custom-buffer-indent (1- level)))
+ − 3337 (insert "\\- " (widget-get widget :tag) " group end ")
+ − 3338 (insert-char ?- (- 75 (current-column) (* custom-buffer-indent level)))
+ − 3339 (insert "/\n")))))
+ − 3340
+ − 3341 (defvar custom-group-menu
4289
+ − 3342 `(("Set for Current Session" custom-group-set
+ − 3343 ,#'(lambda (widget)
+ − 3344 (eq (widget-get widget :custom-state) 'modified)))
428
+ − 3345 ("Save for Future Sessions" custom-group-save
4289
+ − 3346 ,#'(lambda (widget)
+ − 3347 (memq (widget-get widget :custom-state) '(modified set))))
428
+ − 3348 ("Reset to Current" custom-group-reset-current
4289
+ − 3349 ,#'(lambda (widget)
+ − 3350 (memq (widget-get widget :custom-state) '(modified))))
428
+ − 3351 ("Reset to Saved" custom-group-reset-saved
4289
+ − 3352 ,#'(lambda (widget)
+ − 3353 (memq (widget-get widget :custom-state) '(modified set))))
428
+ − 3354 ("Reset to standard setting" custom-group-reset-standard
4289
+ − 3355 ,#'(lambda (widget)
+ − 3356 (memq (widget-get widget :custom-state) '(modified set saved)))))
428
+ − 3357 "Alist of actions for the `custom-group' widget.
+ − 3358 Each entry has the form (NAME ACTION FILTER) where NAME is the name of
+ − 3359 the menu entry, ACTION is the function to call on the widget when the
+ − 3360 menu is selected, and FILTER is a predicate which takes a `custom-group'
+ − 3361 widget as an argument, and returns non-nil if ACTION is valid on that
+ − 3362 widget. If FILTER is nil, ACTION is always valid.")
+ − 3363
+ − 3364 (defun custom-group-action (widget &optional event)
+ − 3365 "Show the menu for `custom-group' WIDGET.
+ − 3366 Optional EVENT is the location for the menu."
+ − 3367 (if (eq (widget-get widget :custom-state) 'hidden)
+ − 3368 (custom-toggle-hide widget)
+ − 3369 (let* ((completion-ignore-case t)
+ − 3370 (answer (widget-choose (concat "Operation on "
+ − 3371 (custom-unlispify-tag-name
+ − 3372 (widget-get widget :value)))
+ − 3373 (custom-menu-filter custom-group-menu
+ − 3374 widget)
+ − 3375 event)))
+ − 3376 (if answer
+ − 3377 (funcall answer widget)))))
+ − 3378
+ − 3379 (defun custom-group-set (widget)
+ − 3380 "Set changes in all modified group members."
+ − 3381 (let ((children (widget-get widget :children)))
+ − 3382 (mapc (lambda (child)
+ − 3383 (when (eq (widget-get child :custom-state) 'modified)
+ − 3384 (widget-apply child :custom-set)))
+ − 3385 children)))
+ − 3386
480
+ − 3387 (defun custom-group-pre-save (widget)
+ − 3388 "Prepare for saving all modified group members."
+ − 3389 (let ((children (widget-get widget :children)))
+ − 3390 (mapc (lambda (child)
+ − 3391 (when (memq (widget-get child :custom-state) '(modified set))
+ − 3392 (widget-apply child :custom-pre-save)))
+ − 3393 children)))
+ − 3394
+ − 3395 (defun custom-group-post-save (widget)
428
+ − 3396 "Save all modified group members."
+ − 3397 (let ((children (widget-get widget :children)))
+ − 3398 (mapc (lambda (child)
+ − 3399 (when (memq (widget-get child :custom-state) '(modified set))
480
+ − 3400 (widget-apply child :custom-post-save)))
428
+ − 3401 children)))
+ − 3402
480
+ − 3403 (defun custom-group-save (widget)
+ − 3404 "Save all modified group members."
+ − 3405 (custom-group-pre-save widget)
+ − 3406 (custom-save-all)
+ − 3407 (custom-group-post-save widget))
+ − 3408
428
+ − 3409 (defun custom-group-reset-current (widget)
+ − 3410 "Reset all modified group members."
+ − 3411 (let ((children (widget-get widget :children)))
+ − 3412 (mapc (lambda (child)
+ − 3413 (when (eq (widget-get child :custom-state) 'modified)
+ − 3414 (widget-apply child :custom-reset-current)))
+ − 3415 children)))
+ − 3416
+ − 3417 (defun custom-group-reset-saved (widget)
+ − 3418 "Reset all modified or set group members."
+ − 3419 (let ((children (widget-get widget :children)))
+ − 3420 (mapc (lambda (child)
+ − 3421 (when (memq (widget-get child :custom-state) '(modified set))
+ − 3422 (widget-apply child :custom-reset-saved)))
+ − 3423 children)))
+ − 3424
480
+ − 3425 ;; This function returns non nil when we need to re-save the options --dv.
+ − 3426 (defun custom-group-pre-reset-standard (widget)
+ − 3427 "Prepare for resetting all modified, set, or saved group members."
+ − 3428 (let ((children (widget-get widget :children))
+ − 3429 must-save)
+ − 3430 (mapc (lambda (child)
+ − 3431 (when (memq (widget-get child :custom-state)
+ − 3432 '(modified set saved))
+ − 3433 (and (widget-apply child :custom-pre-reset-standard)
+ − 3434 (setq must-save t))))
+ − 3435 children)
+ − 3436 must-save
+ − 3437 ))
+ − 3438
+ − 3439 (defun custom-group-post-reset-standard (widget)
+ − 3440 "Finish resetting all modified, set, or saved group members."
428
+ − 3441 (let ((children (widget-get widget :children)))
+ − 3442 (mapc (lambda (child)
+ − 3443 (when (memq (widget-get child :custom-state)
+ − 3444 '(modified set saved))
480
+ − 3445 (widget-apply child :custom-post-reset-standard)))
428
+ − 3446 children)))
+ − 3447
480
+ − 3448 (defun custom-group-reset-standard (widget)
+ − 3449 "Reset all modified, set, or saved group members."
+ − 3450 (when (custom-group-pre-reset-standard widget)
+ − 3451 (custom-save-all))
+ − 3452 (custom-group-post-reset-standard widget))
+ − 3453
428
+ − 3454 (defun custom-group-state-update (widget)
+ − 3455 "Update magic."
+ − 3456 (unless (eq (widget-get widget :custom-state) 'hidden)
+ − 3457 (let* ((children (widget-get widget :children))
+ − 3458 (states (mapcar (lambda (child)
+ − 3459 (widget-get child :custom-state))
+ − 3460 children))
+ − 3461 (magics custom-magic-alist)
+ − 3462 (found 'standard))
+ − 3463 (while magics
+ − 3464 (let ((magic (car (car magics))))
+ − 3465 (if (and (not (eq magic 'hidden))
+ − 3466 (memq magic states))
+ − 3467 (setq found magic
+ − 3468 magics nil)
+ − 3469 (setq magics (cdr magics)))))
+ − 3470 (widget-put widget :custom-state found)))
+ − 3471 (custom-magic-reset widget))
+ − 3472
+ − 3473 (defun custom-save-delete (symbol)
+ − 3474 "Delete the call to SYMBOL form in `custom-file'.
+ − 3475 Leave point at the location of the call, or after the last expression."
+ − 3476 (let ((find-file-hooks nil)
+ − 3477 (auto-mode-alist nil))
+ − 3478 (set-buffer (find-file-noselect custom-file)))
+ − 3479 (goto-char (point-min))
+ − 3480 (catch 'found
+ − 3481 (while t
+ − 3482 (let ((sexp (condition-case nil
+ − 3483 (read (current-buffer))
+ − 3484 (end-of-file (throw 'found nil)))))
+ − 3485 (when (and (listp sexp)
+ − 3486 (eq (car sexp) symbol))
+ − 3487 (delete-region (save-excursion
+ − 3488 (backward-sexp)
+ − 3489 (point))
+ − 3490 (point))
+ − 3491 (throw 'found nil))))))
+ − 3492
848
+ − 3493 (defun custom-save-delete-any (&rest symbols)
+ − 3494 "Delete the call to any symbol among SYMBOLS in `custom-file'.
+ − 3495 Leave the point at the end of the file."
+ − 3496 (let ((find-file-hooks nil)
+ − 3497 (auto-mode-alist nil))
+ − 3498 (set-buffer (find-file-noselect custom-file)))
+ − 3499 (goto-char (point-min))
+ − 3500 (condition-case nil
+ − 3501 (while (not (eobp))
4178
+ − 3502 (let ((sexp (read (current-buffer))))
+ − 3503 (when (and (listp sexp)
+ − 3504 (memq (car sexp) symbols))
+ − 3505 (delete-region (save-excursion
+ − 3506 (backward-sexp)
+ − 3507 (point))
+ − 3508 (point))
+ − 3509 (while (and (eolp) (not (eobp)))
+ − 3510 (delete-region (point) (prog2 (forward-line 1) (point))))
+ − 3511 )))
848
+ − 3512 (end-of-file nil)))
+ − 3513
+ − 3514 (defsubst custom-save-variable-p (symbol)
+ − 3515 "Return non-nil if symbol SYMBOL is a customized variable."
+ − 3516 (and (symbolp symbol)
+ − 3517 (let ((spec (car-safe (get symbol 'theme-value))))
4178
+ − 3518 (or (and spec (eq (car spec) 'user)
+ − 3519 (eq (second spec) 'set))
+ − 3520 (get symbol 'saved-variable-comment)
+ − 3521 ;; support non-themed vars
+ − 3522 (and (null spec) (get symbol 'saved-value))))))
848
+ − 3523
+ − 3524 (defun custom-save-variable-internal (symbol)
+ − 3525 "Print variable SYMBOL to the standard output.
+ − 3526 SYMBOL must be a customized variable."
+ − 3527 (let ((requests (get symbol 'custom-requests))
4178
+ − 3528 (now (not (or (get symbol 'standard-value)
+ − 3529 (and (not (boundp symbol))
+ − 3530 (not (eq (get symbol 'force-value)
+ − 3531 'rogue))))))
+ − 3532 (comment (get symbol 'saved-variable-comment))
+ − 3533 ;; Print everything, no placeholders `...'
+ − 3534 (print-level nil)
+ − 3535 (print-length nil))
848
+ − 3536 (unless (custom-save-variable-p symbol)
+ − 3537 (error 'wrong-type-argument "Not a customized variable" symbol))
+ − 3538 (princ "\n '(")
+ − 3539 (prin1 symbol)
+ − 3540 (princ " ")
+ − 3541 ;; This comment stuff is in the way ####
+ − 3542 ;; Is (eq (third spec) (car saved-value)) ????
+ − 3543 ;; (prin1 (third spec))
+ − 3544 ;; XEmacs -- pretty-print value if available
+ − 3545 (if (and custom-save-pretty-print
4178
+ − 3546 (fboundp 'pp))
+ − 3547 ;; To suppress bytecompiler warning
+ − 3548 (with-fboundp 'pp
+ − 3549 (pp (car (get symbol 'saved-value))))
848
+ − 3550 (prin1 (car (get symbol 'saved-value))))
+ − 3551 (when (or now requests comment)
+ − 3552 (princ (if now " t" " nil")))
+ − 3553 (when (or comment requests)
+ − 3554 (princ " ")
+ − 3555 (prin1 requests))
+ − 3556 (when comment
+ − 3557 (princ " ")
+ − 3558 (prin1 comment))
+ − 3559 (princ ")")))
+ − 3560
428
+ − 3561 (defun custom-save-variables ()
+ − 3562 "Save all customized variables in `custom-file'."
+ − 3563 (save-excursion
+ − 3564 (custom-save-delete 'custom-load-themes)
+ − 3565 (custom-save-delete 'custom-reset-variables)
+ − 3566 (custom-save-delete 'custom-set-variables)
848
+ − 3567 ;; This leaves point at the end of file.
+ − 3568 ;; Adrian Aichner <adrian@xemacs.org> stated it is
+ − 3569 ;; a bad behavior <npak@ispras.ru>
+ − 3570 ;;(custom-save-delete-any 'custom-load-themes
+ − 3571 ;; 'custom-reset-variables
+ − 3572 ;; 'custom-set-variables)
428
+ − 3573 (custom-save-loaded-themes)
+ − 3574 (custom-save-resets 'theme-value 'custom-reset-variables nil)
848
+ − 3575 (let ((standard-output (current-buffer))
4178
+ − 3576 (sorted-list ()))
848
+ − 3577 ;; First create a sorted list of saved variables.
+ − 3578 (mapatoms
4178
+ − 3579 (lambda (symbol)
+ − 3580 (when (custom-save-variable-p symbol)
+ − 3581 (push symbol sorted-list))))
2122
+ − 3582 (setq sorted-list (sort sorted-list 'string<))
428
+ − 3583 (unless (bolp)
4178
+ − 3584 (princ "\n"))
428
+ − 3585 (princ "(custom-set-variables")
848
+ − 3586 (mapc 'custom-save-variable-internal
4178
+ − 3587 sorted-list)
848
+ − 3588 (princ ")")
+ − 3589 (unless (looking-at "\n")
4178
+ − 3590 (princ "\n")))))
428
+ − 3591
+ − 3592 (defvar custom-save-face-ignoring nil)
+ − 3593
848
+ − 3594 (defsubst custom-save-face-p (symbol)
+ − 3595 "Return non-nil if SYMBOL is a customized face."
428
+ − 3596 (let ((theme-spec (car-safe (get symbol 'theme-face)))
848
+ − 3597 (comment (get symbol 'saved-face-comment)))
+ − 3598 (or (and (not (memq symbol custom-save-face-ignoring))
4178
+ − 3599 ;; Don't print default face here.
+ − 3600 (or (and theme-spec
+ − 3601 (eq (car theme-spec) 'user)
+ − 3602 (eq (second theme-spec) 'set))
+ − 3603 ;; cope with non-themed faces
+ − 3604 (and (null theme-spec)
+ − 3605 (get symbol 'saved-face))))
+ − 3606 comment)))
848
+ − 3607
+ − 3608 (defun custom-save-face-internal (symbol)
+ − 3609 "Print face SYMBOL to the standard output.
+ − 3610 SYMBOL must be a customized face."
+ − 3611 (let ((comment (get symbol 'saved-face-comment))
428
+ − 3612 (now (not (or (get symbol 'face-defface-spec)
+ − 3613 (and (not (find-face symbol))
848
+ − 3614 (not (eq (get symbol 'force-face) 'rogue))))))
4178
+ − 3615 ;; Print everything, no placeholders `...'
+ − 3616 (print-level nil)
+ − 3617 (print-length nil))
848
+ − 3618 (if (memq symbol custom-save-face-ignoring)
4178
+ − 3619 ;; Do nothing
+ − 3620 nil
848
+ − 3621 ;; Print face
+ − 3622 (unless (custom-save-face-p symbol)
4178
+ − 3623 (error 'wrong-type-argument "Not a customized face" symbol))
428
+ − 3624 (princ "\n '(")
+ − 3625 (prin1 symbol)
+ − 3626 (princ " ")
+ − 3627 (prin1 (get symbol 'saved-face))
+ − 3628 (if (or comment now)
4178
+ − 3629 (princ (if now " t" " nil")))
428
+ − 3630 (when comment
4178
+ − 3631 (princ " ")
+ − 3632 (prin1 comment))
428
+ − 3633 (princ ")"))))
+ − 3634
+ − 3635 (defun custom-save-faces ()
+ − 3636 "Save all customized faces in `custom-file'."
+ − 3637 (save-excursion
+ − 3638 (custom-save-delete 'custom-reset-faces)
+ − 3639 (custom-save-delete 'custom-set-faces)
848
+ − 3640 ;; This leaves point at the end of file.
+ − 3641 ;; Adrian Aichner <adrian@xemacs.org> stated it is
+ − 3642 ;; a bad behavior <npak@ispras.ru>
+ − 3643 ;;(custom-save-delete-any 'custom-reset-faces
+ − 3644 ;; 'custom-set-faces)
428
+ − 3645 (custom-save-resets 'theme-face 'custom-reset-faces '(default))
848
+ − 3646 (let ((standard-output (current-buffer))
4178
+ − 3647 (sorted-list ()))
848
+ − 3648 ;; Create a sorted list of faces
+ − 3649 (mapatoms
+ − 3650 (lambda (symbol)
4178
+ − 3651 (when (custom-save-face-p symbol)
+ − 3652 (push symbol sorted-list))))
2122
+ − 3653 (setq sorted-list (sort sorted-list 'string<))
428
+ − 3654 (unless (bolp)
+ − 3655 (princ "\n"))
+ − 3656 (princ "(custom-set-faces")
+ − 3657 ;; The default face must be first, since it affects the others.
848
+ − 3658 (when (custom-save-face-p 'default)
4178
+ − 3659 (custom-save-face-internal 'default))
428
+ − 3660 (let ((custom-save-face-ignoring '(default)))
848
+ − 3661 (mapc 'custom-save-face-internal
4178
+ − 3662 sorted-list))
428
+ − 3663 (princ ")")
+ − 3664 (unless (looking-at "\n")
+ − 3665 (princ "\n")))))
+ − 3666
848
+ − 3667 (defmacro make-custom-save-resets-mapper (property setter)
+ − 3668 "Create a mapper for `custom-save-resets'."
+ − 3669 `(lambda (object)
+ − 3670 (let ((spec (car-safe (get object (quote ,property))))
4178
+ − 3671 (print-level nil)
+ − 3672 (print-length nil))
848
+ − 3673 (with-boundp '(ignored-special started-writing)
4178
+ − 3674 (when (and (not (memq object ignored-special))
+ − 3675 (eq (car spec) 'user)
+ − 3676 (eq (second spec) 'reset))
+ − 3677 ;; Do not write reset statements unless necessary.
+ − 3678 (unless started-writing
+ − 3679 (setq started-writing t)
+ − 3680 (unless (bolp)
+ − 3681 (princ "\n"))
+ − 3682 (princ "(")
+ − 3683 (princ (quote ,setter))
+ − 3684 (princ "\n '(")
+ − 3685 (prin1 object)
+ − 3686 (princ " ")
+ − 3687 (prin1 (third spec))
+ − 3688 (princ ")")))))))
848
+ − 3689
+ − 3690 (defconst custom-save-resets-mapper-alist
+ − 3691 (eval-when-compile
+ − 3692 (list (list 'theme-value 'custom-reset-variables
4178
+ − 3693 (byte-compile
+ − 3694 (make-custom-save-resets-mapper
+ − 3695 'theme-value 'custom-reset-variables)))
+ − 3696 (list 'theme-face 'custom-reset-faces
+ − 3697 (byte-compile
+ − 3698 (make-custom-save-resets-mapper
+ − 3699 'theme-face 'custom-reset-faces)))))
848
+ − 3700 "Never use it.
+ − 3701 Hashes several heavily used functions for `custom-save-resets'")
+ − 3702
428
+ − 3703 (defun custom-save-resets (property setter special)
848
+ − 3704 (declare (special ignored-special))
428
+ − 3705 (let (started-writing ignored-special)
444
+ − 3706 ;; (custom-save-delete setter) Done by caller
428
+ − 3707 (let ((standard-output (current-buffer))
848
+ − 3708 (mapper (let ((triple (assq property custom-save-resets-mapper-alist)))
4178
+ − 3709 (if (and triple (eq (second triple) setter))
+ − 3710 (third triple)
+ − 3711 (make-custom-save-resets-mapper property setter)))))
428
+ − 3712 (mapc mapper special)
+ − 3713 (setq ignored-special special)
+ − 3714 (mapatoms mapper)
+ − 3715 (when started-writing
848
+ − 3716 (princ ")\n")))))
444
+ − 3717
428
+ − 3718
+ − 3719 (defun custom-save-loaded-themes ()
+ − 3720 (let ((themes (reverse (get 'user 'theme-loads-themes)))
848
+ − 3721 (standard-output (current-buffer))
4178
+ − 3722 (print-level nil)
+ − 3723 (print-length nil))
428
+ − 3724 (when themes
+ − 3725 (unless (bolp) (princ "\n"))
+ − 3726 (princ "(custom-load-themes")
+ − 3727 (mapc (lambda (theme)
+ − 3728 (princ "\n '")
+ − 3729 (prin1 theme)) themes)
444
+ − 3730 (princ " )\n"))))
428
+ − 3731
+ − 3732 ;;;###autoload
+ − 3733 (defun customize-save-customized ()
+ − 3734 "Save all user options which have been set in this session."
+ − 3735 (interactive)
+ − 3736 (mapatoms (lambda (symbol)
+ − 3737 (let ((face (get symbol 'customized-face))
+ − 3738 (value (get symbol 'customized-value))
+ − 3739 (face-comment (get symbol 'customized-face-comment))
+ − 3740 (variable-comment
+ − 3741 (get symbol 'customized-variable-comment)))
+ − 3742 (when face
+ − 3743 (put symbol 'saved-face face)
+ − 3744 (custom-push-theme 'theme-face symbol 'user 'set value)
+ − 3745 (put symbol 'customized-face nil))
+ − 3746 (when value
+ − 3747 (put symbol 'saved-value value)
+ − 3748 (custom-push-theme 'theme-value symbol 'user 'set value)
+ − 3749 (put symbol 'customized-value nil))
+ − 3750 (when variable-comment
+ − 3751 (put symbol 'saved-variable-comment variable-comment)
+ − 3752 (put symbol 'customized-variable-comment nil))
+ − 3753 (when face-comment
+ − 3754 (put symbol 'saved-face-comment face-comment)
+ − 3755 (put symbol 'customized-face-comment nil)))))
+ − 3756 ;; We really should update all custom buffers here.
+ − 3757 (custom-save-all))
+ − 3758
+ − 3759 ;;;###autoload
+ − 3760 (defun custom-save-all ()
+ − 3761 "Save all customizations in `custom-file'."
4257
+ − 3762 (when init-file-had-error
+ − 3763 (error 'invalid-change
+ − 3764 "Cannot save customizations; init file was not fully loaded"))
428
+ − 3765 (let ((inhibit-read-only t))
+ − 3766 (custom-save-variables)
+ − 3767 (custom-save-faces)
+ − 3768 (let ((find-file-hooks nil)
+ − 3769 (auto-mode-alist))
+ − 3770 (with-current-buffer (find-file-noselect custom-file)
+ − 3771 (save-buffer)))))
+ − 3772
+ − 3773
+ − 3774 ;;; The Customize Menu.
+ − 3775
+ − 3776 ;;; Menu support
+ − 3777
+ − 3778 (defun custom-face-menu-create (widget symbol)
+ − 3779 "Ignoring WIDGET, create a menu entry for customization face SYMBOL."
+ − 3780 (vector (custom-unlispify-menu-entry symbol)
+ − 3781 `(customize-face ',symbol)
+ − 3782 t))
+ − 3783
+ − 3784 (defun custom-variable-menu-create (widget symbol)
+ − 3785 "Ignoring WIDGET, create a menu entry for customization variable SYMBOL."
+ − 3786 (let ((type (get symbol 'custom-type)))
+ − 3787 (unless (listp type)
+ − 3788 (setq type (list type)))
+ − 3789 (if (and type (widget-get type :custom-menu))
+ − 3790 (widget-apply type :custom-menu symbol)
+ − 3791 (vector (custom-unlispify-menu-entry symbol)
+ − 3792 `(customize-variable ',symbol)
+ − 3793 t))))
+ − 3794
+ − 3795 ;; Add checkboxes to boolean variable entries.
+ − 3796 (widget-put (get 'boolean 'widget-type)
+ − 3797 :custom-menu (lambda (widget symbol)
+ − 3798 `[,(custom-unlispify-menu-entry symbol)
+ − 3799 (customize-variable ',symbol)
+ − 3800 :style toggle
+ − 3801 :selected ,symbol]))
+ − 3802
+ − 3803 ;; XEmacs can create menus dynamically.
+ − 3804 (defun custom-group-menu-create (widget symbol)
+ − 3805 "Ignoring WIDGET, create a menu entry for customization group SYMBOL."
+ − 3806 `( ,(custom-unlispify-menu-entry symbol t)
+ − 3807 :filter (lambda (&rest junk)
+ − 3808 (let ((item (custom-menu-create ',symbol)))
+ − 3809 (if (listp item)
+ − 3810 (cdr item)
+ − 3811 (list item))))))
+ − 3812
+ − 3813 ;;;###autoload
+ − 3814 (defun custom-menu-create (symbol)
+ − 3815 "Create menu for customization group SYMBOL.
+ − 3816 The menu is in a format applicable to `easy-menu-define'."
2544
+ − 3817 (menu-split-long-menu
+ − 3818 (let* ((item (vector (custom-unlispify-menu-entry symbol)
+ − 3819 `(customize-group ',symbol)
+ − 3820 t)))
+ − 3821 ;; Item is the entry for creating a menu buffer for SYMBOL.
+ − 3822 ;; We may nest, if the menu is not too big.
+ − 3823 (custom-load-custom-defines symbol)
+ − 3824 (if t ;(< (length (get symbol 'custom-group)) widget-menu-max-size)
+ − 3825 ;; The menu is not too big.
+ − 3826 (let ((custom-prefix-list (custom-prefix-add symbol
+ − 3827 custom-prefix-list))
+ − 3828 (members (custom-sort-items (get symbol 'custom-group)
+ − 3829 custom-menu-sort-alphabetically
+ − 3830 custom-menu-order-groups)))
+ − 3831 ;; Create the menu.
+ − 3832 `(,(custom-unlispify-menu-entry symbol t)
+ − 3833 ,item
+ − 3834 "--"
+ − 3835 ,@(mapcar (lambda (entry)
+ − 3836 (widget-apply (if (listp (nth 1 entry))
+ − 3837 (nth 1 entry)
+ − 3838 (list (nth 1 entry)))
+ − 3839 :custom-menu (nth 0 entry)))
+ − 3840 members)))
+ − 3841 ; else ;; The menu was too big.
+ − 3842 item
+ − 3843 ))))
428
+ − 3844
+ − 3845 ;;;###autoload
+ − 3846 (defun customize-menu-create (symbol &optional name)
+ − 3847 "Return a customize menu for customization group SYMBOL.
+ − 3848 If optional NAME is given, use that as the name of the menu.
+ − 3849 Otherwise the menu will be named `Customize'.
+ − 3850 The format is suitable for use with `easy-menu-define'."
+ − 3851 (unless name
+ − 3852 (setq name "Customize"))
+ − 3853 `(,name
+ − 3854 :filter (lambda (&rest junk)
+ − 3855 (cdr (custom-menu-create ',symbol)))))
+ − 3856
+ − 3857 ;;; The Custom Mode.
+ − 3858
+ − 3859 (defvar custom-mode-map nil
+ − 3860 "Keymap for `custom-mode'.")
+ − 3861
+ − 3862 (unless custom-mode-map
+ − 3863 (setq custom-mode-map (make-sparse-keymap))
+ − 3864 (set-keymap-parents custom-mode-map widget-keymap)
+ − 3865 (suppress-keymap custom-mode-map)
+ − 3866 (define-key custom-mode-map " " 'scroll-up)
+ − 3867 (define-key custom-mode-map [delete] 'scroll-down)
+ − 3868 (define-key custom-mode-map "q" 'Custom-buffer-done)
+ − 3869 (define-key custom-mode-map "u" 'Custom-goto-parent)
+ − 3870 (define-key custom-mode-map "n" 'widget-forward)
+ − 3871 (define-key custom-mode-map "p" 'widget-backward))
+ − 3872
+ − 3873 (easy-menu-define Custom-mode-menu
+ − 3874 custom-mode-map
+ − 3875 "Menu used in customization buffers."
+ − 3876 `("Custom"
+ − 3877 ,(customize-menu-create 'customize)
+ − 3878 ["Set" Custom-set t]
+ − 3879 ["Save" Custom-save t]
+ − 3880 ["Reset to Current" Custom-reset-current t]
+ − 3881 ["Reset to Saved" Custom-reset-saved t]
+ − 3882 ["Reset to Standard Settings" Custom-reset-standard t]
+ − 3883 ["Info" (Info-goto-node "(xemacs)Easy Customization") t]))
+ − 3884
+ − 3885 (defun Custom-goto-parent ()
+ − 3886 "Go to the parent group listed at the top of this buffer.
+ − 3887 If several parents are listed, go to the first of them."
+ − 3888 (interactive)
+ − 3889 (save-excursion
+ − 3890 (goto-char (point-min))
+ − 3891 (if (search-forward "\nGo to parent group: " nil t)
+ − 3892 (let* ((button (get-char-property (point) 'button))
+ − 3893 (parent (downcase (widget-get button :tag))))
+ − 3894 (customize-group parent)))))
+ − 3895
+ − 3896 (defcustom custom-mode-hook nil
+ − 3897 "Hook called when entering custom-mode."
+ − 3898 :type 'hook
+ − 3899 :group 'custom-buffer )
+ − 3900
+ − 3901 (defun custom-state-buffer-message (widget)
+ − 3902 (if (eq (widget-get (widget-get widget :parent) :custom-state) 'modified)
+ − 3903 (message
+ − 3904 "To install your edits, invoke [State] and choose the Set operation")))
+ − 3905
+ − 3906 (defun custom-mode ()
+ − 3907 "Major mode for editing customization buffers.
+ − 3908
+ − 3909 The following commands are available:
+ − 3910
+ − 3911 Move to next button or editable field. \\[widget-forward]
+ − 3912 Move to previous button or editable field. \\[widget-backward]
+ − 3913 \\<widget-field-keymap>\
+ − 3914 Complete content of editable text field. \\[widget-complete]
+ − 3915 \\<custom-mode-map>\
+ − 3916 Invoke button under point. \\[widget-button-press]
+ − 3917 Set all modifications. \\[Custom-set]
+ − 3918 Make all modifications default. \\[Custom-save]
4178
+ − 3919 Reset all modified options. \\[Custom-reset-current]
428
+ − 3920 Reset all modified or set options. \\[Custom-reset-saved]
+ − 3921 Reset all options. \\[Custom-reset-standard]
+ − 3922
+ − 3923 Entry to this mode calls the value of `custom-mode-hook'
+ − 3924 if that value is non-nil."
+ − 3925 (kill-all-local-variables)
+ − 3926 (setq major-mode 'custom-mode
+ − 3927 mode-name "Custom")
+ − 3928 (use-local-map custom-mode-map)
+ − 3929 (easy-menu-add Custom-mode-menu)
+ − 3930 (make-local-variable 'custom-options)
+ − 3931 (make-local-variable 'widget-documentation-face)
+ − 3932 (setq widget-documentation-face 'custom-documentation-face)
+ − 3933 (make-local-variable 'widget-button-face)
+ − 3934 (setq widget-button-face 'custom-button-face)
+ − 3935 (make-local-hook 'widget-edit-functions)
+ − 3936 (add-hook 'widget-edit-functions 'custom-state-buffer-message nil t)
+ − 3937 (run-hooks 'custom-mode-hook))
+ − 3938
+ − 3939
442
+ − 3940 ;;;###autoload
+ − 3941 (defun custom-migrate-custom-file (new-custom-file-name)
+ − 3942 "Migrate custom file from home directory."
+ − 3943 (mapc 'custom-save-delete
+ − 3944 '(custom-load-themes custom-reset-variables
+ − 3945 custom-set-variables
+ − 3946 custom-set-faces
+ − 3947 custom-reset-faces))
+ − 3948 (with-current-buffer (find-file-noselect custom-file)
+ − 3949 (save-buffer))
+ − 3950 (setq custom-file new-custom-file-name)
+ − 3951 (custom-save-all))
+ − 3952
428
+ − 3953 ;;; The End.
+ − 3954
+ − 3955 (provide 'cus-edit)
+ − 3956
+ − 3957 ;; cus-edit.el ends here
