xemacs-beta: lisp/cus-face.el comparison

comparison lisp/cus-face.el @ 398:74fd4e045ea6 r21-2-29

Import from CVS: tag r21-2-29

author	cvs
date	Mon, 13 Aug 2007 11:13:30 +0200
parents	d883f39b8495
children	697ef44129c6

comparison

equal deleted inserted replaced

-:f4aeb21a5bad
+:74fd4e045ea6
 ;;; cus-face.el -- Support for Custom faces.
 ;;
 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
-;; Maintainer: Hrvoje Niksic <hniksic@srce.hr>
+;; Maintainer: Hrvoje Niksic <hniksic@xemacs.org>
 ;; Keywords: help, faces
 ;; Version: 1.9960-x
 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
 ;;; Commentary:
 ;;;###autoload
 (defun custom-declare-face (face spec doc &rest args)
 "Like `defface', but FACE is evaluated as a normal argument."
 ;; (when (fboundp 'pureload)
 ;; (error "Attempt to declare a face during dump"))
+;; #### should we possibly reset force-face here?
 (unless (get face 'face-defface-spec)
 (put face 'face-defface-spec spec)
 (unless (find-face face)
 ;; If the user has already created the face, respect that.
 (let ((value (or (get face 'saved-face) spec))
 	    (frames (relevant-custom-frames))
 	    frame)
 	;; Create global face.
 	(make-empty-face face)
-	(face-display-set face value)
+	(face-display-set face value nil '(custom))
 	;; Create frame local faces
 	(while frames
 	  (setq frame (car frames)
 		frames (cdr frames))
-	  (face-display-set face value frame))
+	  (face-display-set face value frame '(custom)))
 	(init-face-from-resources face)))
 (when (and doc (null (face-doc-string face)))
 (set-face-doc-string face doc))
 (custom-handle-all-keywords face args 'custom-face)
 (run-hooks 'custom-define-hook))
 			   :help-echo "\
 Text size (e.g. 9pt or 2mm).")
 	   custom-set-face-font-size custom-face-font-size)
 (:family (editable-field :format "Font Family: %v"
 			     :help-echo "\
 Name of font family to use (e.g. times).")
 	     custom-set-face-font-family custom-face-font-family)
 (:background-pixmap (editable-field :format "Background pixmap: %v"
 					:help-echo "\
 Name of background pixmap file.")
 	      set-face-background-pixmap custom-face-background-pixmap)
 be changed.
 The GET function should take two arguments, the face to examine, and
 optonally the frame where the face should be examined.")
-(defun face-custom-attributes-set (face frame &rest atts)
+(defun face-custom-attributes-set (face frame tags &rest atts)
 "For FACE on FRAME set the attributes [KEYWORD VALUE]....
 Each keyword should be listed in `custom-face-attributes'.
 If FRAME is nil, set the default face."
 (while atts
 (let* ((name (nth 0 atts))
 	   (value (nth 1 atts))
 	   (fun (nth 2 (assq name custom-face-attributes))))
 (setq atts (cdr (cdr atts)))
 (condition-case nil
-	  (funcall fun face value frame)
+	  (funcall fun face value frame tags)
 	(error nil)))))
 (defun face-custom-attributes-get (face frame)
 "For FACE on FRAME get the attributes [KEYWORD VALUE]....
 Each keyword should be listed in `custom-face-attributes'.
 (get symbol 'face-defface-spec)
 ;; Attempt to construct it.
 (list (list t (face-custom-attributes-get
 		     symbol (selected-frame))))))
-(defun custom-set-face-bold (face value &optional frame)
+(defun custom-set-face-bold (face value &optional frame tags)
 "Set the bold property of FACE to VALUE."
 (if value
-(make-face-bold face frame)
+(make-face-bold face frame tags)
-(make-face-unbold face frame)))
+(make-face-unbold face frame tags)))
 ;; Really, we should get rid of these font.el dependencies...  They
 ;; are still presenting a problem with dumping the faces (font.el is
 ;; too bloated for us to dump).  I am thinking about hacking up
 ;; font-like functionality myself for the sake of this file.  It will
 (let* ((font (apply 'face-font-name face args))
 	 ;; Gag
 	 (fontobj (font-create-object font)))
 (font-bold-p fontobj)))
-(defun custom-set-face-italic (face value &optional frame)
+(defun custom-set-face-italic (face value &optional frame tags)
 "Set the italic property of FACE to VALUE."
 (if value
-(make-face-italic face frame)
+(make-face-italic face frame tags)
-(make-face-unitalic face frame)))
+(make-face-unitalic face frame tags)))
 (defun custom-face-italic (face &rest args)
 "Return non-nil if the font of FACE is italic."
 (let* ((font (apply 'face-font-name face args))
 	 ;; Gag
 (let ((image  (apply 'specifier-instance
 		       (face-background-pixmap face) args)))
 (and image
 	 (image-instance-file-name image))))
-(defun custom-set-face-font-size (face size &rest args)
+(defun custom-set-face-font-size (face size &optional locale tags)
 "Set the font of FACE to SIZE"
-(let* ((font (apply 'face-font-name face args))
+(let* ((font (apply 'face-font-name face locale))
 	 ;; Gag
 	 (fontobj (font-create-object font)))
 (set-font-size fontobj size)
-(apply 'font-set-face-font face fontobj args)))
+(apply 'font-set-face-font face fontobj locale tags)))
 (defun custom-face-font-size (face &rest args)
 "Return the size of the font of FACE as a string."
 (let* ((font (apply 'face-font-name face args))
 	 ;; Gag
 	 (fontobj (font-create-object font)))
 (format "%s" (font-size fontobj))))
-(defun custom-set-face-font-family (face family &rest args)
+(defun custom-set-face-font-family (face family &optional locale tags)
 "Set the font of FACE to FAMILY."
-(let* ((font (apply 'face-font-name face args))
+(let* ((font (apply 'face-font-name face locale))
 	 ;; Gag
 	 (fontobj (font-create-object font)))
 (set-font-family fontobj family)
-(apply 'font-set-face-font face fontobj args)))
+(apply 'font-set-face-font face fontobj locale tags)))
 (defun custom-face-font-family (face &rest args)
 "Return the name of the font family of FACE."
 (let* ((font (apply 'face-font-name face args))
 	 ;; Gag
 "Customize the FACE for display types matching DISPLAY, merging
 in the new items from PLIST"
 (let ((spec (face-spec-update-all-matching (custom-face-get-spec face)
 					     display plist)))
 (put face 'customized-face spec)
-(face-spec-set face spec)))
+(face-spec-set face spec nil '(custom))))
 ;;; Initializing.
 ;;;###autoload
 (defun custom-set-faces (&rest args)
 "Initialize faces according to user preferences.
+This asociates the setting with the USER theme.
 The arguments should be a list where each entry has the form:
-(FACE SPEC [NOW])
+(FACE SPEC [NOW [COMMENT]])
 SPEC will be stored as the saved value for FACE.  If NOW is present
 and non-nil, FACE will also be created according to SPEC.
+COMMENT is a string comment about FACE.
 See `defface' for the format of SPEC."
-(while args
+(apply #'custom-theme-set-faces 'user args))
-(let ((entry (car args)))
-(if (listp entry)
+;;;###autoload
-	  (let ((face (nth 0 entry))
+(defun custom-theme-set-faces (theme &rest args)
-		(spec (nth 1 entry))
+"Initialize faces according to settings specified by args.
-		(now (nth 2 entry)))
+Records the settings as belonging to THEME.
+See `custom-set-faces' for a description of the arguments ARGS."
+(custom-check-theme theme)
+(let ((immediate (get theme 'theme-immediate)))
+(while args
+(let ((entry (car args)))
+	(if (listp entry)
+	    (let ((face (nth 0 entry))
+		  (spec (nth 1 entry))
+		  (now (nth 2 entry))
+		  (comment (nth 3 entry)))
+	      (put face 'saved-face spec)
+	      (custom-push-theme 'theme-face face theme 'set spec)
+	      (put face 'saved-face-comment comment)
+	      (when (or now immediate)
+		(put face 'force-face (if now 'rogue 'immediate)))
+	      (when (or now immediate (find-face face))
+		(put face 'face-comment comment)
+		(unless (find-face face)
+		  (make-empty-face face))
+		(face-spec-set face spec nil '(custom)))
+	      (setq args (cdr args)))
+	  ;; Old format, a plist of FACE SPEC pairs.
+	  (let ((face (nth 0 args))
+		(spec (nth 1 args)))
 	    (put face 'saved-face spec)
-	    (when now
+	    (custom-push-theme 'theme-face face theme 'set spec))
-	      (put face 'force-face t))
+	  (setq args (cdr (cdr args))))))))
-	    (when (or now (find-face face))
+;;;###autoload
+(defun custom-theme-face-value (face theme)
+"Return spec of FACE in THEME if the THEME modifies the
+FACE.  Nil otherwise."
+(car-safe (custom-theme-value theme (get face 'theme-face))))
+(defun custom-theme-reset-internal-face (face to-theme)
+(let ((spec (custom-theme-face-value face to-theme))
+	was-in-theme)
+(setq was-in-theme spec)
+(setq spec (or spec (get face 'standard-value)))
+(when spec
+(put face 'save-face was-in-theme)
+(when (or (get face 'force-face) (find-face face))
 	      (unless (find-face face)
 		(make-empty-face face))
-	      (face-spec-set face spec))
+	      (face-spec-set face spec)))
-	    (setq args (cdr args)))
+spec))
-	;; Old format, a plist of FACE SPEC pairs.
-	(let ((face (nth 0 args))
+;;;###autoload
-	      (spec (nth 1 args)))
+(defun custom-theme-reset-faces (theme &rest args)
-	  (put face 'saved-face spec))
+(custom-check-theme theme)
-	(setq args (cdr (cdr args)))))))
+"Reset the value of the face to values previously defined.
+Assosiate this setting with THEME.
+ARGS is a list of lists of the form
+(face to-theme)
+This means reset face to its value in to-theme."
+(mapc #'(lambda (arg)
+	    (apply #'custom-theme-reset-internal-face arg)
+	    (custom-push-theme (car arg) 'theme-face theme 'reset (cadr arg)))
+	args))
+;;;###autoload
+(defun custom-reset-faces (&rest args)
+"Reset the value of the face to values previously defined.
+Assosiate this setting with the 'user' theme.
+ARGS is defined as for `custom-theme-reset-faces'"
+(apply #'custom-theme-reset-faces 'user args))
 ;;; The End.
 (provide 'cus-face)

Mercurial > hg > xemacs-beta

comparison lisp/cus-face.el @ 398:74fd4e045ea6 r21-2-29