Mercurial > hg > xemacs-beta

comparison lisp/custom/cus-face.el @ 136:b980b6286996 r20-2b2

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