Mercurial > hg > xemacs-beta

comparison lisp/custom/custom.el @ 24:4103f0995bd7 r19-15b95

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b95
author cvs
date Mon, 13 Aug 2007 08:51:03 +0200
parents 8fc7fe29b841
children 441bb1e64a06
comparison
equal deleted inserted replaced
23:0edd3412f124 24:4103f0995bd7
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.40 7 ;; Version: 1.44
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.
33 (autoload 'custom-menu-update "custom-edit") 33 (autoload 'custom-menu-update "custom-edit")
34 (autoload 'custom-make-dependencies "custom-edit")) 34 (autoload 'custom-make-dependencies "custom-edit"))
35 35
36 ;;; Compatibility. 36 ;;; Compatibility.
37 37
38 (unless (fboundp 'x-color-values)
39 ;; Emacs function missing in XEmacs 19.14.
40 (defun x-color-values (color)
41 "Return a description of the color named COLOR on frame FRAME.
42 The value is a list of integer RGB values--(RED GREEN BLUE).
43 These values appear to range from 0 to 65280 or 65535, depending
44 on the system; white is (65280 65280 65280) or (65535 65535 65535).
45 If FRAME is omitted or nil, use the selected frame."
46 (color-instance-rgb-components (make-color-instance color))))
47
48 (unless (fboundp 'frame-property) 38 (unless (fboundp 'frame-property)
49 ;; XEmacs function missing in Emacs 19.34. 39 ;; XEmacs function missing in Emacs 19.34.
50 (defun frame-property (frame property &optional default) 40 (defun frame-property (frame property &optional default)
51 "Return FRAME's value for property PROPERTY." 41 "Return FRAME's value for property PROPERTY."
52 (or (cdr (assq property (frame-parameters frame))) 42 (or (cdr (assq property (frame-parameters frame)))
53 default))) 43 default)))
54 44
55 (defun custom-background-mode () 45 (defun custom-background-mode ()
56 "Kludge to detext background mode." 46 "Kludge to detect background mode."
57 (let* ((bg-resource 47 (let* ((bg-resource
58 (condition-case () 48 (condition-case ()
59 (x-get-resource ".backgroundMode" "BackgroundMode" 'string) 49 (x-get-resource ".backgroundMode" "BackgroundMode" 'string)
60 (error nil))) 50 (error nil)))
61 color 51 color
78 (list (cons 'background-mode mode))) 68 (list (cons 'background-mode mode)))
79 mode)) 69 mode))
80 70
81 ;; XEmacs and Emacs have different definitions of `facep'. 71 ;; XEmacs and Emacs have different definitions of `facep'.
82 ;; The Emacs definition is the useful one, so emulate that. 72 ;; The Emacs definition is the useful one, so emulate that.
83 (cond ((not (fboundp 'facep)) 73 (if (fboundp 'facep)
84 (defun custom-facep (face) 74 (defalias 'custom-facep 'facep)
85 "No faces" 75 (defun custom-facep (face)
86 nil)) 76 "No faces"
87 ((string-match "XEmacs" emacs-version) 77 nil))
88 (defun custom-facep (face)
89 "Face symbol or object."
90 (or (facep face)
91 (find-face face))))
92 (t
93 (defalias 'custom-facep 'facep)))
94 78
95 ;;; The `defcustom' Macro. 79 ;;; The `defcustom' Macro.
96 80
97 (defun custom-declare-variable (symbol value doc &rest args) 81 (defun custom-declare-variable (symbol value doc &rest args)
98 "Like `defcustom', but SYMBOL and VALUE are evaluated as notmal arguments." 82 "Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments."
99 (unless (and (default-boundp symbol) 83 (unless (and (default-boundp symbol)
100 (not (get symbol 'saved-value))) 84 (not (get symbol 'saved-value)))
101 (set-default symbol (if (get symbol 'saved-value) 85 (set-default symbol (if (get symbol 'saved-value)
102 (eval (car (get symbol 'saved-value))) 86 (eval (car (get symbol 'saved-value)))
103 (eval value)))) 87 (eval value))))
152 `(eval-and-compile 136 `(eval-and-compile
153 (custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args))) 137 (custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args)))
154 138
155 ;;; The `defface' Macro. 139 ;;; The `defface' Macro.
156 140
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
157 (defun custom-declare-face (face spec doc &rest args) 150 (defun custom-declare-face (face spec doc &rest args)
158 "Like `defface', but FACE is evaluated as a normal argument." 151 "Like `defface', but FACE is evaluated as a normal argument."
159 (put face 'factory-face spec) 152 (put face 'factory-face spec)
160 (when (fboundp 'facep) 153 (when (fboundp 'facep)
161 (unless (and (custom-facep face) 154 (unless (and (custom-facep face)
162 (not (get face 'saved-face))) 155 (not (get face 'saved-face)))
163 ;; If the user has already created the face, respect that. 156 ;; If the user has already created the face, respect that.
164 (let ((value (or (get face 'saved-face) spec))) 157 (let ((value (or (get face 'saved-face) spec)))
165 (custom-face-display-set face value)))) 158 (custom-face-display-set face value))))
166 (when doc 159 (when (and doc (null (get-face-documentation face)))
167 (put face 'face-documentation doc)) 160 (set-face-documentation face doc))
168 (custom-handle-all-keywords face args 'custom-face) 161 (custom-handle-all-keywords face args 'custom-face)
169 (run-hooks 'custom-define-hook) 162 (run-hooks 'custom-define-hook)
170 face) 163 face)
171 164
172 (defmacro defface (face spec doc &rest args) 165 (defmacro defface (face spec doc &rest args)
335 (defun custom-face-display-set (face spec &optional frame) 328 (defun custom-face-display-set (face spec &optional frame)
336 "Set FACE to the attributes to the first matching entry in SPEC. 329 "Set FACE to the attributes to the first matching entry in SPEC.
337 Iff optional FRAME is non-nil, set it for that frame only. 330 Iff optional FRAME is non-nil, set it for that frame only.
338 See `defface' for information about SPEC." 331 See `defface' for information about SPEC."
339 (when (fboundp 'copy-face) 332 (when (fboundp 'copy-face)
340 (copy-face 'custom-face-empty face) 333 (copy-face 'custom-face-empty face frame)
341 (while spec 334 (while spec
342 (let* ((entry (car spec)) 335 (let* ((entry (car spec))
343 (display (nth 0 entry)) 336 (display (nth 0 entry))
344 (atts (nth 1 entry))) 337 (atts (nth 1 entry)))
345 (setq spec (cdr spec)) 338 (setq spec (cdr spec))
406 399
407 The SET function should take three arguments, the face to modify, the 400 The SET function should take three arguments, the face to modify, the
408 value of the attribute, and optionally the frame where the face should 401 value of the attribute, and optionally the frame where the face should
409 be changed.") 402 be changed.")
410 403
411 (when (string-match "XEmacs" emacs-version)
412 ;; Support for special XEmacs font attributes.
413 (require 'font)
414
415 (unless (fboundp 'face-font-name)
416 (defun face-font-name (face &rest args)
417 (apply 'face-font face args)))
418
419 (defun set-face-font-size (face size &rest args)
420 "Set the font of FACE to SIZE"
421 (let* ((font (apply 'face-font-name face args))
422 (fontobj (font-create-object font)))
423 (set-font-size fontobj size)
424 (apply 'set-face-font face fontobj args)))
425
426 (defun set-face-font-family (face family &rest args)
427 "Set the font of FACE to FAMILY"
428 (let* ((font (apply 'face-font-name face args))
429 (fontobj (font-create-object font)))
430 (set-font-family fontobj family)
431 (apply 'set-face-font face fontobj args)))
432
433 (nconc custom-face-attributes
434 '((:family (editable-field :format "Family: %v")
435 set-face-font-family)
436 (:size (editable-field :format "Size: %v")
437 set-face-font-size))))
438
439 (defun custom-face-attribites-set (face frame &rest atts) 404 (defun custom-face-attribites-set (face frame &rest atts)
440 "For FACE on FRAME set the attributes [KEYWORD VALUE].... 405 "For FACE on FRAME set the attributes [KEYWORD VALUE]....
441 Each keyword should be listed in `custom-face-attributes'. 406 Each keyword should be listed in `custom-face-attributes'.
442 407
443 If FRAME is nil, set the default face." 408 If FRAME is nil, set the default face."
445 (let* ((name (nth 0 atts)) 410 (let* ((name (nth 0 atts))
446 (value (nth 1 atts)) 411 (value (nth 1 atts))
447 (fun (nth 2 (assq name custom-face-attributes)))) 412 (fun (nth 2 (assq name custom-face-attributes))))
448 (setq atts (cdr (cdr atts))) 413 (setq atts (cdr (cdr atts)))
449 (condition-case nil 414 (condition-case nil
450 (funcall fun face value) 415 (funcall fun face value frame)
451 (error nil))))) 416 (error nil)))))
452 417
453 (defun custom-set-face-bold (face value &optional frame) 418 (defun custom-set-face-bold (face value &optional frame)
454 "Set the bold property of FACE to VALUE." 419 "Set the bold property of FACE to VALUE."
455 (if value 420 (if value
555 ["Face..." customize-face t] 520 ["Face..." customize-face t]
556 ["Saved..." customize-customized t] 521 ["Saved..." customize-customized t]
557 ["Apropos..." customize-apropos t]) 522 ["Apropos..." customize-apropos t])
558 "Customize menu") 523 "Customize menu")
559 524
560 (defun custom-menu-reset () 525 ;(defun custom-menu-reset ()
561 "Reset customize menu." 526 ; "Reset customize menu."
562 (remove-hook 'custom-define-hook 'custom-menu-reset) 527 ; (remove-hook 'custom-define-hook 'custom-menu-reset)
563 (cond ((fboundp 'add-submenu) 528 ; (define-key global-map [menu-bar help-menu customize-menu]
564 ;; XEmacs with menus. 529 ; (cons (car custom-help-menu)
565 (add-submenu '("Help") custom-help-menu)) 530 ; (easy-menu-create-keymaps (car custom-help-menu)
566 ((string-match "XEmacs" emacs-version) 531 ; (cdr custom-help-menu)))))
567 ;; XEmacs without menus. 532
568 ) 533 ;;; The End.
569 (t 534
570 ;; Emacs. 535 (provide 'custom)
571 (define-key global-map [menu-bar help-menu customize-menu] 536
572 (cons (car custom-help-menu) 537 (when (and (not (fboundp 'load-gc))
573 (easy-menu-create-keymaps (car custom-help-menu) 538 (string-match "XEmacs" emacs-version))
574 (cdr custom-help-menu))))))) 539 ;; Overwrite definitions for XEmacs.
540 (load-library "custom-xmas"))
575 541
576 (unless (fboundp 'load-gc) 542 (unless (fboundp 'load-gc)
577 (custom-menu-reset)) 543 (custom-menu-reset))
578 544
579 ;;; The End.
580
581 (provide 'custom)
582
583 ;; custom.el ends here 545 ;; custom.el ends here