diff options
| author | Per Abrahamsen | 1997-04-12 17:51:31 +0000 |
|---|---|---|
| committer | Per Abrahamsen | 1997-04-12 17:51:31 +0000 |
| commit | bd042c030f6530726313e4ff55065df7e2ee41a9 (patch) | |
| tree | abb71fe08c194635b74c71d314bcc23c319790b3 /lisp | |
| parent | c5292bc831ae97cd0d99234c039c9309c05af2a6 (diff) | |
| download | emacs-bd042c030f6530726313e4ff55065df7e2ee41a9.tar.gz emacs-bd042c030f6530726313e4ff55065df7e2ee41a9.zip | |
Sync with 1.84.
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/cus-edit.el | 548 | ||||
| -rw-r--r-- | lisp/cus-face.el | 65 | ||||
| -rw-r--r-- | lisp/custom.el | 36 | ||||
| -rw-r--r-- | lisp/wid-browse.el | 34 | ||||
| -rw-r--r-- | lisp/wid-edit.el | 7 | ||||
| -rw-r--r-- | lisp/widget.el | 7 |
6 files changed, 463 insertions, 234 deletions
diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 0327c7aa286..aee2ef02679 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el | |||
| @@ -4,7 +4,7 @@ | |||
| 4 | ;; | 4 | ;; |
| 5 | ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> | 5 | ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> |
| 6 | ;; Keywords: help, faces | 6 | ;; Keywords: help, faces |
| 7 | ;; Version: 1.71 | 7 | ;; Version: 1.84 |
| 8 | ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ | 8 | ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ |
| 9 | 9 | ||
| 10 | ;;; Commentary: | 10 | ;;; Commentary: |
| @@ -22,6 +22,10 @@ | |||
| 22 | :custom-set :custom-save :custom-reset-current :custom-reset-saved | 22 | :custom-set :custom-save :custom-reset-current :custom-reset-saved |
| 23 | :custom-reset-factory) | 23 | :custom-reset-factory) |
| 24 | 24 | ||
| 25 | (put 'custom-define-hook 'custom-type 'hook) | ||
| 26 | (put 'custom-define-hook 'factory-value '(nil)) | ||
| 27 | (custom-add-to-group 'customize 'custom-define-hook 'custom-variable) | ||
| 28 | |||
| 25 | ;;; Customization Groups. | 29 | ;;; Customization Groups. |
| 26 | 30 | ||
| 27 | (defgroup emacs nil | 31 | (defgroup emacs nil |
| @@ -202,9 +206,90 @@ | |||
| 202 | :link '(url-link :tag "Development Page" | 206 | :link '(url-link :tag "Development Page" |
| 203 | "http://www.dina.kvl.dk/~abraham/custom/") | 207 | "http://www.dina.kvl.dk/~abraham/custom/") |
| 204 | :prefix "custom-" | 208 | :prefix "custom-" |
| 205 | :group 'help | 209 | :group 'help) |
| 210 | |||
| 211 | (defgroup custom-faces nil | ||
| 212 | "Faces used by customize." | ||
| 213 | :group 'customize | ||
| 206 | :group 'faces) | 214 | :group 'faces) |
| 207 | 215 | ||
| 216 | (defgroup abbrev-mode nil | ||
| 217 | "Word abbreviations mode." | ||
| 218 | :group 'abbrev) | ||
| 219 | |||
| 220 | (defgroup alloc nil | ||
| 221 | "Storage allocation and gc for GNU Emacs Lisp interpreter." | ||
| 222 | :tag "Storage Allocation" | ||
| 223 | :group 'internal) | ||
| 224 | |||
| 225 | (defgroup undo nil | ||
| 226 | "Undoing changes in buffers." | ||
| 227 | :group 'editing) | ||
| 228 | |||
| 229 | (defgroup modeline nil | ||
| 230 | "Content of the modeline." | ||
| 231 | :group 'environment) | ||
| 232 | |||
| 233 | (defgroup fill nil | ||
| 234 | "Indenting and filling text." | ||
| 235 | :group 'editing) | ||
| 236 | |||
| 237 | (defgroup editing-basics nil | ||
| 238 | "Most basic editing facilities." | ||
| 239 | :group 'editing) | ||
| 240 | |||
| 241 | (defgroup display nil | ||
| 242 | "How characters are displayed in buffers." | ||
| 243 | :group 'environment) | ||
| 244 | |||
| 245 | (defgroup execute nil | ||
| 246 | "Executing external commands." | ||
| 247 | :group 'processes) | ||
| 248 | |||
| 249 | (defgroup installation nil | ||
| 250 | "The Emacs installation." | ||
| 251 | :group 'environment) | ||
| 252 | |||
| 253 | (defgroup dired nil | ||
| 254 | "Directory editing." | ||
| 255 | :group 'environment) | ||
| 256 | |||
| 257 | (defgroup limits nil | ||
| 258 | "Internal Emacs limits." | ||
| 259 | :group 'internal) | ||
| 260 | |||
| 261 | (defgroup debug nil | ||
| 262 | "Debugging Emacs itself." | ||
| 263 | :group 'development) | ||
| 264 | |||
| 265 | (defgroup minibuffer nil | ||
| 266 | "Controling the behaviour of the minibuffer." | ||
| 267 | :group 'environment) | ||
| 268 | |||
| 269 | (defgroup keyboard nil | ||
| 270 | "Input from the keyboard." | ||
| 271 | :group 'environment) | ||
| 272 | |||
| 273 | (defgroup mouse nil | ||
| 274 | "Input from the mouse." | ||
| 275 | :group 'environment) | ||
| 276 | |||
| 277 | (defgroup menu nil | ||
| 278 | "Input from the menus." | ||
| 279 | :group 'environment) | ||
| 280 | |||
| 281 | (defgroup auto-save nil | ||
| 282 | "Preventing accidential loss of data." | ||
| 283 | :group 'data) | ||
| 284 | |||
| 285 | (defgroup processes-basics nil | ||
| 286 | "Basic stuff dealing with processes." | ||
| 287 | :group 'processes) | ||
| 288 | |||
| 289 | (defgroup windows nil | ||
| 290 | "Windows within a frame." | ||
| 291 | :group 'processes) | ||
| 292 | |||
| 208 | ;;; Utilities. | 293 | ;;; Utilities. |
| 209 | 294 | ||
| 210 | (defun custom-quote (sexp) | 295 | (defun custom-quote (sexp) |
| @@ -236,6 +321,23 @@ IF REGEXP is not a string, return it unchanged." | |||
| 236 | (nreverse (cons (substring regexp start) all))) | 321 | (nreverse (cons (substring regexp start) all))) |
| 237 | regexp)) | 322 | regexp)) |
| 238 | 323 | ||
| 324 | (defun custom-variable-prompt () | ||
| 325 | ;; Code stolen from `help.el'. | ||
| 326 | "Prompt for a variable, defaulting to the variable at point. | ||
| 327 | Return a list suitable for use in `interactive'." | ||
| 328 | (let ((v (variable-at-point)) | ||
| 329 | (enable-recursive-minibuffers t) | ||
| 330 | val) | ||
| 331 | (setq val (completing-read | ||
| 332 | (if v | ||
| 333 | (format "Customize variable (default %s): " v) | ||
| 334 | "Customize variable: ") | ||
| 335 | obarray 'boundp t)) | ||
| 336 | (list (if (equal val "") | ||
| 337 | v (intern val))))) | ||
| 338 | |||
| 339 | ;;; Unlispify. | ||
| 340 | |||
| 239 | (defvar custom-prefix-list nil | 341 | (defvar custom-prefix-list nil |
| 240 | "List of prefixes that should be ignored by `custom-unlispify'") | 342 | "List of prefixes that should be ignored by `custom-unlispify'") |
| 241 | 343 | ||
| @@ -258,6 +360,10 @@ IF REGEXP is not a string, return it unchanged." | |||
| 258 | (erase-buffer) | 360 | (erase-buffer) |
| 259 | (princ symbol (current-buffer)) | 361 | (princ symbol (current-buffer)) |
| 260 | (goto-char (point-min)) | 362 | (goto-char (point-min)) |
| 363 | (when (and (eq (get symbol 'custom-type) 'boolean) | ||
| 364 | (re-search-forward "-p\\'" nil t)) | ||
| 365 | (replace-match "" t t) | ||
| 366 | (goto-char (point-min))) | ||
| 261 | (let ((prefixes custom-prefix-list) | 367 | (let ((prefixes custom-prefix-list) |
| 262 | prefix) | 368 | prefix) |
| 263 | (while prefixes | 369 | (while prefixes |
| @@ -290,62 +396,73 @@ IF REGEXP is not a string, return it unchanged." | |||
| 290 | (concat (symbol-name symbol) "-")) | 396 | (concat (symbol-name symbol) "-")) |
| 291 | prefixes)) | 397 | prefixes)) |
| 292 | 398 | ||
| 293 | ;;; The Custom Mode. | 399 | ;;; Guess. |
| 294 | 400 | ||
| 295 | (defvar custom-options nil | 401 | (defcustom custom-guess-name-alist |
| 296 | "Customization widgets in the current buffer.") | 402 | '(("-p\\'" boolean) |
| 297 | 403 | ("-hook\\'" hook) | |
| 298 | (defvar custom-mode-map nil | 404 | ("-face\\'" face) |
| 299 | "Keymap for `custom-mode'.") | 405 | ("-file\\'" file) |
| 300 | 406 | ("-function\\'" function) | |
| 301 | (unless custom-mode-map | 407 | ("-functions\\'" (repeat function)) |
| 302 | (setq custom-mode-map (make-sparse-keymap)) | 408 | ("-list\\'" (repeat sexp)) |
| 303 | (set-keymap-parent custom-mode-map widget-keymap) | 409 | ("-alist\\'" (repeat (cons sexp sexp)))) |
| 304 | (define-key custom-mode-map "q" 'bury-buffer)) | 410 | "Alist of (MATCH TYPE). |
| 305 | 411 | ||
| 306 | (easy-menu-define custom-mode-menu | 412 | MATCH should be a regexp matching the name of a symbol, and TYPE should |
| 307 | custom-mode-map | 413 | be a widget suitable for editing the value of that symbol. The TYPE |
| 308 | "Menu used in customization buffers." | 414 | of the first entry where MATCH matches the name of the symbol will be |
| 309 | '("Custom" | 415 | used. |
| 310 | ["Set" custom-set t] | 416 | |
| 311 | ["Save" custom-save t] | 417 | This is used for guessing the type of variables not declared with |
| 312 | ["Reset to Current" custom-reset-current t] | 418 | customize." |
| 313 | ["Reset to Saved" custom-reset-saved t] | 419 | :type '(repeat (group (regexp :tag "Match") (sexp :tag "Type"))) |
| 314 | ["Reset to Factory Settings" custom-reset-factory t] | ||
| 315 | ["Info" (Info-goto-node "(custom)The Customization Buffer") t])) | ||
| 316 | |||
| 317 | (defcustom custom-mode-hook nil | ||
| 318 | "Hook called when entering custom-mode." | ||
| 319 | :type 'hook | ||
| 320 | :group 'customize) | 420 | :group 'customize) |
| 321 | 421 | ||
| 322 | (defun custom-mode () | 422 | (defcustom custom-guess-doc-alist |
| 323 | "Major mode for editing customization buffers. | 423 | '(("\\`\\*?Non-nil " boolean)) |
| 424 | "Alist of (MATCH TYPE). | ||
| 324 | 425 | ||
| 325 | The following commands are available: | 426 | MATCH should be a regexp matching a documentation string, and TYPE |
| 427 | should be a widget suitable for editing the value of a variable with | ||
| 428 | that documentation string. The TYPE of the first entry where MATCH | ||
| 429 | matches the name of the symbol will be used. | ||
| 326 | 430 | ||
| 327 | \\[widget-forward] Move to next button or editable field. | 431 | This is used for guessing the type of variables not declared with |
| 328 | \\[widget-backward] Move to previous button or editable field. | 432 | customize." |
| 329 | \\[widget-button-click] Activate button under the mouse pointer. | 433 | :type '(repeat (group (regexp :tag "Match") (sexp :tag "Type"))) |
| 330 | \\[widget-button-press] Activate button under point. | 434 | :group 'customize) |
| 331 | \\[custom-set] Set all modifications. | ||
| 332 | \\[custom-save] Make all modifications default. | ||
| 333 | \\[custom-reset-current] Reset all modified options. | ||
| 334 | \\[custom-reset-saved] Reset all modified or set options. | ||
| 335 | \\[custom-reset-factory] Reset all options. | ||
| 336 | 435 | ||
| 337 | Entry to this mode calls the value of `custom-mode-hook' | 436 | (defun custom-guess-type (symbol) |
| 338 | if that value is non-nil." | 437 | "Guess a widget suitable for editing the value of SYMBOL. |
| 339 | (kill-all-local-variables) | 438 | This is done by matching SYMBOL with `custom-guess-name-alist' and |
| 340 | (setq major-mode 'custom-mode | 439 | if that fails, the doc string with `custom-guess-doc-alist'." |
| 341 | mode-name "Custom") | 440 | (let ((name (symbol-name symbol)) |
| 342 | (use-local-map custom-mode-map) | 441 | (names custom-guess-name-alist) |
| 343 | (easy-menu-add custom-mode-menu) | 442 | current found) |
| 344 | (make-local-variable 'custom-options) | 443 | (while names |
| 345 | (run-hooks 'custom-mode-hook)) | 444 | (setq current (car names) |
| 445 | names (cdr names)) | ||
| 446 | (when (string-match (nth 0 current) name) | ||
| 447 | (setq found (nth 1 current) | ||
| 448 | names nil))) | ||
| 449 | (unless found | ||
| 450 | (let ((doc (documentation-property symbol 'variable-documentation)) | ||
| 451 | (docs custom-guess-doc-alist)) | ||
| 452 | (when doc | ||
| 453 | (while docs | ||
| 454 | (setq current (car docs) | ||
| 455 | docs (cdr docs)) | ||
| 456 | (when (string-match (nth 0 current) doc) | ||
| 457 | (setq found (nth 1 current) | ||
| 458 | docs nil)))))) | ||
| 459 | found)) | ||
| 346 | 460 | ||
| 347 | ;;; Custom Mode Commands. | 461 | ;;; Custom Mode Commands. |
| 348 | 462 | ||
| 463 | (defvar custom-options nil | ||
| 464 | "Customization widgets in the current buffer.") | ||
| 465 | |||
| 349 | (defun custom-set () | 466 | (defun custom-set () |
| 350 | "Set changes in all modified options." | 467 | "Set changes in all modified options." |
| 351 | (interactive) | 468 | (interactive) |
| @@ -430,21 +547,17 @@ when the action is chosen.") | |||
| 430 | ;;;###autoload | 547 | ;;;###autoload |
| 431 | (defun customize-variable (symbol) | 548 | (defun customize-variable (symbol) |
| 432 | "Customize SYMBOL, which must be a variable." | 549 | "Customize SYMBOL, which must be a variable." |
| 433 | (interactive | 550 | (interactive (custom-variable-prompt)) |
| 434 | ;; Code stolen from `help.el'. | ||
| 435 | (let ((v (variable-at-point)) | ||
| 436 | (enable-recursive-minibuffers t) | ||
| 437 | val) | ||
| 438 | (setq val (completing-read | ||
| 439 | (if v | ||
| 440 | (format "Customize variable (default %s): " v) | ||
| 441 | "Customize variable: ") | ||
| 442 | obarray 'boundp t)) | ||
| 443 | (list (if (equal val "") | ||
| 444 | v (intern val))))) | ||
| 445 | (custom-buffer-create (list (list symbol 'custom-variable)))) | 551 | (custom-buffer-create (list (list symbol 'custom-variable)))) |
| 446 | 552 | ||
| 447 | ;;;###autoload | 553 | ;;;###autoload |
| 554 | (defun customize-variable-other-window (symbol) | ||
| 555 | "Customize SYMBOL, which must be a variable. | ||
| 556 | Show the buffer in another window, but don't select it." | ||
| 557 | (interactive (custom-variable-prompt)) | ||
| 558 | (custom-buffer-create-other-window (list (list symbol 'custom-variable)))) | ||
| 559 | |||
| 560 | ;;;###autoload | ||
| 448 | (defun customize-face (&optional symbol) | 561 | (defun customize-face (&optional symbol) |
| 449 | "Customize SYMBOL, which should be a face name or nil. | 562 | "Customize SYMBOL, which should be a face name or nil. |
| 450 | If SYMBOL is nil, customize all faces." | 563 | If SYMBOL is nil, customize all faces." |
| @@ -455,7 +568,10 @@ If SYMBOL is nil, customize all faces." | |||
| 455 | (message "Looking for faces...") | 568 | (message "Looking for faces...") |
| 456 | (mapcar (lambda (symbol) | 569 | (mapcar (lambda (symbol) |
| 457 | (setq found (cons (list symbol 'custom-face) found))) | 570 | (setq found (cons (list symbol 'custom-face) found))) |
| 458 | (face-list)) | 571 | (nreverse (mapcar 'intern |
| 572 | (sort (mapcar 'symbol-name (face-list)) | ||
| 573 | 'string<)))) | ||
| 574 | |||
| 459 | (custom-buffer-create found)) | 575 | (custom-buffer-create found)) |
| 460 | (if (stringp symbol) | 576 | (if (stringp symbol) |
| 461 | (setq symbol (intern symbol))) | 577 | (setq symbol (intern symbol))) |
| @@ -464,6 +580,19 @@ If SYMBOL is nil, customize all faces." | |||
| 464 | (custom-buffer-create (list (list symbol 'custom-face))))) | 580 | (custom-buffer-create (list (list symbol 'custom-face))))) |
| 465 | 581 | ||
| 466 | ;;;###autoload | 582 | ;;;###autoload |
| 583 | (defun customize-face-other-window (&optional symbol) | ||
| 584 | "Show customization buffer for FACE in other window." | ||
| 585 | (interactive (list (completing-read "Customize face: " | ||
| 586 | obarray 'custom-facep))) | ||
| 587 | (if (or (null symbol) (and (stringp symbol) (zerop (length symbol)))) | ||
| 588 | () | ||
| 589 | (if (stringp symbol) | ||
| 590 | (setq symbol (intern symbol))) | ||
| 591 | (unless (symbolp symbol) | ||
| 592 | (error "Should be a symbol %S" symbol)) | ||
| 593 | (custom-buffer-create-other-window (list (list symbol 'custom-face))))) | ||
| 594 | |||
| 595 | ;;;###autoload | ||
| 467 | (defun customize-customized () | 596 | (defun customize-customized () |
| 468 | "Customize all already customized user options." | 597 | "Customize all already customized user options." |
| 469 | (interactive) | 598 | (interactive) |
| @@ -511,9 +640,24 @@ user-settable." | |||
| 511 | OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where | 640 | OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where |
| 512 | SYMBOL is a customization option, and WIDGET is a widget for editing | 641 | SYMBOL is a customization option, and WIDGET is a widget for editing |
| 513 | that option." | 642 | that option." |
| 514 | (message "Creating customization buffer...") | ||
| 515 | (kill-buffer (get-buffer-create "*Customization*")) | 643 | (kill-buffer (get-buffer-create "*Customization*")) |
| 516 | (switch-to-buffer (get-buffer-create "*Customization*")) | 644 | (switch-to-buffer (get-buffer-create "*Customization*")) |
| 645 | (custom-buffer-create-internal options)) | ||
| 646 | |||
| 647 | (defun custom-buffer-create-other-window (options) | ||
| 648 | "Create a buffer containing OPTIONS. | ||
| 649 | OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where | ||
| 650 | SYMBOL is a customization option, and WIDGET is a widget for editing | ||
| 651 | that option." | ||
| 652 | (kill-buffer (get-buffer-create "*Customization*")) | ||
| 653 | (let ((window (selected-window))) | ||
| 654 | (switch-to-buffer-other-window (get-buffer-create "*Customization*")) | ||
| 655 | (custom-buffer-create-internal options) | ||
| 656 | (select-window window))) | ||
| 657 | |||
| 658 | |||
| 659 | (defun custom-buffer-create-internal (options) | ||
| 660 | (message "Creating customization buffer...") | ||
| 517 | (custom-mode) | 661 | (custom-mode) |
| 518 | (widget-insert "This is a customization buffer. | 662 | (widget-insert "This is a customization buffer. |
| 519 | Push RET or click mouse-2 on the word ") | 663 | Push RET or click mouse-2 on the word ") |
| @@ -753,7 +897,8 @@ The list should be sorted most significant first." | |||
| 753 | (string :tag "Magic") | 897 | (string :tag "Magic") |
| 754 | face | 898 | face |
| 755 | (string :tag "Description")))) | 899 | (string :tag "Description")))) |
| 756 | :group 'customize) | 900 | :group 'customize |
| 901 | :group 'custom-faces) | ||
| 757 | 902 | ||
| 758 | (defcustom custom-magic-show 'long | 903 | (defcustom custom-magic-show 'long |
| 759 | "Show long description of the state of each customization option." | 904 | "Show long description of the state of each customization option." |
| @@ -956,22 +1101,27 @@ Change the state of this item." | |||
| 956 | (t | 1101 | (t |
| 957 | (funcall show widget value))))) | 1102 | (funcall show widget value))))) |
| 958 | 1103 | ||
| 1104 | (defvar custom-load-recursion nil | ||
| 1105 | "Hack to avoid recursive dependencies.") | ||
| 1106 | |||
| 959 | (defun custom-load-symbol (symbol) | 1107 | (defun custom-load-symbol (symbol) |
| 960 | "Load all dependencies for SYMBOL." | 1108 | "Load all dependencies for SYMBOL." |
| 961 | (let ((loads (get symbol 'custom-loads)) | 1109 | (unless custom-load-recursion |
| 962 | load) | 1110 | (let ((custom-load-recursion t) |
| 963 | (while loads | 1111 | (loads (get symbol 'custom-loads)) |
| 964 | (setq load (car loads) | 1112 | load) |
| 965 | loads (cdr loads)) | 1113 | (while loads |
| 966 | (cond ((symbolp load) | 1114 | (setq load (car loads) |
| 967 | (condition-case nil | 1115 | loads (cdr loads)) |
| 968 | (require load) | 1116 | (cond ((symbolp load) |
| 969 | (error nil))) | 1117 | (condition-case nil |
| 970 | ((assoc load load-history)) | 1118 | (require load) |
| 971 | (t | 1119 | (error nil))) |
| 972 | (condition-case nil | 1120 | ((assoc load load-history)) |
| 973 | (load-library load) | 1121 | (t |
| 974 | (error nil))))))) | 1122 | (condition-case nil |
| 1123 | (load-library load) | ||
| 1124 | (error nil)))))))) | ||
| 975 | 1125 | ||
| 976 | (defun custom-load-widget (widget) | 1126 | (defun custom-load-widget (widget) |
| 977 | "Load all dependencies for WIDGET." | 1127 | "Load all dependencies for WIDGET." |
| @@ -981,11 +1131,11 @@ Change the state of this item." | |||
| 981 | 1131 | ||
| 982 | (defface custom-variable-sample-face '((t (:underline t))) | 1132 | (defface custom-variable-sample-face '((t (:underline t))) |
| 983 | "Face used for unpushable variable tags." | 1133 | "Face used for unpushable variable tags." |
| 984 | :group 'customize) | 1134 | :group 'custom-faces) |
| 985 | 1135 | ||
| 986 | (defface custom-variable-button-face '((t (:underline t :bold t))) | 1136 | (defface custom-variable-button-face '((t (:underline t :bold t))) |
| 987 | "Face used for pushable variable tags." | 1137 | "Face used for pushable variable tags." |
| 988 | :group 'customize) | 1138 | :group 'custom-faces) |
| 989 | 1139 | ||
| 990 | (define-widget 'custom-variable 'custom | 1140 | (define-widget 'custom-variable 'custom |
| 991 | "Customize variable." | 1141 | "Customize variable." |
| @@ -1003,6 +1153,22 @@ Change the state of this item." | |||
| 1003 | :custom-reset-saved 'custom-variable-reset-saved | 1153 | :custom-reset-saved 'custom-variable-reset-saved |
| 1004 | :custom-reset-factory 'custom-variable-reset-factory) | 1154 | :custom-reset-factory 'custom-variable-reset-factory) |
| 1005 | 1155 | ||
| 1156 | (defun custom-variable-type (symbol) | ||
| 1157 | "Return a widget suitable for editing the value of SYMBOL. | ||
| 1158 | If SYMBOL has a `custom-type' property, use that. | ||
| 1159 | Otherwise, look up symbol in `custom-guess-type-alist'." | ||
| 1160 | (let* ((type (or (get symbol 'custom-type) | ||
| 1161 | (and (not (get symbol 'factory-value)) | ||
| 1162 | (custom-guess-type symbol)) | ||
| 1163 | 'sexp)) | ||
| 1164 | (options (get symbol 'custom-options)) | ||
| 1165 | (tmp (if (listp type) | ||
| 1166 | (copy-list type) | ||
| 1167 | (list type)))) | ||
| 1168 | (when options | ||
| 1169 | (widget-put tmp :options options)) | ||
| 1170 | tmp)) | ||
| 1171 | |||
| 1006 | (defun custom-variable-value-create (widget) | 1172 | (defun custom-variable-value-create (widget) |
| 1007 | "Here is where you edit the variables value." | 1173 | "Here is where you edit the variables value." |
| 1008 | (custom-load-widget widget) | 1174 | (custom-load-widget widget) |
| @@ -1011,15 +1177,8 @@ Change the state of this item." | |||
| 1011 | (form (widget-get widget :custom-form)) | 1177 | (form (widget-get widget :custom-form)) |
| 1012 | (state (widget-get widget :custom-state)) | 1178 | (state (widget-get widget :custom-state)) |
| 1013 | (symbol (widget-get widget :value)) | 1179 | (symbol (widget-get widget :value)) |
| 1014 | (options (get symbol 'custom-options)) | ||
| 1015 | (child-type (or (get symbol 'custom-type) 'sexp)) | ||
| 1016 | (tag (widget-get widget :tag)) | 1180 | (tag (widget-get widget :tag)) |
| 1017 | (type (let ((tmp (if (listp child-type) | 1181 | (type (custom-variable-type symbol)) |
| 1018 | (copy-list child-type) | ||
| 1019 | (list child-type)))) | ||
| 1020 | (when options | ||
| 1021 | (widget-put tmp :options options)) | ||
| 1022 | tmp)) | ||
| 1023 | (conv (widget-convert type)) | 1182 | (conv (widget-convert type)) |
| 1024 | (value (if (default-boundp symbol) | 1183 | (value (if (default-boundp symbol) |
| 1025 | (default-value symbol) | 1184 | (default-value symbol) |
| @@ -1162,10 +1321,10 @@ Optional EVENT is the location for the menu." | |||
| 1162 | (goto-char (widget-get val :from)) | 1321 | (goto-char (widget-get val :from)) |
| 1163 | (error "%s" (widget-get val :error))) | 1322 | (error "%s" (widget-get val :error))) |
| 1164 | ((eq form 'lisp) | 1323 | ((eq form 'lisp) |
| 1165 | (set symbol (eval (setq val (widget-value child)))) | 1324 | (set-default symbol (eval (setq val (widget-value child)))) |
| 1166 | (put symbol 'customized-value (list val))) | 1325 | (put symbol 'customized-value (list val))) |
| 1167 | (t | 1326 | (t |
| 1168 | (set symbol (setq val (widget-value child))) | 1327 | (set-default symbol (setq val (widget-value child))) |
| 1169 | (put symbol 'customized-value (list (custom-quote val))))) | 1328 | (put symbol 'customized-value (list (custom-quote val))))) |
| 1170 | (custom-variable-state-set widget) | 1329 | (custom-variable-state-set widget) |
| 1171 | (custom-redraw-magic widget))) | 1330 | (custom-redraw-magic widget))) |
| @@ -1184,12 +1343,12 @@ Optional EVENT is the location for the menu." | |||
| 1184 | (error "%s" (widget-get val :error))) | 1343 | (error "%s" (widget-get val :error))) |
| 1185 | ((eq form 'lisp) | 1344 | ((eq form 'lisp) |
| 1186 | (put symbol 'saved-value (list (widget-value child))) | 1345 | (put symbol 'saved-value (list (widget-value child))) |
| 1187 | (set symbol (eval (widget-value child)))) | 1346 | (set-default symbol (eval (widget-value child)))) |
| 1188 | (t | 1347 | (t |
| 1189 | (put symbol | 1348 | (put symbol |
| 1190 | 'saved-value (list (custom-quote (widget-value | 1349 | 'saved-value (list (custom-quote (widget-value |
| 1191 | child)))) | 1350 | child)))) |
| 1192 | (set symbol (widget-value child)))) | 1351 | (set-default symbol (widget-value child)))) |
| 1193 | (put symbol 'customized-value nil) | 1352 | (put symbol 'customized-value nil) |
| 1194 | (custom-save-all) | 1353 | (custom-save-all) |
| 1195 | (custom-variable-state-set widget) | 1354 | (custom-variable-state-set widget) |
| @@ -1200,7 +1359,7 @@ Optional EVENT is the location for the menu." | |||
| 1200 | (let ((symbol (widget-value widget))) | 1359 | (let ((symbol (widget-value widget))) |
| 1201 | (if (get symbol 'saved-value) | 1360 | (if (get symbol 'saved-value) |
| 1202 | (condition-case nil | 1361 | (condition-case nil |
| 1203 | (set symbol (eval (car (get symbol 'saved-value)))) | 1362 | (set-default symbol (eval (car (get symbol 'saved-value)))) |
| 1204 | (error nil)) | 1363 | (error nil)) |
| 1205 | (error "No saved value for %s" symbol)) | 1364 | (error "No saved value for %s" symbol)) |
| 1206 | (put symbol 'customized-value nil) | 1365 | (put symbol 'customized-value nil) |
| @@ -1211,7 +1370,7 @@ Optional EVENT is the location for the menu." | |||
| 1211 | "Restore the factory setting for the variable being edited by WIDGET." | 1370 | "Restore the factory setting for the variable being edited by WIDGET." |
| 1212 | (let ((symbol (widget-value widget))) | 1371 | (let ((symbol (widget-value widget))) |
| 1213 | (if (get symbol 'factory-value) | 1372 | (if (get symbol 'factory-value) |
| 1214 | (set symbol (eval (car (get symbol 'factory-value)))) | 1373 | (set-default symbol (eval (car (get symbol 'factory-value)))) |
| 1215 | (error "No factory default for %S" symbol)) | 1374 | (error "No factory default for %S" symbol)) |
| 1216 | (put symbol 'customized-value nil) | 1375 | (put symbol 'customized-value nil) |
| 1217 | (when (get symbol 'saved-value) | 1376 | (when (get symbol 'saved-value) |
| @@ -1311,7 +1470,7 @@ Match frames with dark backgrounds.") | |||
| 1311 | 1470 | ||
| 1312 | (defface custom-face-tag-face '((t (:underline t))) | 1471 | (defface custom-face-tag-face '((t (:underline t))) |
| 1313 | "Face used for face tags." | 1472 | "Face used for face tags." |
| 1314 | :group 'customize) | 1473 | :group 'custom-faces) |
| 1315 | 1474 | ||
| 1316 | (define-widget 'custom-face 'custom | 1475 | (define-widget 'custom-face 'custom |
| 1317 | "Customize face." | 1476 | "Customize face." |
| @@ -1613,7 +1772,7 @@ The first member is used for level 1 groups, the second for level 2, | |||
| 1613 | and so forth. The remaining group tags are shown with | 1772 | and so forth. The remaining group tags are shown with |
| 1614 | `custom-group-tag-face'." | 1773 | `custom-group-tag-face'." |
| 1615 | :type '(repeat face) | 1774 | :type '(repeat face) |
| 1616 | :group 'customize) | 1775 | :group 'custom-faces) |
| 1617 | 1776 | ||
| 1618 | (defface custom-group-tag-face-1 '((((class color) | 1777 | (defface custom-group-tag-face-1 '((((class color) |
| 1619 | (background dark)) | 1778 | (background dark)) |
| @@ -1632,7 +1791,7 @@ and so forth. The remaining group tags are shown with | |||
| 1632 | (:foreground "blue" :underline t)) | 1791 | (:foreground "blue" :underline t)) |
| 1633 | (t (:underline t))) | 1792 | (t (:underline t))) |
| 1634 | "Face used for low level group tags." | 1793 | "Face used for low level group tags." |
| 1635 | :group 'customize) | 1794 | :group 'custom-faces) |
| 1636 | 1795 | ||
| 1637 | (define-widget 'custom-group 'custom | 1796 | (define-widget 'custom-group 'custom |
| 1638 | "Customize group." | 1797 | "Customize group." |
| @@ -1835,9 +1994,21 @@ Leave point at the location of the call, or after the last expression." | |||
| 1835 | (unless (bolp) | 1994 | (unless (bolp) |
| 1836 | (princ "\n")) | 1995 | (princ "\n")) |
| 1837 | (princ "(custom-set-faces") | 1996 | (princ "(custom-set-faces") |
| 1997 | (let ((value (get 'default 'saved-face))) | ||
| 1998 | ;; The default face must be first, since it affects the others. | ||
| 1999 | (when value | ||
| 2000 | (princ "\n '(default ") | ||
| 2001 | (prin1 value) | ||
| 2002 | (if (or (get 'default 'factory-face) | ||
| 2003 | (and (not (custom-facep 'default)) | ||
| 2004 | (not (get 'default 'force-face)))) | ||
| 2005 | (princ ")") | ||
| 2006 | (princ " t)")))) | ||
| 1838 | (mapatoms (lambda (symbol) | 2007 | (mapatoms (lambda (symbol) |
| 1839 | (let ((value (get symbol 'saved-face))) | 2008 | (let ((value (get symbol 'saved-face))) |
| 1840 | (when value | 2009 | (when (and (not (eq symbol 'default)) |
| 2010 | ;; Don't print default face here. | ||
| 2011 | value) | ||
| 1841 | (princ "\n '(") | 2012 | (princ "\n '(") |
| 1842 | (princ symbol) | 2013 | (princ symbol) |
| 1843 | (princ " ") | 2014 | (princ " ") |
| @@ -1862,10 +2033,43 @@ Leave point at the location of the call, or after the last expression." | |||
| 1862 | 2033 | ||
| 1863 | ;;; The Customize Menu. | 2034 | ;;; The Customize Menu. |
| 1864 | 2035 | ||
| 1865 | (defcustom custom-menu-nesting 2 | 2036 | ;;; Menu support |
| 1866 | "Maximum nesting in custom menus." | 2037 | |
| 1867 | :type 'integer | 2038 | (unless (string-match "XEmacs" emacs-version) |
| 1868 | :group 'customize) | 2039 | (defconst custom-help-menu '("Customize" |
| 2040 | ["Update menu..." custom-menu-update t] | ||
| 2041 | ["Group..." customize t] | ||
| 2042 | ["Variable..." customize-variable t] | ||
| 2043 | ["Face..." customize-face t] | ||
| 2044 | ["Saved..." customize-customized t] | ||
| 2045 | ["Apropos..." customize-apropos t]) | ||
| 2046 | ;; This menu should be identical to the one defined in `menu-bar.el'. | ||
| 2047 | "Customize menu") | ||
| 2048 | |||
| 2049 | (defun custom-menu-reset () | ||
| 2050 | "Reset customize menu." | ||
| 2051 | (remove-hook 'custom-define-hook 'custom-menu-reset) | ||
| 2052 | (define-key global-map [menu-bar help-menu customize-menu] | ||
| 2053 | (cons (car custom-help-menu) | ||
| 2054 | (easy-menu-create-keymaps (car custom-help-menu) | ||
| 2055 | (cdr custom-help-menu))))) | ||
| 2056 | |||
| 2057 | (defun custom-menu-update (event) | ||
| 2058 | "Update customize menu." | ||
| 2059 | (interactive "e") | ||
| 2060 | (add-hook 'custom-define-hook 'custom-menu-reset) | ||
| 2061 | (let* ((emacs (widget-apply '(custom-group) :custom-menu 'emacs)) | ||
| 2062 | (menu `(,(car custom-help-menu) | ||
| 2063 | ,emacs | ||
| 2064 | ,@(cdr (cdr custom-help-menu))))) | ||
| 2065 | (let ((map (easy-menu-create-keymaps (car menu) (cdr menu)))) | ||
| 2066 | (define-key global-map [menu-bar help-menu customize-menu] | ||
| 2067 | (cons (car menu) map))))) | ||
| 2068 | |||
| 2069 | (defcustom custom-menu-nesting 2 | ||
| 2070 | "Maximum nesting in custom menus." | ||
| 2071 | :type 'integer | ||
| 2072 | :group 'customize)) | ||
| 1869 | 2073 | ||
| 1870 | (defun custom-face-menu-create (widget symbol) | 2074 | (defun custom-face-menu-create (widget symbol) |
| 1871 | "Ignoring WIDGET, create a menu entry for customization face SYMBOL." | 2075 | "Ignoring WIDGET, create a menu entry for customization face SYMBOL." |
| @@ -1884,6 +2088,7 @@ Leave point at the location of the call, or after the last expression." | |||
| 1884 | `(custom-buffer-create '((,symbol custom-variable))) | 2088 | `(custom-buffer-create '((,symbol custom-variable))) |
| 1885 | t)))) | 2089 | t)))) |
| 1886 | 2090 | ||
| 2091 | ;; Add checkboxes to boolean variable entries. | ||
| 1887 | (widget-put (get 'boolean 'widget-type) | 2092 | (widget-put (get 'boolean 'widget-type) |
| 1888 | :custom-menu (lambda (widget symbol) | 2093 | :custom-menu (lambda (widget symbol) |
| 1889 | (vector (custom-unlispify-menu-entry symbol) | 2094 | (vector (custom-unlispify-menu-entry symbol) |
| @@ -1906,17 +2111,15 @@ Leave point at the location of the call, or after the last expression." | |||
| 1906 | (let ((custom-menu-nesting (1- custom-menu-nesting))) | 2111 | (let ((custom-menu-nesting (1- custom-menu-nesting))) |
| 1907 | (custom-menu-create symbol)))) | 2112 | (custom-menu-create symbol)))) |
| 1908 | 2113 | ||
| 1909 | (defun custom-menu-create (symbol &optional name) | 2114 | ;;;###autoload |
| 2115 | (defun custom-menu-create (symbol) | ||
| 1910 | "Create menu for customization group SYMBOL. | 2116 | "Create menu for customization group SYMBOL. |
| 1911 | If optional NAME is given, use that as the name of the menu. | ||
| 1912 | Otherwise make up a name from SYMBOL. | ||
| 1913 | The menu is in a format applicable to `easy-menu-define'." | 2117 | The menu is in a format applicable to `easy-menu-define'." |
| 1914 | (unless name | 2118 | (let* ((item (vector (custom-unlispify-menu-entry symbol) |
| 1915 | (setq name (custom-unlispify-menu-entry symbol))) | 2119 | `(custom-buffer-create '((,symbol custom-group))) |
| 1916 | (let ((item (vector name | 2120 | t))) |
| 1917 | `(custom-buffer-create '((,symbol custom-group))) | 2121 | (if (and (or (not (boundp 'custom-menu-nesting)) |
| 1918 | t))) | 2122 | (>= custom-menu-nesting 0)) |
| 1919 | (if (and (>= custom-menu-nesting 0) | ||
| 1920 | (< (length (get symbol 'custom-group)) widget-menu-max-size)) | 2123 | (< (length (get symbol 'custom-group)) widget-menu-max-size)) |
| 1921 | (let ((custom-prefix-list (custom-prefix-add symbol | 2124 | (let ((custom-prefix-list (custom-prefix-add symbol |
| 1922 | custom-prefix-list))) | 2125 | custom-prefix-list))) |
| @@ -1933,58 +2136,77 @@ The menu is in a format applicable to `easy-menu-define'." | |||
| 1933 | item))) | 2136 | item))) |
| 1934 | 2137 | ||
| 1935 | ;;;###autoload | 2138 | ;;;###autoload |
| 1936 | (defun custom-menu-update (event) | 2139 | (defun customize-menu-create (symbol &optional name) |
| 1937 | "Update customize menu." | 2140 | "Return a customize menu for customization group SYMBOL. |
| 1938 | (interactive "e") | 2141 | If optional NAME is given, use that as the name of the menu. |
| 1939 | (add-hook 'custom-define-hook 'custom-menu-reset) | 2142 | Otherwise the menu will be named `Customize'. |
| 1940 | (let* ((emacs (widget-apply '(custom-group) :custom-menu 'emacs)) | 2143 | The format is suitable for use with `easy-menu-define'." |
| 1941 | (menu `(,(car custom-help-menu) | 2144 | (unless name |
| 1942 | ,emacs | 2145 | (setq name "Customize")) |
| 1943 | ,@(cdr (cdr custom-help-menu))))) | 2146 | (if (string-match "XEmacs" emacs-version) |
| 1944 | (let ((map (easy-menu-create-keymaps (car menu) (cdr menu)))) | 2147 | ;; We can delay it under XEmacs. |
| 1945 | (define-key global-map [menu-bar help-menu customize-menu] | 2148 | `(,name |
| 1946 | (cons (car menu) map))))) | 2149 | :filter (lambda (&rest junk) |
| 1947 | 2150 | (cdr (custom-menu-create ',symbol)))) | |
| 1948 | ;;; Dependencies. | 2151 | ;; But we must create it now under Emacs. |
| 2152 | (cons name (cdr (custom-menu-create symbol))))) | ||
| 1949 | 2153 | ||
| 1950 | ;;;###autoload | 2154 | ;;; The Custom Mode. |
| 1951 | (defun custom-make-dependencies () | 2155 | |
| 1952 | "Batch function to extract custom dependencies from .el files. | 2156 | (defvar custom-mode-map nil |
| 1953 | Usage: emacs -batch *.el -f custom-make-dependencies > deps.el" | 2157 | "Keymap for `custom-mode'.") |
| 1954 | (let ((buffers (buffer-list))) | 2158 | |
| 1955 | (while buffers | 2159 | (unless custom-mode-map |
| 1956 | (set-buffer (car buffers)) | 2160 | (setq custom-mode-map (make-sparse-keymap)) |
| 1957 | (setq buffers (cdr buffers)) | 2161 | (set-keymap-parent custom-mode-map widget-keymap) |
| 1958 | (let ((file (buffer-file-name))) | 2162 | (define-key custom-mode-map "q" 'bury-buffer)) |
| 1959 | (when (and file (string-match "\\`\\(.*\\)\\.el\\'" file)) | 2163 | |
| 1960 | (goto-char (point-min)) | 2164 | (easy-menu-define custom-mode-customize-menu |
| 1961 | (condition-case nil | 2165 | custom-mode-map |
| 1962 | (let ((name (file-name-nondirectory (match-string 1 file)))) | 2166 | "Menu used in customization buffers." |
| 1963 | (while t | 2167 | (customize-menu-create 'customize)) |
| 1964 | (let ((expr (read (current-buffer)))) | 2168 | |
| 1965 | (when (and (listp expr) | 2169 | (easy-menu-define custom-mode-menu |
| 1966 | (memq (car expr) '(defcustom defface defgroup))) | 2170 | custom-mode-map |
| 1967 | (eval expr) | 2171 | "Menu used in customization buffers." |
| 1968 | (put (nth 1 expr) 'custom-where name))))) | 2172 | `("Custom" |
| 1969 | (error nil)))))) | 2173 | ["Set" custom-set t] |
| 1970 | (mapatoms (lambda (symbol) | 2174 | ["Save" custom-save t] |
| 1971 | (let ((members (get symbol 'custom-group)) | 2175 | ["Reset to Current" custom-reset-current t] |
| 1972 | item where found) | 2176 | ["Reset to Saved" custom-reset-saved t] |
| 1973 | (when members | 2177 | ["Reset to Factory Settings" custom-reset-factory t] |
| 1974 | (princ "(put '") | 2178 | ["Info" (Info-goto-node "(custom)The Customization Buffer") t])) |
| 1975 | (princ symbol) | 2179 | |
| 1976 | (princ " 'custom-loads '(") | 2180 | (defcustom custom-mode-hook nil |
| 1977 | (while members | 2181 | "Hook called when entering custom-mode." |
| 1978 | (setq item (car (car members)) | 2182 | :type 'hook |
| 1979 | members (cdr members) | 2183 | :group 'customize) |
| 1980 | where (get item 'custom-where)) | 2184 | |
| 1981 | (unless (or (null where) | 2185 | (defun custom-mode () |
| 1982 | (member where found)) | 2186 | "Major mode for editing customization buffers. |
| 1983 | (when found | 2187 | |
| 1984 | (princ " ")) | 2188 | The following commands are available: |
| 1985 | (prin1 where) | 2189 | |
| 1986 | (push where found))) | 2190 | Move to next button or editable field. \\[widget-forward] |
| 1987 | (princ "))\n")))))) | 2191 | Move to previous button or editable field. \\[widget-backward] |
| 2192 | Activate button under the mouse pointer. \\[widget-button-click] | ||
| 2193 | Activate button under point. \\[widget-button-press] | ||
| 2194 | Set all modifications. \\[custom-set] | ||
| 2195 | Make all modifications default. \\[custom-save] | ||
| 2196 | Reset all modified options. \\[custom-reset-current] | ||
| 2197 | Reset all modified or set options. \\[custom-reset-saved] | ||
| 2198 | Reset all options. \\[custom-reset-factory] | ||
| 2199 | |||
| 2200 | Entry to this mode calls the value of `custom-mode-hook' | ||
| 2201 | if that value is non-nil." | ||
| 2202 | (kill-all-local-variables) | ||
| 2203 | (setq major-mode 'custom-mode | ||
| 2204 | mode-name "Custom") | ||
| 2205 | (use-local-map custom-mode-map) | ||
| 2206 | (easy-menu-add custom-mode-customize-menu) | ||
| 2207 | (easy-menu-add custom-mode-menu) | ||
| 2208 | (make-local-variable 'custom-options) | ||
| 2209 | (run-hooks 'custom-mode-hook)) | ||
| 1988 | 2210 | ||
| 1989 | ;;; The End. | 2211 | ;;; The End. |
| 1990 | 2212 | ||
diff --git a/lisp/cus-face.el b/lisp/cus-face.el index c0d64a8ecfb..952171ca4d0 100644 --- a/lisp/cus-face.el +++ b/lisp/cus-face.el | |||
| @@ -4,7 +4,7 @@ | |||
| 4 | ;; | 4 | ;; |
| 5 | ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> | 5 | ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> |
| 6 | ;; Keywords: help, faces | 6 | ;; Keywords: help, faces |
| 7 | ;; Version: 1.71 | 7 | ;; Version: 1.84 |
| 8 | ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ | 8 | ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ |
| 9 | 9 | ||
| 10 | ;;; Commentary: | 10 | ;;; Commentary: |
| @@ -39,7 +39,7 @@ | |||
| 39 | 39 | ||
| 40 | (eval-and-compile | 40 | (eval-and-compile |
| 41 | (unless (fboundp 'frame-property) | 41 | (unless (fboundp 'frame-property) |
| 42 | ;; XEmacs function missing in Emacs 19.34. | 42 | ;; XEmacs function missing in Emacs. |
| 43 | (defun frame-property (frame property &optional default) | 43 | (defun frame-property (frame property &optional default) |
| 44 | "Return FRAME's value for property PROPERTY." | 44 | "Return FRAME's value for property PROPERTY." |
| 45 | (or (cdr (assq property (frame-parameters frame))) | 45 | (or (cdr (assq property (frame-parameters frame))) |
| @@ -49,44 +49,13 @@ | |||
| 49 | ;; XEmacs function missing in Emacs. | 49 | ;; XEmacs function missing in Emacs. |
| 50 | (defun face-doc-string (face) | 50 | (defun face-doc-string (face) |
| 51 | "Get the documentation string for FACE." | 51 | "Get the documentation string for FACE." |
| 52 | (get face 'face-doc-string))) | 52 | (get face 'face-documentation))) |
| 53 | 53 | ||
| 54 | (unless (fboundp 'set-face-doc-string) | 54 | (unless (fboundp 'set-face-doc-string) |
| 55 | ;; XEmacs function missing in Emacs. | 55 | ;; XEmacs function missing in Emacs. |
| 56 | (defun set-face-doc-string (face string) | 56 | (defun set-face-doc-string (face string) |
| 57 | "Set the documentation string for FACE to STRING." | 57 | "Set the documentation string for FACE to STRING." |
| 58 | (put face 'face-doc-string string))) | 58 | (put face 'face-documentation string)))) |
| 59 | |||
| 60 | (when (and (not (fboundp 'set-face-stipple)) | ||
| 61 | (fboundp 'set-face-background-pixmap)) | ||
| 62 | ;; Emacs function missing in XEmacs 19.15. | ||
| 63 | (defun set-face-stipple (face pixmap &optional frame) | ||
| 64 | ;; Written by Kyle Jones. | ||
| 65 | "Change the stipple pixmap of face FACE to PIXMAP. | ||
| 66 | PIXMAP should be a string, the name of a file of pixmap data. | ||
| 67 | The directories listed in the `x-bitmap-file-path' variable are searched. | ||
| 68 | |||
| 69 | Alternatively, PIXMAP may be a list of the form (WIDTH HEIGHT DATA) | ||
| 70 | where WIDTH and HEIGHT are the size in pixels, | ||
| 71 | and DATA is a string, containing the raw bits of the bitmap. | ||
| 72 | |||
| 73 | If the optional FRAME argument is provided, change only | ||
| 74 | in that frame; otherwise change each frame." | ||
| 75 | (while (not (find-face face)) | ||
| 76 | (setq face (signal 'wrong-type-argument (list 'facep face)))) | ||
| 77 | (while (cond ((stringp pixmap) | ||
| 78 | (unless (file-readable-p pixmap) | ||
| 79 | (setq pixmap (vector 'xbm ':file pixmap))) | ||
| 80 | nil) | ||
| 81 | ((and (consp pixmap) (= (length pixmap) 3)) | ||
| 82 | (setq pixmap (vector 'xbm ':data pixmap)) | ||
| 83 | nil) | ||
| 84 | (t t)) | ||
| 85 | (setq pixmap (signal 'wrong-type-argument | ||
| 86 | (list 'stipple-pixmap-p pixmap)))) | ||
| 87 | (while (and frame (not (framep frame))) | ||
| 88 | (setq frame (signal 'wrong-type-argument (list 'framep frame)))) | ||
| 89 | (set-face-background-pixmap face pixmap frame)))) | ||
| 90 | 59 | ||
| 91 | (unless (fboundp 'x-color-values) | 60 | (unless (fboundp 'x-color-values) |
| 92 | ;; Emacs function missing in XEmacs 19.14. | 61 | ;; Emacs function missing in XEmacs 19.14. |
| @@ -410,7 +379,7 @@ If FRAME is nil, use the default face." | |||
| 410 | "Return the size of the font of FACE as a string." | 379 | "Return the size of the font of FACE as a string." |
| 411 | (let* ((font (apply 'custom-face-font-name face args)) | 380 | (let* ((font (apply 'custom-face-font-name face args)) |
| 412 | (fontobj (font-create-object font))) | 381 | (fontobj (font-create-object font))) |
| 413 | (format "%d" (font-size fontobj)))) | 382 | (format "%s" (font-size fontobj)))) |
| 414 | 383 | ||
| 415 | (defun custom-set-face-font-family (face family &rest args) | 384 | (defun custom-set-face-font-family (face family &rest args) |
| 416 | "Set the font of FACE to FAMILY." | 385 | "Set the font of FACE to FAMILY." |
| @@ -425,17 +394,23 @@ If FRAME is nil, use the default face." | |||
| 425 | (fontobj (font-create-object font))) | 394 | (fontobj (font-create-object font))) |
| 426 | (font-family fontobj))) | 395 | (font-family fontobj))) |
| 427 | 396 | ||
| 428 | (nconc custom-face-attributes | 397 | (setq custom-face-attributes |
| 429 | '((:family (editable-field :format "Font Family: %v" | 398 | (append '((:family (editable-field :format "Font Family: %v" |
| 430 | :help-echo "\ | 399 | :help-echo "\ |
| 431 | Name of font family to use (e.g. times).") | 400 | Name of font family to use (e.g. times).") |
| 432 | custom-set-face-font-family | 401 | custom-set-face-font-family |
| 433 | custom-face-font-family) | 402 | custom-face-font-family) |
| 434 | (:size (editable-field :format "Size: %v" | 403 | (:size (editable-field :format "Size: %v" |
| 435 | :help-echo "\ | 404 | :help-echo "\ |
| 436 | Text size (e.g. 9pt or 2mm).") | 405 | Text size (e.g. 9pt or 2mm).") |
| 437 | custom-set-face-font-size | 406 | custom-set-face-font-size |
| 438 | custom-face-font-size)))) | 407 | custom-face-font-size) |
| 408 | (:strikethru (toggle :format "Strikethru: %[%v%]\n" | ||
| 409 | :help-echo "\ | ||
| 410 | Control whether the text should be strikethru.") | ||
| 411 | set-face-strikethru-p | ||
| 412 | face-strikethru-p)) | ||
| 413 | custom-face-attributes))) | ||
| 439 | 414 | ||
| 440 | ;;; Frames. | 415 | ;;; Frames. |
| 441 | 416 | ||
diff --git a/lisp/custom.el b/lisp/custom.el index 57026fc8f4a..4e4cde95d9e 100644 --- a/lisp/custom.el +++ b/lisp/custom.el | |||
| @@ -4,7 +4,7 @@ | |||
| 4 | ;; | 4 | ;; |
| 5 | ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> | 5 | ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> |
| 6 | ;; Keywords: help, faces | 6 | ;; Keywords: help, faces |
| 7 | ;; Version: 1.71 | 7 | ;; Version: 1.84 |
| 8 | ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ | 8 | ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ |
| 9 | 9 | ||
| 10 | ;;; Commentary: | 10 | ;;; Commentary: |
| @@ -23,16 +23,26 @@ | |||
| 23 | 23 | ||
| 24 | (define-widget-keywords :prefix :tag :load :link :options :type :group) | 24 | (define-widget-keywords :prefix :tag :load :link :options :type :group) |
| 25 | 25 | ||
| 26 | (defvar custom-define-hook nil | ||
| 27 | ;; Customize information for this option is in `cus-edit.el'. | ||
| 28 | "Hook called after defining each customize option.") | ||
| 29 | |||
| 26 | ;;; The `defcustom' Macro. | 30 | ;;; The `defcustom' Macro. |
| 27 | 31 | ||
| 28 | (defun custom-declare-variable (symbol value doc &rest args) | 32 | (defun custom-declare-variable (symbol value doc &rest args) |
| 29 | "Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments." | 33 | "Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments." |
| 30 | (unless (and (default-boundp symbol) | 34 | ;; Bind this variable unless it already is bound. |
| 31 | (not (get symbol 'saved-value))) | 35 | (unless (default-boundp symbol) |
| 36 | ;; Use the saved value if it exists, otherwise the factory setting. | ||
| 32 | (set-default symbol (if (get symbol 'saved-value) | 37 | (set-default symbol (if (get symbol 'saved-value) |
| 33 | (eval (car (get symbol 'saved-value))) | 38 | (eval (car (get symbol 'saved-value))) |
| 34 | (eval value)))) | 39 | (eval value)))) |
| 40 | ;; Remember the factory setting. | ||
| 35 | (put symbol 'factory-value (list value)) | 41 | (put symbol 'factory-value (list value)) |
| 42 | ;; Maybe this option was rogue in an earlier version. It no longer is. | ||
| 43 | (when (get symbol 'force-value) | ||
| 44 | ;; It no longer is. | ||
| 45 | (put symbol 'force-value nil)) | ||
| 36 | (when doc | 46 | (when doc |
| 37 | (put symbol 'variable-documentation doc)) | 47 | (put symbol 'variable-documentation doc)) |
| 38 | (while args | 48 | (while args |
| @@ -262,23 +272,23 @@ the default value for the SYMBOL." | |||
| 262 | (value (nth 1 entry)) | 272 | (value (nth 1 entry)) |
| 263 | (now (nth 2 entry))) | 273 | (now (nth 2 entry))) |
| 264 | (put symbol 'saved-value (list value)) | 274 | (put symbol 'saved-value (list value)) |
| 265 | (when now | 275 | (cond (now |
| 266 | (put symbol 'force-value t) | 276 | ;; Rogue variable, set it now. |
| 267 | (set-default symbol (eval value))) | 277 | (put symbol 'force-value t) |
| 278 | (set-default symbol (eval value))) | ||
| 279 | ((default-boundp symbol) | ||
| 280 | ;; Something already set this, overwrite it. | ||
| 281 | (set-default symbol (eval value)))) | ||
| 268 | (setq args (cdr args))) | 282 | (setq args (cdr args))) |
| 269 | ;; Old format, a plist of SYMBOL VALUE pairs. | 283 | ;; Old format, a plist of SYMBOL VALUE pairs. |
| 284 | (message "Warning: old format `custom-set-variables'") | ||
| 285 | (ding) | ||
| 286 | (sit-for 2) | ||
| 270 | (let ((symbol (nth 0 args)) | 287 | (let ((symbol (nth 0 args)) |
| 271 | (value (nth 1 args))) | 288 | (value (nth 1 args))) |
| 272 | (put symbol 'saved-value (list value))) | 289 | (put symbol 'saved-value (list value))) |
| 273 | (setq args (cdr (cdr args))))))) | 290 | (setq args (cdr (cdr args))))))) |
| 274 | 291 | ||
| 275 | ;;; Meta Customization | ||
| 276 | |||
| 277 | (defcustom custom-define-hook nil | ||
| 278 | "Hook called after defining each customize option." | ||
| 279 | :group 'customize | ||
| 280 | :type 'hook) | ||
| 281 | |||
| 282 | ;;; The End. | 292 | ;;; The End. |
| 283 | 293 | ||
| 284 | (provide 'custom) | 294 | (provide 'custom) |
diff --git a/lisp/wid-browse.el b/lisp/wid-browse.el index d90836c05c4..f656a3b9020 100644 --- a/lisp/wid-browse.el +++ b/lisp/wid-browse.el | |||
| @@ -4,7 +4,7 @@ | |||
| 4 | ;; | 4 | ;; |
| 5 | ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> | 5 | ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> |
| 6 | ;; Keywords: extensions | 6 | ;; Keywords: extensions |
| 7 | ;; Version: 1.71 | 7 | ;; Version: 1.84 |
| 8 | ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ | 8 | ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ |
| 9 | 9 | ||
| 10 | ;;; Commentary: | 10 | ;;; Commentary: |
| @@ -29,7 +29,13 @@ | |||
| 29 | 29 | ||
| 30 | (unless widget-browse-mode-map | 30 | (unless widget-browse-mode-map |
| 31 | (setq widget-browse-mode-map (make-sparse-keymap)) | 31 | (setq widget-browse-mode-map (make-sparse-keymap)) |
| 32 | (set-keymap-parent widget-browse-mode-map widget-keymap)) | 32 | (set-keymap-parent widget-browse-mode-map widget-keymap) |
| 33 | (define-key widget-browse-mode-map "q" 'bury-buffer)) | ||
| 34 | |||
| 35 | (easy-menu-define widget-browse-mode-customize-menu | ||
| 36 | widget-browse-mode-map | ||
| 37 | "Menu used in widget browser buffers." | ||
| 38 | (customize-menu-create 'widgets)) | ||
| 33 | 39 | ||
| 34 | (easy-menu-define widget-browse-mode-menu | 40 | (easy-menu-define widget-browse-mode-menu |
| 35 | widget-browse-mode-map | 41 | widget-browse-mode-map |
| @@ -59,6 +65,7 @@ if that value is non-nil." | |||
| 59 | (setq major-mode 'widget-browse-mode | 65 | (setq major-mode 'widget-browse-mode |
| 60 | mode-name "Widget") | 66 | mode-name "Widget") |
| 61 | (use-local-map widget-browse-mode-map) | 67 | (use-local-map widget-browse-mode-map) |
| 68 | (easy-menu-add widget-browse-mode-customize-menu) | ||
| 62 | (easy-menu-add widget-browse-mode-menu) | 69 | (easy-menu-add widget-browse-mode-menu) |
| 63 | (run-hooks 'widget-browse-mode-hook)) | 70 | (run-hooks 'widget-browse-mode-hook)) |
| 64 | 71 | ||
| @@ -82,6 +89,7 @@ if that value is non-nil." | |||
| 82 | 89 | ||
| 83 | (defvar widget-browse-history nil) | 90 | (defvar widget-browse-history nil) |
| 84 | 91 | ||
| 92 | ;;;###autoload | ||
| 85 | (defun widget-browse (widget) | 93 | (defun widget-browse (widget) |
| 86 | "Create a widget browser for WIDGET." | 94 | "Create a widget browser for WIDGET." |
| 87 | (interactive (list (completing-read "Widget: " | 95 | (interactive (list (completing-read "Widget: " |
| @@ -106,11 +114,11 @@ if that value is non-nil." | |||
| 106 | (widget-browse-mode) | 114 | (widget-browse-mode) |
| 107 | 115 | ||
| 108 | ;; Quick way to get out. | 116 | ;; Quick way to get out. |
| 109 | (widget-create 'push-button | 117 | ;; (widget-create 'push-button |
| 110 | :action (lambda (widget &optional event) | 118 | ;; :action (lambda (widget &optional event) |
| 111 | (bury-buffer)) | 119 | ;; (bury-buffer)) |
| 112 | "Quit") | 120 | ;; "Quit") |
| 113 | (widget-insert "\n") | 121 | ;; (widget-insert "\n") |
| 114 | 122 | ||
| 115 | ;; Top text indicating whether it is a class or object browser. | 123 | ;; Top text indicating whether it is a class or object browser. |
| 116 | (if (listp widget) | 124 | (if (listp widget) |
| @@ -145,6 +153,18 @@ if that value is non-nil." | |||
| 145 | (widget-setup) | 153 | (widget-setup) |
| 146 | (goto-char (point-min))) | 154 | (goto-char (point-min))) |
| 147 | 155 | ||
| 156 | ;;;###autoload | ||
| 157 | (defun widget-browse-other-window (&optional widget) | ||
| 158 | "Show widget browser for WIDGET in other window." | ||
| 159 | (interactive) | ||
| 160 | (let ((window (selected-window))) | ||
| 161 | (switch-to-buffer-other-window "*Browse Widget*") | ||
| 162 | (if widget | ||
| 163 | (widget-browse widget) | ||
| 164 | (call-interactively 'widget-browse)) | ||
| 165 | (select-window window))) | ||
| 166 | |||
| 167 | |||
| 148 | ;;; The `widget-browse' Widget. | 168 | ;;; The `widget-browse' Widget. |
| 149 | 169 | ||
| 150 | (define-widget 'widget-browse 'push-button | 170 | (define-widget 'widget-browse 'push-button |
diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 283981d42f4..e7985c5bc8f 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el | |||
| @@ -4,7 +4,7 @@ | |||
| 4 | ;; | 4 | ;; |
| 5 | ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> | 5 | ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> |
| 6 | ;; Keywords: extensions | 6 | ;; Keywords: extensions |
| 7 | ;; Version: 1.71 | 7 | ;; Version: 1.84 |
| 8 | ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ | 8 | ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ |
| 9 | 9 | ||
| 10 | ;;; Commentary: | 10 | ;;; Commentary: |
| @@ -1238,13 +1238,14 @@ With optional ARG, move across that many fields." | |||
| 1238 | (define-widget 'push-button 'item | 1238 | (define-widget 'push-button 'item |
| 1239 | "A pushable button." | 1239 | "A pushable button." |
| 1240 | :value-create 'widget-push-button-value-create | 1240 | :value-create 'widget-push-button-value-create |
| 1241 | :text-format "[%s]" | ||
| 1241 | :format "%[%v%]") | 1242 | :format "%[%v%]") |
| 1242 | 1243 | ||
| 1243 | (defun widget-push-button-value-create (widget) | 1244 | (defun widget-push-button-value-create (widget) |
| 1244 | ;; Insert text representing the `on' and `off' states. | 1245 | ;; Insert text representing the `on' and `off' states. |
| 1245 | (let* ((tag (or (widget-get widget :tag) | 1246 | (let* ((tag (or (widget-get widget :tag) |
| 1246 | (widget-get widget :value))) | 1247 | (widget-get widget :value))) |
| 1247 | (text (concat "[" tag "]")) | 1248 | (text (format (widget-get widget :text-format) tag)) |
| 1248 | (gui (cdr (assoc tag widget-push-button-cache)))) | 1249 | (gui (cdr (assoc tag widget-push-button-cache)))) |
| 1249 | (if (and (fboundp 'make-gui-button) | 1250 | (if (and (fboundp 'make-gui-button) |
| 1250 | (fboundp 'make-glyph) | 1251 | (fboundp 'make-glyph) |
| @@ -2374,7 +2375,7 @@ It will read a directory name from the minibuffer when activated." | |||
| 2374 | (defun widget-vector-match (widget value) | 2375 | (defun widget-vector-match (widget value) |
| 2375 | (and (vectorp value) | 2376 | (and (vectorp value) |
| 2376 | (widget-group-match widget | 2377 | (widget-group-match widget |
| 2377 | (widget-apply :value-to-internal widget value)))) | 2378 | (widget-apply widget :value-to-internal value)))) |
| 2378 | 2379 | ||
| 2379 | (define-widget 'cons 'group | 2380 | (define-widget 'cons 'group |
| 2380 | "A cons-cell." | 2381 | "A cons-cell." |
diff --git a/lisp/widget.el b/lisp/widget.el index 4e1f2ca804c..7acd239578b 100644 --- a/lisp/widget.el +++ b/lisp/widget.el | |||
| @@ -4,7 +4,7 @@ | |||
| 4 | ;; | 4 | ;; |
| 5 | ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> | 5 | ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> |
| 6 | ;; Keywords: help, extensions, faces, hypermedia | 6 | ;; Keywords: help, extensions, faces, hypermedia |
| 7 | ;; Version: 1.71 | 7 | ;; Version: 1.84 |
| 8 | ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ | 8 | ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ |
| 9 | 9 | ||
| 10 | ;;; Commentary: | 10 | ;;; Commentary: |
| @@ -27,8 +27,8 @@ | |||
| 27 | (set (car keywords) (car keywords))) | 27 | (set (car keywords) (car keywords))) |
| 28 | (setq keywords (cdr keywords))))))) | 28 | (setq keywords (cdr keywords))))))) |
| 29 | 29 | ||
| 30 | (define-widget-keywords :deactivate :active :inactive :activate | 30 | (define-widget-keywords :text-format :deactivate :active :inactive |
| 31 | :sibling-args :delete-button-args | 31 | :activate :sibling-args :delete-button-args |
| 32 | :insert-button-args :append-button-args :button-args | 32 | :insert-button-args :append-button-args :button-args |
| 33 | :tag-glyph :off-glyph :on-glyph :valid-regexp | 33 | :tag-glyph :off-glyph :on-glyph :valid-regexp |
| 34 | :secret :sample-face :sample-face-get :case-fold :widget-doc | 34 | :secret :sample-face :sample-face-get :case-fold :widget-doc |
| @@ -50,6 +50,7 @@ | |||
| 50 | (autoload 'widget-create "wid-edit") | 50 | (autoload 'widget-create "wid-edit") |
| 51 | (autoload 'widget-insert "wid-edit") | 51 | (autoload 'widget-insert "wid-edit") |
| 52 | (autoload 'widget-browse "wid-browse" nil t) | 52 | (autoload 'widget-browse "wid-browse" nil t) |
| 53 | (autoload 'widget-browse-other-window "wid-browse" nil t) | ||
| 53 | (autoload 'widget-browse-at "wid-browse" nil t)) | 54 | (autoload 'widget-browse-at "wid-browse" nil t)) |
| 54 | 55 | ||
| 55 | (defun define-widget (name class doc &rest args) | 56 | (defun define-widget (name class doc &rest args) |