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

Import from CVS: tag r20-3b1
author cvs
date Mon, 13 Aug 2007 09:36:16 +0200
parents b980b6286996
children 25f70ba0133c
line wrap: on
line diff
--- a/lisp/custom/cus-face.el	Mon Aug 13 09:35:15 2007 +0200
+++ b/lisp/custom/cus-face.el	Mon Aug 13 09:36:16 2007 +0200
@@ -4,7 +4,7 @@
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; Keywords: help, faces
-;; Version: 1.84
+;; Version: 1.97
 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
 
 ;;; Commentary:
@@ -15,7 +15,7 @@
 
 (require 'custom)
 
-(eval-and-compile (require 'cl))
+(eval-when-compile (require 'cl))
 
 ;;; Compatibility.
 
@@ -38,12 +38,18 @@
 				   'face-font))
 
 (eval-and-compile
-  (unless (fboundp 'frame-property)
-    ;; XEmacs function missing in Emacs.
-    (defun frame-property (frame property &optional default)
-      "Return FRAME's value for property PROPERTY."
-      (or (cdr (assq property (frame-parameters frame)))
-	  default)))
+  (cond ((fboundp 'frame-property)
+	 ;; XEmacs.
+	 (defalias 'custom-frame-parameter 'frame-property))
+	((fboundp 'frame-parameter)
+	 ;; Emacs 19.35.
+	 (defalias 'custom-frame-parameter 'frame-parameter))
+	(t
+	 ;; Old emacsen.
+	 (defun custom-frame-parameter (frame property &optional default)
+	   "Return FRAME's value for property PROPERTY."
+	   (or (cdr (assq property (frame-parameters frame)))
+	       default))))
 
   (unless (fboundp 'face-doc-string)
     ;; XEmacs function missing in Emacs.
@@ -146,12 +152,12 @@
 ;;    (interactive (list (read-face-name "Reverse face: ")))
 ;;    (let ((fg (or (face-foreground face frame)
 ;;		  (face-foreground 'default frame)
-;;		  (frame-property (or frame (selected-frame))
+;;		  (custom-frame-parameter (or frame (selected-frame))
 ;;				  'foreground-color)
 ;;		  "black"))
 ;;	  (bg (or (face-background face frame)
 ;;		  (face-background 'default frame)
-;;		  (frame-property (or frame (selected-frame))
+;;		  (custom-frame-parameter (or frame (selected-frame))
 ;;				  'background-color)
 ;;		  "white")))
 ;;      (set-face-foreground face bg frame)
@@ -163,9 +169,9 @@
 your background is light, or nil (default) if you want Emacs to
 examine the brightness for you."
   :group 'customize
-  :type '(choice (choice-item dark) 
-		 (choice-item light)
-		 (choice-item :tag "default" nil)))
+  :type '(choice (const dark) 
+		 (const light)
+		 (const :tag "default" nil)))
 
 (defun custom-background-mode (frame)
   "Kludge to detect background mode for FRAME."
@@ -177,7 +183,7 @@
 	 (mode (cond (bg-resource
 		      (intern (downcase bg-resource)))
 		     ((and (setq color (condition-case ()
-					   (or (frame-property
+					   (or (custom-frame-parameter
 						frame
 						'background-color)
 					       (custom-face-background
@@ -201,16 +207,16 @@
 	(list 'type (device-type (frame-device frame))
 	      'class (device-class (frame-device frame))
 	      'background (or custom-background-mode
-			      (frame-property frame
+			      (custom-frame-parameter frame
 					      'background-mode)
 			      (custom-background-mode frame))))
     ;; Emacs.
     (defun custom-extract-frame-properties (frame)
       "Return a plist with the frame properties of FRAME used by custom."
       (list 'type window-system
-	    'class (frame-property frame 'display-type)
+	    'class (custom-frame-parameter frame 'display-type)
 	    'background (or custom-background-mode
-			    (frame-property frame 'background-mode)
+			    (custom-frame-parameter frame 'background-mode)
 			    (custom-background-mode frame))))))  
 
 ;;; Declaring a face.
@@ -218,11 +224,13 @@
 ;;;###autoload
 (defun custom-declare-face (face spec doc &rest args)
   "Like `defface', but FACE is evaluated as a normal argument."
-  (when (fboundp 'load-gc)
+  (when (or (fboundp 'load-gc)		;XEmacs.
+	    ;; Emacs.
+	    (and (boundp purify-flag) purify-flag))
     ;; This should be allowed, somehow.
     (error "Attempt to declare a face during dump"))
-  (unless (get face 'factory-face)
-    (put face 'factory-face spec)
+  (unless (get face 'face-defface-spec)
+    (put face 'face-defface-spec spec)
     (when (fboundp 'facep)
       (unless (custom-facep face)
 	;; If the user has already created the face, respect that.
@@ -247,16 +255,16 @@
 ;;; Font Attributes.
 
 (defconst custom-face-attributes
-  '((:bold (toggle :format "Bold: %[%v%]\n"
+  '((:bold (toggle :format "%[Bold%]: %v\n"
 		   :help-echo "Control whether a bold font should be used.")
 	   custom-set-face-bold 
 	   custom-face-bold)
-    (:italic (toggle :format "Italic: %[%v%]\n"
+    (:italic (toggle :format "%[Italic%]: %v\n"
 		     :help-echo "\
 Control whether an italic font should be used.")
 	     custom-set-face-italic
 	     custom-face-italic)
-    (:underline (toggle :format "Underline: %[%v%]\n"
+    (:underline (toggle :format "%[Underline%]: %v\n"
 			:help-echo "\
 Control whether the text should be underlined.")
 		set-face-underline-p
@@ -405,7 +413,7 @@
 Text size (e.g. 9pt or 2mm).")
 			 custom-set-face-font-size
 			 custom-face-font-size)
-		  (:strikethru (toggle :format "Strikethru: %[%v%]\n"
+		  (:strikethru (toggle :format "%[Strikethru%]: %v\n"
 				      :help-echo "\
 Control whether the text should be strikethru.")
 			       set-face-strikethru-p
@@ -414,6 +422,16 @@
 
 ;;; Frames.
 
+(defun face-spec-set (face spec &optional frame)
+  "Set FACE to the attributes to the first matching entry in SPEC.
+Iff optional FRAME is non-nil, set it for that frame only.
+See `defface' for information about SPEC.
+
+Clear all existing attributes first."
+  (when (fboundp 'copy-face)
+    (copy-face 'custom-face-empty face frame))
+  (custom-face-display-set face spec frame))
+
 (defun custom-face-display-set (face spec &optional frame)
   "Set FACE to the attributes to the first matching entry in SPEC.
 Iff optional FRAME is non-nil, set it for that frame only.
@@ -424,7 +442,7 @@
 	     (display (nth 0 entry))
 	     (atts (nth 1 entry)))
 	(setq spec (cdr spec))
-	(when (custom-display-match-frame display frame)
+	(when (face-spec-set-match-display display frame)
 	  ;; Avoid creating frame local duplicates of the global face.
 	  (unless (and frame (eq display (get face 'custom-face-display)))
 	    (apply 'custom-face-attributes-set face frame atts))
@@ -443,7 +461,7 @@
 If FRAME is nil, return the default frame properties."
   (cond (frame
 	 ;; Try to get from cache.
-	 (let ((cache (frame-property frame 'custom-properties)))
+	 (let ((cache (custom-frame-parameter frame 'custom-properties)))
 	   (unless cache
 	     ;; Oh well, get it then.
 	     (setq cache (custom-extract-frame-properties frame))
@@ -456,7 +474,7 @@
 	 (setq custom-default-frame-properties
 	       (custom-extract-frame-properties (selected-frame))))))
 
-(defun custom-display-match-frame (display frame)
+(defun face-spec-set-match-display (display frame)
   "Non-nil iff DISPLAY matches FRAME.
 If FRAME is nil, the current FRAME is used."
   ;; This is a kludge to get started, we really should use specifiers!
@@ -503,7 +521,7 @@
 If FRAME is nil or omitted, initialize them for all frames."
   (mapcar (lambda (symbol)
 	    (let ((spec (or (get symbol 'saved-face)
-			    (get symbol 'factory-face))))
+			    (get symbol 'face-defface-spec))))
 	      (when spec 
 		(custom-face-display-set symbol spec frame)
 		(initialize-face-resources symbol frame))))
@@ -545,9 +563,7 @@
 	    (when now
 	      (put face 'force-face t))
 	    (when (or now (custom-facep face))
-	      (when (fboundp 'copy-face)
-		(copy-face 'custom-face-empty face))
-	      (custom-face-display-set face spec))
+	      (face-spec-set face spec))
 	    (setq args (cdr args)))
 	;; Old format, a plist of FACE SPEC pairs.
 	(let ((face (nth 0 args))