Mercurial > hg > xemacs-beta

comparison lisp/custom/custom.el @ 28:1917ad0d78d7 r19-15b97

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b97
author cvs
date Mon, 13 Aug 2007 08:51:55 +0200
parents 441bb1e64a06
children ec9a17fef872
comparison
equal deleted inserted replaced
27:0a3286277d9b 28:1917ad0d78d7
2 ;; 2 ;;
3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. 3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
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.46 7 ;; Version: 1.50
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:
11 ;; 11 ;;
12 ;; If you want to use this code, please visit the URL above. 12 ;; If you want to use this code, please visit the URL above.
13 ;; 13 ;;
14 ;; This file only contain the code needed to declare and initialize 14 ;; This file only contain the code needed to declare and initialize
15 ;; user options. The code to customize options is autoloaded from 15 ;; user options. The code to customize options is autoloaded from
16 ;; `custom-edit.el'. 16 ;; `cus-edit.el'.
17
18 ;; The code implementing face declarations is in `cus-face.el'
17 19
18 ;;; Code: 20 ;;; Code:
19 21
20 (require 'widget) 22 (require 'widget)
21 23
22 (define-widget-keywords :prefix :tag :load :link :options :type :group) 24 (define-widget-keywords :prefix :tag :load :link :options :type :group)
23 25
24 ;; These autoloads should be deleted when the file is added to Emacs 26 ;; These autoloads should be deleted when the file is added to Emacs
25 27
26 (unless (fboundp 'load-gc) 28 (unless (fboundp 'load-gc)
27 (autoload 'customize "custom-edit" nil t) 29 ;; From cus-edit.el
28 (autoload 'customize-variable "custom-edit" nil t) 30 (autoload 'customize "cus-edit" nil t)
29 (autoload 'customize-face "custom-edit" nil t) 31 (autoload 'customize-variable "cus-edit" nil t)
30 (autoload 'customize-apropos "custom-edit" nil t) 32 (autoload 'customize-face "cus-edit" nil t)
31 (autoload 'customize-customized "custom-edit" nil t) 33 (autoload 'customize-apropos "cus-edit" nil t)
32 (autoload 'custom-buffer-create "custom-edit") 34 (autoload 'customize-customized "cus-edit" nil t)
33 (autoload 'custom-menu-update "custom-edit") 35 (autoload 'custom-buffer-create "cus-edit")
34 (autoload 'custom-make-dependencies "custom-edit")) 36 (autoload 'custom-menu-update "cus-edit")
35 37 (autoload 'custom-make-dependencies "cus-edit")
36 ;;; Compatibility. 38 ;; From cus-face.el
37 39 (autoload 'custom-declare-face "cus-face")
38 (unless (fboundp 'frame-property) 40 (autoload 'custom-set-faces "cus-face"))
39 ;; XEmacs function missing in Emacs 19.34.
40 (defun frame-property (frame property &optional default)
41 "Return FRAME's value for property PROPERTY."
42 (or (cdr (assq property (frame-parameters frame)))
43 default)))
44
45 (defun custom-background-mode ()
46 "Kludge to detect background mode."
47 (let* ((bg-resource
48 (condition-case ()
49 (x-get-resource ".backgroundMode" "BackgroundMode" 'string)
50 (error nil)))
51 color
52 (mode (cond (bg-resource
53 (intern (downcase bg-resource)))
54 ((and (setq color (condition-case ()
55 (or (frame-property
56 (selected-frame)
57 'background-color)
58 (color-instance-name
59 (specifier-instance
60 (face-background 'default))))
61 (error nil)))
62 (< (apply '+ (x-color-values color))
63 (/ (apply '+ (x-color-values "white"))
64 3)))
65 'dark)
66 (t 'light))))
67 (modify-frame-parameters (selected-frame)
68 (list (cons 'background-mode mode)))
69 mode))
70
71 ;; XEmacs and Emacs have different definitions of `facep'.
72 ;; The Emacs definition is the useful one, so emulate that.
73 (if (fboundp 'facep)
74 (defalias 'custom-facep 'facep)
75 (defun custom-facep (face)
76 "No faces"
77 nil))
78 41
79 ;;; The `defcustom' Macro. 42 ;;; The `defcustom' Macro.
80 43
81 (defun custom-declare-variable (symbol value doc &rest args) 44 (defun custom-declare-variable (symbol value doc &rest args)
82 "Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments." 45 "Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments."
136 `(eval-and-compile 99 `(eval-and-compile
137 (custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args))) 100 (custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args)))
138 101
139 ;;; The `defface' Macro. 102 ;;; The `defface' Macro.
140 103
141
142 ;(defun get-face-documentation (face)
143 ; "Get the documentation string for FACE."
144 ; (get face 'face-documentation))
145
146 ;(defun set-face-documentation (face string)
147 ; "Set the documentation string for FACE to STRING."
148 ; (put face 'face-documentation string))
149
150 (defun custom-declare-face (face spec doc &rest args)
151 "Like `defface', but FACE is evaluated as a normal argument."
152 (put face 'factory-face spec)
153 (when (fboundp 'facep)
154 (unless (and (custom-facep face)
155 (not (get face 'saved-face)))
156 ;; If the user has already created the face, respect that.
157 (let ((value (or (get face 'saved-face) spec)))
158 (custom-face-display-set face value))))
159 (when (and doc (null (get-face-documentation face)))
160 (set-face-documentation face doc))
161 (custom-handle-all-keywords face args 'custom-face)
162 (run-hooks 'custom-define-hook)
163 face)
164
165 (defmacro defface (face spec doc &rest args) 104 (defmacro defface (face spec doc &rest args)
166 "Declare FACE as a customizable face that defaults to SPEC. 105 "Declare FACE as a customizable face that defaults to SPEC.
167 FACE does not need to be quoted. 106 FACE does not need to be quoted.
168 107
169 Third argument DOC is the face documentation. 108 Third argument DOC is the face documentation.
318 LOAD should be either a library file name, or a feature name." 257 LOAD should be either a library file name, or a feature name."
319 (let ((loads (get symbol 'custom-loads))) 258 (let ((loads (get symbol 'custom-loads)))
320 (unless (member load loads) 259 (unless (member load loads)
321 (put symbol 'custom-loads (cons load loads))))) 260 (put symbol 'custom-loads (cons load loads)))))
322 261
323 ;;; Face Utilities.
324
325 (and (fboundp 'make-face)
326 (make-face 'custom-face-empty))
327
328 (defun custom-face-display-set (face spec &optional frame)
329 "Set FACE to the attributes to the first matching entry in SPEC.
330 Iff optional FRAME is non-nil, set it for that frame only.
331 See `defface' for information about SPEC."
332 (when (fboundp 'copy-face)
333 (copy-face 'custom-face-empty face frame)
334 (while spec
335 (let* ((entry (car spec))
336 (display (nth 0 entry))
337 (atts (nth 1 entry)))
338 (setq spec (cdr spec))
339 (when (custom-display-match-frame display frame)
340 (apply 'custom-face-attribites-set face frame atts)
341 (setq spec nil))))))
342
343 (defcustom custom-background-mode nil
344 "The brightness of the background.
345 Set this to the symbol dark if your background color is dark, light if
346 your background is light, or nil (default) if you want Emacs to
347 examine the brightness for you."
348 :group 'customize
349 :type '(choice (choice-item dark)
350 (choice-item light)
351 (choice-item :tag "default" nil)))
352
353 (defun custom-display-match-frame (display frame)
354 "Non-nil iff DISPLAY matches FRAME.
355 If FRAME is nil, the current FRAME is used."
356 ;; This is a kludge to get started, we really should use specifiers!
357 (unless frame
358 (setq frame (selected-frame)))
359 (if (eq display t)
360 t
361 (let ((match t))
362 (while (and display match)
363 (let* ((entry (car display))
364 (req (car entry))
365 (options (cdr entry)))
366 (setq display (cdr display))
367 (cond ((eq req 'type)
368 (let ((type (if (fboundp 'device-type)
369 (device-type (frame-device frame))
370 window-system)))
371 (setq match (memq type options))))
372 ((eq req 'class)
373 (let ((class (if (fboundp 'device-class)
374 (device-class (frame-device frame))
375 (frame-property frame 'display-type))))
376 (setq match (memq class options))))
377 ((eq req 'background)
378 (let ((background (or custom-background-mode
379 (frame-property frame 'background-mode)
380 (custom-background-mode))))
381 (setq match (memq background options))))
382 (t
383 (error "Unknown req `%S' with options `%S'" req options)))))
384 match)))
385
386 (defconst custom-face-attributes
387 '((:bold (toggle :format "Bold: %[%v%]\n") custom-set-face-bold)
388 (:italic (toggle :format "Italic: %[%v%]\n") custom-set-face-italic)
389 (:underline
390 (toggle :format "Underline: %[%v%]\n") set-face-underline-p)
391 (:foreground (color :tag "Foreground") set-face-foreground)
392 (:background (color :tag "Background") set-face-background)
393 (:stipple (editable-field :format "Stipple: %v") set-face-stipple))
394 "Alist of face attributes.
395
396 The elements are of the form (KEY TYPE SET) where KEY is a symbol
397 identifying the attribute, TYPE is a widget type for editing the
398 attibute, SET is a function for setting the attribute value.
399
400 The SET function should take three arguments, the face to modify, the
401 value of the attribute, and optionally the frame where the face should
402 be changed.")
403
404 (defun custom-face-attribites-set (face frame &rest atts)
405 "For FACE on FRAME set the attributes [KEYWORD VALUE]....
406 Each keyword should be listed in `custom-face-attributes'.
407
408 If FRAME is nil, set the default face."
409 (while atts
410 (let* ((name (nth 0 atts))
411 (value (nth 1 atts))
412 (fun (nth 2 (assq name custom-face-attributes))))
413 (setq atts (cdr (cdr atts)))
414 (condition-case nil
415 (funcall fun face value frame)
416 (error nil)))))
417
418 (defun custom-set-face-bold (face value &optional frame)
419 "Set the bold property of FACE to VALUE."
420 (if value
421 (make-face-bold face frame)
422 (make-face-unbold face frame)))
423
424 (defun custom-set-face-italic (face value &optional frame)
425 "Set the italic property of FACE to VALUE."
426 (if value
427 (make-face-italic face frame)
428 (make-face-unitalic face frame)))
429
430 (defun custom-initialize-faces (&optional frame)
431 "Initialize all custom faces for FRAME.
432 If FRAME is nil or omitted, initialize them for all frames."
433 (mapatoms (lambda (symbol)
434 (let ((spec (or (get symbol 'saved-face)
435 (get symbol 'factory-face))))
436 (when spec
437 (custom-face-display-set symbol spec frame))))))
438
439 ;;; Initializing. 262 ;;; Initializing.
440 263
441 (defun custom-set-variables (&rest args) 264 (defun custom-set-variables (&rest args)
442 "Initialize variables according to user preferences. 265 "Initialize variables according to user preferences.
443 266
463 (let ((symbol (nth 0 args)) 286 (let ((symbol (nth 0 args))
464 (value (nth 1 args))) 287 (value (nth 1 args)))
465 (put symbol 'saved-value (list value))) 288 (put symbol 'saved-value (list value)))
466 (setq args (cdr (cdr args))))))) 289 (setq args (cdr (cdr args)))))))
467 290
468 (defun custom-set-faces (&rest args)
469 "Initialize faces according to user preferences.
470 The arguments should be a list where each entry has the form:
471
472 (FACE SPEC [NOW])
473
474 SPEC will be stored as the saved value for FACE. If NOW is present
475 and non-nil, FACE will also be created according to SPEC.
476
477 See `defface' for the format of SPEC."
478 (while args
479 (let ((entry (car args)))
480 (if (listp entry)
481 (let ((face (nth 0 entry))
482 (spec (nth 1 entry))
483 (now (nth 2 entry)))
484 (put face 'saved-face spec)
485 (when now
486 (put face 'force-face t)
487 (custom-face-display-set face spec))
488 (setq args (cdr args)))
489 ;; Old format, a plist of FACE SPEC pairs.
490 (let ((face (nth 0 args))
491 (spec (nth 1 args)))
492 (put face 'saved-face spec))
493 (setq args (cdr (cdr args)))))))
494
495 ;;; Meta Customization 291 ;;; Meta Customization
496 292
497 (defcustom custom-define-hook nil 293 (defcustom custom-define-hook nil
498 "Hook called after defining each customize option." 294 "Hook called after defining each customize option."
499 :group 'customize 295 :group 'customize
508 ["Face..." customize-face t] 304 ["Face..." customize-face t]
509 ["Saved..." customize-customized t] 305 ["Saved..." customize-customized t]
510 ["Apropos..." customize-apropos t]) 306 ["Apropos..." customize-apropos t])
511 "Customize menu") 307 "Customize menu")
512 308
513 ;(defun custom-menu-reset () 309 (defun custom-menu-reset ()
514 ; "Reset customize menu." 310 "Reset customize menu."
515 ; (remove-hook 'custom-define-hook 'custom-menu-reset) 311 (remove-hook 'custom-define-hook 'custom-menu-reset)
516 ; (define-key global-map [menu-bar help-menu customize-menu] 312 (if (string-match "XEmacs" emacs-version)
517 ; (cons (car custom-help-menu) 313 (when (fboundp 'add-submenu)
518 ; (easy-menu-create-keymaps (car custom-help-menu) 314 (add-submenu '("Help") custom-help-menu))
519 ; (cdr custom-help-menu))))) 315 (define-key global-map [menu-bar help-menu customize-menu]
316 (cons (car custom-help-menu)
317 (easy-menu-create-keymaps (car custom-help-menu)
318 (cdr custom-help-menu))))))
520 319
521 ;;; The End. 320 ;;; The End.
522 321
523 (provide 'custom) 322 (provide 'custom)
524 323
525 (when (and (not (fboundp 'load-gc))
526 (string-match "XEmacs" emacs-version))
527 ;; Overwrite definitions for XEmacs.
528 (load-library "custom-xmas"))
529
530 (unless (fboundp 'load-gc)
531 (custom-menu-reset))
532
533 ;; custom.el ends here 324 ;; custom.el ends here