Mercurial > hg > xemacs-beta

diff lisp/gtk-faces.el @ 711:5be46355cc42

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2001-12-23 01:01:45 by wmperry] 2001-12-13 William M. Perry <wmperry@gnu.org> * gtk-faces.el (gtk-init-device-faces): Better way of munging the default faces from a style. Do not use 'device' as the locale when setting it, or it makes it very difficult for a user to override. Now munges highlight, zmacs-region, and toolbar from the appropriate information in the default GtkStyle for the device. * gui.el (gui-button-face): Ditto. * faces.el (text-cursor): (highlight): (zmacs-region): (list-mode-item-selected): (primary-selection): (secondary-selection): (isearch): (isearch-secondary): Condense old window-system specific settings into one specifier using the 'win default' tags. * dialog-gtk.el (popup-builtin-question-dialog): Deal gracefully with buttons of length 1, 2, and 3. Fixed yes-or-no-p lossage.
author wmperry
date Sun, 23 Dec 2001 01:01:46 +0000
parents a307f9a2021d
children 943eaba38521
line wrap: on
line diff
--- a/lisp/gtk-faces.el	Sat Dec 22 07:20:58 2001 +0000
+++ b/lisp/gtk-faces.el	Sun Dec 23 01:01:46 2001 +0000
@@ -42,14 +42,10 @@
    gtk-font-selection-dialog-cancel-button gtk-widget-show-all
    gtk-main))
 
-(defun gtk-init-find-device ()
-  (let ((dev nil)
-	(devices (device-list)))
-    (while (and (not dev) devices)
-      (if (eq (device-type (car devices)) 'gtk)
-	  (setq dev (car devices)))
-      (setq devices (cdr devices)))
-    dev))
+(eval-when-compile
+  (defmacro gtk-style-munge-face (face attribute value)
+    (let ((func (intern (format "face-%s" (eval attribute)))))
+      `(add-spec-to-specifier (,func ,face) ,value nil '(gtk default) 'prepend))))
 
 ;;; gtk-init-device-faces is responsible for initializing default
 ;;; values for faces on a newly created device.
@@ -58,29 +54,30 @@
   ;;
   ;; If the "default" face didn't have a font specified, try to pick one.
   ;;
-  (if (not (eq (device-type device) 'gtk))
-      nil
-    (gtk-init-pointers)
+  (when (eq (device-type device) 'gtk)
     (let* ((style (gtk-style-info device))
-	   ;;(normal 0)			; GTK_STATE_NORMAL
+	   (normal 0)			; GTK_STATE_NORMAL
 	   ;;(active 1)			; GTK_STATE_ACTIVE
 	   (prelight 2)			; GTK_STATE_PRELIGHT
 	   (selected 3)			; GTK_STATE_SELECTED
 	   ;;(insensitive 4)		; GTK_STATE_INSENSITIVE
 	   )
-      (set-face-foreground 'highlight
-			   (nth prelight (plist-get style 'text))
-			   nil '(gtk default))
-      (set-face-background 'highlight
-			   (nth prelight (plist-get style 'background))
-			   nil '(gtk default))
-      (set-face-foreground 'zmacs-region
-			   (nth selected (plist-get style 'text))
-			   nil '(gtk default))
-      (set-face-background 'zmacs-region
-			   (nth selected (plist-get style 'background))
-			   nil '(gtk default)))
-    (set-face-background 'text-cursor "red3" device)))
+      (gtk-style-munge-face 'highlight 'foreground
+			    (nth prelight (plist-get style 'text)))
+      (gtk-style-munge-face 'highlight 'background
+			    (nth prelight (plist-get style 'background)))
+      (gtk-style-munge-face 'zmacs-region 'foreground
+			    (nth selected (plist-get style 'text)))
+      (gtk-style-munge-face 'zmacs-region 'background
+			    (nth selected (plist-get style 'background)))
+      (gtk-style-munge-face 'toolbar 'background
+			    (nth normal (plist-get style 'base)))
+      (gtk-style-munge-face 'toolbar 'foreground
+			    (nth normal (plist-get style 'text)))
+      (set-face-background 'modeline [toolbar background] '(gtk default))
+      (set-face-foreground 'modeline [toolbar foreground] '(gtk default))
+      )
+    (gtk-init-pointers)))
 
 ;;; This is called from `init-frame-faces', which is called from
 ;;; init_frame_faces() which is called from Fmake_frame(), to perform
@@ -94,9 +91,9 @@
 ;;; specified.
 ;;;
 (defun gtk-init-global-faces ()
-  (let* ((dev (gtk-init-find-device))
+  (let* ((dev nil)
 	 (default-font (or (face-font 'default 'global)
-			   ;(plist-get (gtk-style-info dev) 'font)
+			   ;;(plist-get (gtk-style-info dev) 'font)
 			   "-*-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-*"))
 	 (italic-font (or (gtk-make-font-italic default-font dev) default-font))
 	 (bold-font (or (gtk-make-font-bold default-font dev) default-font))