Mercurial > hg > xemacs-beta

comparison lisp/custom/cus-face.el @ 134:34a5b81f86ba r20-2b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-2b1
author cvs
date Mon, 13 Aug 2007 09:30:11 +0200
parents 9b50b4588a93
children b980b6286996
comparison
equal deleted inserted replaced
133:b27e67717092 134:34a5b81f86ba
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.89
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'.
35 35
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
40 (eval-and-compile 41 (eval-and-compile
41 (unless (fboundp 'frame-property) 42 (cond ((fboundp 'frame-property)
42 ;; XEmacs function missing in Emacs. 43 ;; XEmacs.
43 (defun frame-property (frame property &optional default) 44 (defalias 'custom-frame-parameter 'frame-property))
44 "Return FRAME's value for property PROPERTY." 45 ((fboundp 'frame-parameter)
45 (or (cdr (assq property (frame-parameters frame))) 46 ;; Emacs 19.35.
46 default))) 47 (defalias 'custom-frame-parameter 'frame-parameter))
48 (t
49 ;; Old emacsen.
50 (defun custom-frame-parameter (frame property &optional default)
51 "Return FRAME's value for property PROPERTY."
52 (or (cdr (assq property (frame-parameters frame)))
53 default))))
47 54
48 (unless (fboundp 'face-doc-string) 55 (unless (fboundp 'face-doc-string)
49 ;; XEmacs function missing in Emacs. 56 ;; XEmacs function missing in Emacs.
50 (defun face-doc-string (face) 57 (defun face-doc-string (face)
51 "Get the documentation string for FACE." 58 "Get the documentation string for FACE."
144 ;; "Swap the foreground and background colors of face FACE. 151 ;; "Swap the foreground and background colors of face FACE.
145 ;;If the colors are not specified in the face, use the default colors." 152 ;;If the colors are not specified in the face, use the default colors."
146 ;; (interactive (list (read-face-name "Reverse face: "))) 153 ;; (interactive (list (read-face-name "Reverse face: ")))
147 ;; (let ((fg (or (face-foreground face frame) 154 ;; (let ((fg (or (face-foreground face frame)
148 ;; (face-foreground 'default frame) 155 ;; (face-foreground 'default frame)
149 ;; (frame-property (or frame (selected-frame)) 156 ;; (custom-frame-parameter (or frame (selected-frame))
150 ;; 'foreground-color) 157 ;; 'foreground-color)
151 ;; "black")) 158 ;; "black"))
152 ;; (bg (or (face-background face frame) 159 ;; (bg (or (face-background face frame)
153 ;; (face-background 'default frame) 160 ;; (face-background 'default frame)
154 ;; (frame-property (or frame (selected-frame)) 161 ;; (custom-frame-parameter (or frame (selected-frame))
155 ;; 'background-color) 162 ;; 'background-color)
156 ;; "white"))) 163 ;; "white")))
157 ;; (set-face-foreground face bg frame) 164 ;; (set-face-foreground face bg frame)
158 ;; (set-face-background face fg frame)))) 165 ;; (set-face-background face fg frame))))
159 166
175 (error nil))) 182 (error nil)))
176 color 183 color
177 (mode (cond (bg-resource 184 (mode (cond (bg-resource
178 (intern (downcase bg-resource))) 185 (intern (downcase bg-resource)))
179 ((and (setq color (condition-case () 186 ((and (setq color (condition-case ()
180 (or (frame-property 187 (or (custom-frame-parameter
181 frame 188 frame
182 'background-color) 189 'background-color)
183 (custom-face-background 190 (custom-face-background
184 'default)) 191 'default))
185 (error nil))) 192 (error nil)))
199 (defun custom-extract-frame-properties (frame) 206 (defun custom-extract-frame-properties (frame)
200 "Return a plist with the frame properties of FRAME used by custom." 207 "Return a plist with the frame properties of FRAME used by custom."
201 (list 'type (device-type (frame-device frame)) 208 (list 'type (device-type (frame-device frame))
202 'class (device-class (frame-device frame)) 209 'class (device-class (frame-device frame))
203 'background (or custom-background-mode 210 'background (or custom-background-mode
204 (frame-property frame 211 (custom-frame-parameter frame
205 'background-mode) 212 'background-mode)
206 (custom-background-mode frame)))) 213 (custom-background-mode frame))))
207 ;; Emacs. 214 ;; Emacs.
208 (defun custom-extract-frame-properties (frame) 215 (defun custom-extract-frame-properties (frame)
209 "Return a plist with the frame properties of FRAME used by custom." 216 "Return a plist with the frame properties of FRAME used by custom."
210 (list 'type window-system 217 (list 'type window-system
211 'class (frame-property frame 'display-type) 218 'class (custom-frame-parameter frame 'display-type)
212 'background (or custom-background-mode 219 'background (or custom-background-mode
213 (frame-property frame 'background-mode) 220 (custom-frame-parameter frame 'background-mode)
214 (custom-background-mode frame)))))) 221 (custom-background-mode frame))))))
215 222
216 ;;; Declaring a face. 223 ;;; Declaring a face.
217 224
218 ;;;###autoload 225 ;;;###autoload
219 (defun custom-declare-face (face spec doc &rest args) 226 (defun custom-declare-face (face spec doc &rest args)
220 "Like `defface', but FACE is evaluated as a normal argument." 227 "Like `defface', but FACE is evaluated as a normal argument."
221 (when (fboundp 'load-gc) 228 (when (or (fboundp 'load-gc) ;XEmacs.
229 ;; Emacs.
230 (and (boundp purify-flag) purify-flag))
222 ;; This should be allowed, somehow. 231 ;; This should be allowed, somehow.
223 (error "Attempt to declare a face during dump")) 232 (error "Attempt to declare a face during dump"))
224 (unless (get face 'factory-face) 233 (unless (get face 'factory-face)
225 (put face 'factory-face spec) 234 (put face 'factory-face spec)
226 (when (fboundp 'facep) 235 (when (fboundp 'facep)
441 (defun custom-get-frame-properties (&optional frame) 450 (defun custom-get-frame-properties (&optional frame)
442 "Return a plist with the frame properties of FRAME used by custom. 451 "Return a plist with the frame properties of FRAME used by custom.
443 If FRAME is nil, return the default frame properties." 452 If FRAME is nil, return the default frame properties."
444 (cond (frame 453 (cond (frame
445 ;; Try to get from cache. 454 ;; Try to get from cache.
446 (let ((cache (frame-property frame 'custom-properties))) 455 (let ((cache (custom-frame-parameter frame 'custom-properties)))
447 (unless cache 456 (unless cache
448 ;; Oh well, get it then. 457 ;; Oh well, get it then.
449 (setq cache (custom-extract-frame-properties frame)) 458 (setq cache (custom-extract-frame-properties frame))
450 ;; and cache it... 459 ;; and cache it...
451 (modify-frame-parameters frame 460 (modify-frame-parameters frame