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