Mercurial > hg > xemacs-beta

comparison lisp/custom/cus-face.el @ 149:538048ae2ab8 r20-3b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b1
author cvs
date Mon, 13 Aug 2007 09:36:16 +0200
parents b980b6286996
children 25f70ba0133c
comparison
equal deleted inserted replaced
148:f659db2a1f73 149:538048ae2ab8
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.84 7 ;; Version: 1.97
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 ;; See `custom.el'. 12 ;; See `custom.el'.
13 13
14 ;;; Code: 14 ;;; Code:
15 15
16 (require 'custom) 16 (require 'custom)
17 17
18 (eval-and-compile (require 'cl)) 18 (eval-when-compile (require 'cl))
19 19
20 ;;; Compatibility. 20 ;;; Compatibility.
21 21
22 (if (string-match "XEmacs" emacs-version) 22 (if (string-match "XEmacs" emacs-version)
23 (defun custom-face-background (face &optional frame) 23 (defun custom-face-background (face &optional frame)
36 (defalias 'custom-face-font-name (if (string-match "XEmacs" emacs-version) 36 (defalias 'custom-face-font-name (if (string-match "XEmacs" emacs-version)
37 'face-font-name 37 'face-font-name
38 'face-font)) 38 'face-font))
39 39
40 (eval-and-compile 40 (eval-and-compile
41 (unless (fboundp 'frame-property) 41 (cond ((fboundp 'frame-property)
42 ;; XEmacs function missing in Emacs. 42 ;; XEmacs.
43 (defun frame-property (frame property &optional default) 43 (defalias 'custom-frame-parameter 'frame-property))
44 "Return FRAME's value for property PROPERTY." 44 ((fboundp 'frame-parameter)
45 (or (cdr (assq property (frame-parameters frame))) 45 ;; Emacs 19.35.
46 default))) 46 (defalias 'custom-frame-parameter 'frame-parameter))
47 (t
48 ;; Old emacsen.
49 (defun custom-frame-parameter (frame property &optional default)
50 "Return FRAME's value for property PROPERTY."
51 (or (cdr (assq property (frame-parameters frame)))
52 default))))
47 53
48 (unless (fboundp 'face-doc-string) 54 (unless (fboundp 'face-doc-string)
49 ;; XEmacs function missing in Emacs. 55 ;; XEmacs function missing in Emacs.
50 (defun face-doc-string (face) 56 (defun face-doc-string (face)
51 "Get the documentation string for FACE." 57 "Get the documentation string for FACE."
144 ;; "Swap the foreground and background colors of face FACE. 150 ;; "Swap the foreground and background colors of face FACE.
145 ;;If the colors are not specified in the face, use the default colors." 151 ;;If the colors are not specified in the face, use the default colors."
146 ;; (interactive (list (read-face-name "Reverse face: "))) 152 ;; (interactive (list (read-face-name "Reverse face: ")))
147 ;; (let ((fg (or (face-foreground face frame) 153 ;; (let ((fg (or (face-foreground face frame)
148 ;; (face-foreground 'default frame) 154 ;; (face-foreground 'default frame)
149 ;; (frame-property (or frame (selected-frame)) 155 ;; (custom-frame-parameter (or frame (selected-frame))
150 ;; 'foreground-color) 156 ;; 'foreground-color)
151 ;; "black")) 157 ;; "black"))
152 ;; (bg (or (face-background face frame) 158 ;; (bg (or (face-background face frame)
153 ;; (face-background 'default frame) 159 ;; (face-background 'default frame)
154 ;; (frame-property (or frame (selected-frame)) 160 ;; (custom-frame-parameter (or frame (selected-frame))
155 ;; 'background-color) 161 ;; 'background-color)
156 ;; "white"))) 162 ;; "white")))
157 ;; (set-face-foreground face bg frame) 163 ;; (set-face-foreground face bg frame)
158 ;; (set-face-background face fg frame)))) 164 ;; (set-face-background face fg frame))))
159 165
161 "The brightness of the background. 167 "The brightness of the background.
162 Set this to the symbol dark if your background color is dark, light if 168 Set this to the symbol dark if your background color is dark, light if
163 your background is light, or nil (default) if you want Emacs to 169 your background is light, or nil (default) if you want Emacs to
164 examine the brightness for you." 170 examine the brightness for you."
165 :group 'customize 171 :group 'customize
166 :type '(choice (choice-item dark) 172 :type '(choice (const dark)
167 (choice-item light) 173 (const light)
168 (choice-item :tag "default" nil))) 174 (const :tag "default" nil)))
169 175
170 (defun custom-background-mode (frame) 176 (defun custom-background-mode (frame)
171 "Kludge to detect background mode for FRAME." 177 "Kludge to detect background mode for FRAME."
172 (let* ((bg-resource 178 (let* ((bg-resource
173 (condition-case () 179 (condition-case ()
175 (error nil))) 181 (error nil)))
176 color 182 color
177 (mode (cond (bg-resource 183 (mode (cond (bg-resource
178 (intern (downcase bg-resource))) 184 (intern (downcase bg-resource)))
179 ((and (setq color (condition-case () 185 ((and (setq color (condition-case ()
180 (or (frame-property 186 (or (custom-frame-parameter
181 frame 187 frame
182 'background-color) 188 'background-color)
183 (custom-face-background 189 (custom-face-background
184 'default)) 190 'default))
185 (error nil))) 191 (error nil)))
199 (defun custom-extract-frame-properties (frame) 205 (defun custom-extract-frame-properties (frame)
200 "Return a plist with the frame properties of FRAME used by custom." 206 "Return a plist with the frame properties of FRAME used by custom."
201 (list 'type (device-type (frame-device frame)) 207 (list 'type (device-type (frame-device frame))
202 'class (device-class (frame-device frame)) 208 'class (device-class (frame-device frame))
203 'background (or custom-background-mode 209 'background (or custom-background-mode
204 (frame-property frame 210 (custom-frame-parameter frame
205 'background-mode) 211 'background-mode)
206 (custom-background-mode frame)))) 212 (custom-background-mode frame))))
207 ;; Emacs. 213 ;; Emacs.
208 (defun custom-extract-frame-properties (frame) 214 (defun custom-extract-frame-properties (frame)
209 "Return a plist with the frame properties of FRAME used by custom." 215 "Return a plist with the frame properties of FRAME used by custom."
210 (list 'type window-system 216 (list 'type window-system
211 'class (frame-property frame 'display-type) 217 'class (custom-frame-parameter frame 'display-type)
212 'background (or custom-background-mode 218 'background (or custom-background-mode
213 (frame-property frame 'background-mode) 219 (custom-frame-parameter frame 'background-mode)
214 (custom-background-mode frame)))))) 220 (custom-background-mode frame))))))
215 221
216 ;;; Declaring a face. 222 ;;; Declaring a face.
217 223
218 ;;;###autoload 224 ;;;###autoload
219 (defun custom-declare-face (face spec doc &rest args) 225 (defun custom-declare-face (face spec doc &rest args)
220 "Like `defface', but FACE is evaluated as a normal argument." 226 "Like `defface', but FACE is evaluated as a normal argument."
221 (when (fboundp 'load-gc) 227 (when (or (fboundp 'load-gc) ;XEmacs.
228 ;; Emacs.
229 (and (boundp purify-flag) purify-flag))
222 ;; This should be allowed, somehow. 230 ;; This should be allowed, somehow.
223 (error "Attempt to declare a face during dump")) 231 (error "Attempt to declare a face during dump"))
224 (unless (get face 'factory-face) 232 (unless (get face 'face-defface-spec)
225 (put face 'factory-face spec) 233 (put face 'face-defface-spec spec)
226 (when (fboundp 'facep) 234 (when (fboundp 'facep)
227 (unless (custom-facep face) 235 (unless (custom-facep face)
228 ;; If the user has already created the face, respect that. 236 ;; If the user has already created the face, respect that.
229 (let ((value (or (get face 'saved-face) spec)) 237 (let ((value (or (get face 'saved-face) spec))
230 (frames (custom-relevant-frames)) 238 (frames (custom-relevant-frames))
245 face) 253 face)
246 254
247 ;;; Font Attributes. 255 ;;; Font Attributes.
248 256
249 (defconst custom-face-attributes 257 (defconst custom-face-attributes
250 '((:bold (toggle :format "Bold: %[%v%]\n" 258 '((:bold (toggle :format "%[Bold%]: %v\n"
251 :help-echo "Control whether a bold font should be used.") 259 :help-echo "Control whether a bold font should be used.")
252 custom-set-face-bold 260 custom-set-face-bold
253 custom-face-bold) 261 custom-face-bold)
254 (:italic (toggle :format "Italic: %[%v%]\n" 262 (:italic (toggle :format "%[Italic%]: %v\n"
255 :help-echo "\ 263 :help-echo "\
256 Control whether an italic font should be used.") 264 Control whether an italic font should be used.")
257 custom-set-face-italic 265 custom-set-face-italic
258 custom-face-italic) 266 custom-face-italic)
259 (:underline (toggle :format "Underline: %[%v%]\n" 267 (:underline (toggle :format "%[Underline%]: %v\n"
260 :help-echo "\ 268 :help-echo "\
261 Control whether the text should be underlined.") 269 Control whether the text should be underlined.")
262 set-face-underline-p 270 set-face-underline-p
263 face-underline-p) 271 face-underline-p)
264 (:foreground (color :tag "Foreground" 272 (:foreground (color :tag "Foreground"
403 (:size (editable-field :format "Size: %v" 411 (:size (editable-field :format "Size: %v"
404 :help-echo "\ 412 :help-echo "\
405 Text size (e.g. 9pt or 2mm).") 413 Text size (e.g. 9pt or 2mm).")
406 custom-set-face-font-size 414 custom-set-face-font-size
407 custom-face-font-size) 415 custom-face-font-size)
408 (:strikethru (toggle :format "Strikethru: %[%v%]\n" 416 (:strikethru (toggle :format "%[Strikethru%]: %v\n"
409 :help-echo "\ 417 :help-echo "\
410 Control whether the text should be strikethru.") 418 Control whether the text should be strikethru.")
411 set-face-strikethru-p 419 set-face-strikethru-p
412 face-strikethru-p)) 420 face-strikethru-p))
413 custom-face-attributes))) 421 custom-face-attributes)))
414 422
415 ;;; Frames. 423 ;;; Frames.
424
425 (defun face-spec-set (face spec &optional frame)
426 "Set FACE to the attributes to the first matching entry in SPEC.
427 Iff optional FRAME is non-nil, set it for that frame only.
428 See `defface' for information about SPEC.
429
430 Clear all existing attributes first."
431 (when (fboundp 'copy-face)
432 (copy-face 'custom-face-empty face frame))
433 (custom-face-display-set face spec frame))
416 434
417 (defun custom-face-display-set (face spec &optional frame) 435 (defun custom-face-display-set (face spec &optional frame)
418 "Set FACE to the attributes to the first matching entry in SPEC. 436 "Set FACE to the attributes to the first matching entry in SPEC.
419 Iff optional FRAME is non-nil, set it for that frame only. 437 Iff optional FRAME is non-nil, set it for that frame only.
420 See `defface' for information about SPEC." 438 See `defface' for information about SPEC."
422 (while spec 440 (while spec
423 (let* ((entry (car spec)) 441 (let* ((entry (car spec))
424 (display (nth 0 entry)) 442 (display (nth 0 entry))
425 (atts (nth 1 entry))) 443 (atts (nth 1 entry)))
426 (setq spec (cdr spec)) 444 (setq spec (cdr spec))
427 (when (custom-display-match-frame display frame) 445 (when (face-spec-set-match-display display frame)
428 ;; Avoid creating frame local duplicates of the global face. 446 ;; Avoid creating frame local duplicates of the global face.
429 (unless (and frame (eq display (get face 'custom-face-display))) 447 (unless (and frame (eq display (get face 'custom-face-display)))
430 (apply 'custom-face-attributes-set face frame atts)) 448 (apply 'custom-face-attributes-set face frame atts))
431 (unless frame 449 (unless frame
432 (put face 'custom-face-display display)) 450 (put face 'custom-face-display display))
441 (defun custom-get-frame-properties (&optional frame) 459 (defun custom-get-frame-properties (&optional frame)
442 "Return a plist with the frame properties of FRAME used by custom. 460 "Return a plist with the frame properties of FRAME used by custom.
443 If FRAME is nil, return the default frame properties." 461 If FRAME is nil, return the default frame properties."
444 (cond (frame 462 (cond (frame
445 ;; Try to get from cache. 463 ;; Try to get from cache.
446 (let ((cache (frame-property frame 'custom-properties))) 464 (let ((cache (custom-frame-parameter frame 'custom-properties)))
447 (unless cache 465 (unless cache
448 ;; Oh well, get it then. 466 ;; Oh well, get it then.
449 (setq cache (custom-extract-frame-properties frame)) 467 (setq cache (custom-extract-frame-properties frame))
450 ;; and cache it... 468 ;; and cache it...
451 (modify-frame-parameters frame 469 (modify-frame-parameters frame
454 (custom-default-frame-properties) 472 (custom-default-frame-properties)
455 (t 473 (t
456 (setq custom-default-frame-properties 474 (setq custom-default-frame-properties
457 (custom-extract-frame-properties (selected-frame)))))) 475 (custom-extract-frame-properties (selected-frame))))))
458 476
459 (defun custom-display-match-frame (display frame) 477 (defun face-spec-set-match-display (display frame)
460 "Non-nil iff DISPLAY matches FRAME. 478 "Non-nil iff DISPLAY matches FRAME.
461 If FRAME is nil, the current FRAME is used." 479 If FRAME is nil, the current FRAME is used."
462 ;; This is a kludge to get started, we really should use specifiers! 480 ;; This is a kludge to get started, we really should use specifiers!
463 (if (eq display t) 481 (if (eq display t)
464 t 482 t
501 (defun custom-initialize-faces (&optional frame) 519 (defun custom-initialize-faces (&optional frame)
502 "Initialize all custom faces for FRAME. 520 "Initialize all custom faces for FRAME.
503 If FRAME is nil or omitted, initialize them for all frames." 521 If FRAME is nil or omitted, initialize them for all frames."
504 (mapcar (lambda (symbol) 522 (mapcar (lambda (symbol)
505 (let ((spec (or (get symbol 'saved-face) 523 (let ((spec (or (get symbol 'saved-face)
506 (get symbol 'factory-face)))) 524 (get symbol 'face-defface-spec))))
507 (when spec 525 (when spec
508 (custom-face-display-set symbol spec frame) 526 (custom-face-display-set symbol spec frame)
509 (initialize-face-resources symbol frame)))) 527 (initialize-face-resources symbol frame))))
510 (face-list))) 528 (face-list)))
511 529
543 (now (nth 2 entry))) 561 (now (nth 2 entry)))
544 (put face 'saved-face spec) 562 (put face 'saved-face spec)
545 (when now 563 (when now
546 (put face 'force-face t)) 564 (put face 'force-face t))
547 (when (or now (custom-facep face)) 565 (when (or now (custom-facep face))
548 (when (fboundp 'copy-face) 566 (face-spec-set face spec))
549 (copy-face 'custom-face-empty face))
550 (custom-face-display-set face spec))
551 (setq args (cdr args))) 567 (setq args (cdr args)))
552 ;; Old format, a plist of FACE SPEC pairs. 568 ;; Old format, a plist of FACE SPEC pairs.
553 (let ((face (nth 0 args)) 569 (let ((face (nth 0 args))
554 (spec (nth 1 args))) 570 (spec (nth 1 args)))
555 (put face 'saved-face spec)) 571 (put face 'saved-face spec))