xemacs-beta: lisp/x11/x-font-menu.el comparison

comparison lisp/x11/x-font-menu.el @ 86:364816949b59 r20-0b93

Import from CVS: tag r20-0b93

author	cvs
date	Mon, 13 Aug 2007 09:09:02 +0200
parents	6a378aca36af
children	821dec489c24

comparison

equal deleted inserted replaced

-:c661705957e0
+:364816949b59
 ;; x-font-menu.el --- Managing menus of X fonts.
 ;; Copyright (C) 1994 Free Software Foundation, Inc.
 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
+;; Copyright (C) 1997 Sun Microsystems
 ;; Author: Jamie Zawinski <jwz@lucid.com>
 ;; Restructured by: Jonathan Stigelman <Stig@hackvan.com>
+;; Mule-ized by: Martin Buchholz
 ;; This file is part of XEmacs.
 ;; XEmacs is free software; you can redistribute it and/or modify it
 ;; under the terms of the GNU General Public License as published by
 ;;; XEmacs startup.  At any time (i.e.: after a font-path change or
 ;;; immediately after device creation), you can call
 ;;; `reset-device-font-menus' to rebuild the menus from all currently
 ;;; available fonts.
 ;;;
-;;; There is knowledge here about the regexp match numbers in `x-font-regexp',
+;;; There is knowledge here about the regexp match numbers in
-;;; `x-font-regexp-foundry-and-family', and
+;;; `x-font-regexp' and `x-font-regexp-foundry-and-family' defined in
-;;; `x-font-regexp-registry-and-encoding' defined in x-faces.el.
+;;; x-faces.el.
 ;;;
 ;;; There are at least three kinds of fonts under X11r5:
 ;;;
 ;;; - bitmap fonts, which can be assumed to look as good as possible;
 ;;; - bitmap fonts which have been (or can be) automatically scaled to
 ;;;	(face-font 'default)
 ;;;	(font-truename   (face-font 'default))
 ;;;	(font-properties (face-font 'default))
 ;;; - The values of the following variables after making a selection:
 ;;;	font-menu-preferred-resolution
-;;;	font-menu-preferred-registry
+;;;	font-menu-registry-encoding
 ;;;
 ;;; There is a common misconception that "*-courier-medium-r-*-11-*", also
 ;;; known as "-adobe-courier-medium-r-normal--11-80-100-100-m-60-iso8859-1",
 ;;; is an 11-point font.  It is not -- it is an 11-pixel font at 100dpi,
 ;;; which is an 8-point font (the number after -11- is the size in tenths
 ;;; of points).  So if you expect to be seeing an "11" entry in the "Size"
 ;;; menu and are not, this may be why.
+;;;
+;;; In the real world (aka Solaris), one has to deal with fonts that
+;;; appear to be medium-i but are really light-r, and fonts that
+;;; resolve to different resolutions depending on the charset:
+;;;
+;;; (font-instance-truename
+;;;  (make-font-instance "-*-mincho-medium-i-normal-*-*-*-*-*-*-*-jisx0201*-*"))
+;;; ==>
+;;; "-morisawa-ryumin light kl-light-r-normal--10-100-72-72-m-50-jisx0201.1976-0"
+;;;
+;;; (list-fonts "-dt-interface user-medium-r-normal-s*-*-*-*-*-*-*-*-*")
+;;; ==>
+;;; ("-dt-interface user-medium-r-normal-s sans-12-120-72-72-m-70-iso8859-1"
+;;;  "-dt-interface user-medium-r-normal-s-14-120-75-75-m-120-jisx0208.1983-0"
+;;;  "-dt-interface user-medium-r-normal-s-14-120-75-75-m-60-jisx0201.1976-0")
 ;;; Code:
 ;; #### - implement these...
 ;;
 ;; only call XListFonts (and parse) once per device.
 ;; ( (device . [parsed-list-fonts family-menu size-menu weight-menu]) ...)
 (defvar device-fonts-cache nil)
-(defconst font-menu-preferred-registry nil)
+(defvar font-menu-registry-encoding nil
-(defconst font-menu-preferred-resolution nil)
+"Registry and encoding to use with font menu fonts.")
-(defconst fonts-menu-junk-families
+(defvar font-menu-preferred-resolution "*-*"
+"Preferred horizontal and vertical font menu resolution (e.g. \"75-75\").")
+(defvar fonts-menu-junk-families
 (purecopy
 (mapconcat
 #'identity
 '("cursor" "glyph" "symbol"	; Obvious losers.
 "\\`Ax...\\'"		; FrameMaker fonts - there are just way too
 				;  "Axcor" -> "Applix Courier Roman",
 				;  "Axcob" -> "Applix Courier Bold", etc.
 )
 "\\|"))
 "A regexp matching font families which are uninteresting (e.g. cursor fonts).")
+(eval-when-compile
+(defsubst device-fonts-cache ()
+(or (cdr (assq (selected-device) device-fonts-cache))
+	(reset-device-font-menus (selected-device)))))
 (defun hack-font-truename (fn)
 "Filter the output of `font-instance-truename' to deal with Japanese fontsets."
 (if (string-match "," (font-instance-truename fn))
 (let ((fpnt (nth 8 (split-string (font-instance-name fn) "-")))
 ;;;###autoload
 (fset 'install-font-menus 'reset-device-font-menus)
 (make-obsolete 'install-font-menus 'reset-device-font-menus)
-(defvar x-font-regexp-ja nil
+(defvar x-font-regexp-ascii nil
-"This is used to filter out fonts that don't work in the locale.
+"This is used to filter out font families that can't display ASCII text.
 It must be set at run-time.")
 (defun vassoc (key valist)
 "Search VALIST for a vector whose first element is equal to KEY.
 See also `assoc'."
 (message "Getting list of fonts from server... ")
 (if (or noninteractive
 	  (not (or device (setq device (selected-device))))
 	  (not (eq (device-type device) 'x)))
 nil
-(if (and (getenv "LANG")
+(unless x-font-regexp-ascii
-	     (string-match "^\\(ja\\|japanese\\)$"
+(setq x-font-regexp-ascii (if (fboundp 'charset-registry)
-			   (getenv "LANG")))
+				    (charset-registry 'ascii)
-	;; #### - this is questionable behavior left over from the I18N4 code.
+				  "iso8859-1")))
-	(setq x-font-regexp-ja "jisx[^-]*-[^-]*$"
+(setq font-menu-registry-encoding
-	      font-menu-preferred-registry '("*" . "*")
+	  (if (featurep 'mule) "*-*" "iso8859-1"))
-	      font-menu-preferred-resolution '("*" . "*")))
+(let ((case-fold-search t)
-(let ((all-fonts nil)
+	  family size weight entry monospaced-p
-	  (case-fold-search t)
+	  dev-cache cache families sizes weights)
-	  name family size weight entry monospaced-p
+(dolist (name (cond ((null debug)	; debugging kludge
-	  dev-cache
+			   (list-fonts "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device))
-	  (cache nil)
+			  ((stringp debug) (split-string debug "\n"))
-	  (families nil)
+			  (t debug)))
-	  (sizes nil)
+	(when (and (string-match x-font-regexp-ascii name)
-	  (weights nil))
-(cond ((stringp debug)		; kludge
-	     (setq all-fonts (split-string debug "\n")))
-	    (t
-	     (setq all-fonts
-		   (or debug
-		       (list-fonts "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device)))))
-(while (setq name (pop all-fonts))
-	(when (and (or (not x-font-regexp-ja)
-		       (string-match x-font-regexp-ja name))
 		   (string-match x-font-regexp name))
 	  (setq weight (capitalize (match-string 1 name))
 		size   (string-to-int (match-string 6 name)))
 	  (or (string-match x-font-regexp-foundry-and-family name)
 	      (error "internal error"))
 	  (unless (string-match fonts-menu-junk-families family)
 	    (setq entry (or (vassoc family cache)
 			    (car (setq cache
 				       (cons (vector family nil nil t)
 					     cache)))))
-	    (or (member family families)
+	    (or (member family families) (push family families))
-		(setq families (cons family families)))
+	    (or (member weight weights)  (push weight weights))
-	    (or (member weight weights)
+	    (or (member size   sizes)    (push size   sizes))
-		(setq weights (cons weight weights)))
+	    (or (member weight (aref entry 1)) (push weight (aref entry 1)))
-	    (or (member weight (aref entry 1))
+	    (or (member size   (aref entry 2)) (push size   (aref entry 2)))
-		(aset entry 1 (cons weight (aref entry 1))))
+	    (aset entry 3 (and (aref entry 3) monospaced-p)))))
-	    (or (member size sizes)
-		(setq sizes (cons size sizes)))
-	    (or (member size (aref entry 2))
-		(aset entry 2 (cons size (aref entry 2))))
-	    (aset entry 3 (and (aref entry 3) monospaced-p))
-	    )))
 ;;
 ;; Hack scalable fonts.
 ;; Some fonts come only in scalable versions (the only size is 0)
 ;; and some fonts come in both scalable and non-scalable versions
 ;; (one size is 0).  If there are any scalable fonts at all, make
 	       (setq sizes (cons (car common) sizes)))
 	      (setq common (cdr common)))
 	    (setq sizes (delq 0 sizes))))
 (setq families (sort families 'string-lessp)
-	    weights (sort weights 'string-lessp)
+	    weights  (sort weights 'string-lessp)
-	    sizes (sort sizes '<))
+	    sizes    (sort sizes '<))
-(let ((rest cache))
+(dolist (entry cache)
-	(while rest
+	  (aset entry 1 (sort (aref entry 1) 'string-lessp))
-	  (aset (car rest) 1 (sort (aref (car rest) 1) 'string-lessp))
+	  (aset entry 2 (sort (aref entry 2) '<)))
-	  (aset (car rest) 2 (sort (aref (car rest) 2) '<))
-	  (setq rest (cdr rest))))
 (message "Getting list of fonts from server... done.")
 (setq dev-cache (assq device device-fonts-cache))
 (or dev-cache
 	  (setq dev-cache (car (push (list device) device-fonts-cache))))
-(setcdr dev-cache
+(setcdr
-	      (vector
+dev-cache
-	       cache
+(vector
-	       (mapcar #'(lambda (x)
+	cache
-			   (vector x
+	(mapcar (lambda (x)
-				   (list 'font-menu-set-font x nil nil)
+		  (vector x
-				   ':style 'radio ':active nil ':selected nil))
+			  (list 'font-menu-set-font x nil nil)
-		       families)
+			  ':style 'radio ':active nil ':selected nil))
-	       (mapcar #'(lambda (x)
+		families)
-			   (vector (if (/= 0 (% x 10))
+	(mapcar (lambda (x)
-				       ;; works with no LISP_FLOAT_TYPE
+		  (vector (if (/= 0 (% x 10))
-				       (concat (int-to-string (/ x 10)) "."
+			      ;; works with no LISP_FLOAT_TYPE
-					       (int-to-string (% x 10)))
+			      (concat (int-to-string (/ x 10)) "."
-				     (int-to-string (/ x 10)))
+				      (int-to-string (% x 10)))
-				   (list 'font-menu-set-font nil nil x)
+			    (int-to-string (/ x 10)))
-				   ':style 'radio ':active nil ':selected nil))
+			  (list 'font-menu-set-font nil nil x)
-		       sizes)
+			  ':style 'radio ':active nil ':selected nil))
-	       (mapcar #'(lambda (x)
+		sizes)
-			   (vector x
+	(mapcar (lambda (x)
-				   (list 'font-menu-set-font nil x nil)
+		  (vector x
-				   ':style 'radio ':active nil ':selected nil))
+			  (list 'font-menu-set-font nil x nil)
-		       weights)))
+			  ':style 'radio ':active nil ':selected nil))
+		weights)))
 (cdr dev-cache))))
-(defsubst font-menu-truename (face)
+;; Extract font information from a face.  We examine both the
-(hack-font-truename
+;; user-specified font name and the canonical (`true') font name.
-(if (featurep 'mule)
+;; These can appear to have totally different properties.
-(face-font-instance face nil 'ascii)
+;; For examples, see the prolog above.
-(face-font-instance face))))
+;; We use the user-specified one if possible, else use the truename.
-;;; Extract a font family from a face.
+;; If the user didn't specify one (with "-dt-*-*", for example)
-;;; Use the user-specified one if possible.
+;; get the truename and use the possibly suboptimal data from that.
-;;; If the user didn't specify one (with "*", for example)
+(defun* font-menu-font-data (face dcache)
-;;; get the truename and use the guaranteed family from that.
+(let* ((case-fold-search t)
-(defun font-menu-family (face)
+	 (domain (if font-menu-this-frame-only-p
-(let ((dcache (cdr (assq (selected-device) device-fonts-cache)))
+				  (selected-frame)
-	(name (font-instance-name (face-font-instance face)))
+				(selected-device)))
-	(family nil))
+	 (name (font-instance-name (face-font-instance face domain)))
+	 (truename (font-instance-truename
+		    (face-font-instance face domain
+					(if (featurep 'mule) 'ascii))))
+	 family size weight entry slant)
 (when (string-match x-font-regexp-foundry-and-family name)
-(setq family (capitalize (match-string 1 name))))
+(setq family (capitalize (match-string 1 name)))
-(when (not (and family (vassoc family (aref dcache 0))))
+(setq entry (vassoc family (aref dcache 0))))
-(setq name (font-menu-truename face))
+(when (and (null entry)
-(string-match x-font-regexp-foundry-and-family name)
+	       (string-match x-font-regexp-foundry-and-family truename))
-(setq family (capitalize (match-string 1 name))))
+(setq family (capitalize (match-string 1 truename)))
-family))
+(setq entry  (vassoc family (aref dcache 0))))
+(when (null entry)
+(return-from font-menu-font-data (make-vector 5 nil)))
+(when (string-match x-font-regexp name)
+(setq weight (capitalize    (match-string 1 name)))
+(setq size   (string-to-int (match-string 6 name))))
+(when (string-match x-font-regexp truename)
+(when (not (member weight (aref entry 1)))
+	(setq weight (capitalize (match-string 1 truename))))
+(when (not (member size   (aref entry 2)))
+	(setq size (string-to-int (match-string 6 truename))))
+(setq slant (capitalize (match-string 2 truename))))
+(vector entry family size weight slant)))
 ;;;###autoload
 (defun font-menu-family-constructor (ignored)
-;; by Stig@hackvan.com
+(catch 'menu
-(if (not (eq 'x (device-type (selected-device))))
+(unless (eq 'x (device-type (selected-device)))
-'(["Cannot parse current font" ding nil])
+(throw 'menu '(["Cannot parse current font" ding nil])))
-(let* ((dcache (cdr (assq (selected-device) device-fonts-cache)))
+(let* ((dcache (device-fonts-cache))
-	   (name (font-menu-truename 'default))
+	   (font-data (font-menu-font-data 'default dcache))
-	   (case-fold-search t)
+	   (entry  (aref font-data 0))
-	   family weight size		; parsed from current font
+	   (family (aref font-data 1))
-	   entry			; font cache entry
+	   (size   (aref font-data 2))
+	   (weight (aref font-data 3))
 	   f)
-(or dcache
+(unless family
-	  (setq dcache (reset-device-font-menus (selected-device))))
+	(throw 'menu '(["Cannot parse current font" ding nil])))
-(if (not (string-match x-font-regexp name))
+;; Items on the Font menu are enabled iff that font exists in
-	  ;; couldn't parse current font
+;; the same size and weight as the current font (scalable fonts
-	  '(["Cannot parse current font" ding nil])
+;; exist in every size).  Only the current font is marked as
-	(setq weight (capitalize (match-string 1 name)))
+;; selected.
-	(setq size (string-to-number (match-string 6 name)))
+(mapcar
-	(setq family (font-menu-family 'default))
+(lambda (item)
-	(setq entry (vassoc family (aref dcache 0)))
+	 (setq f (aref item 0)
-	(mapcar #'(lambda (item)
+	       entry (vassoc f (aref dcache 0)))
-		    ;;
+	 (if (and (member weight (aref entry 1))
-		    ;; Items on the Font menu are enabled iff that font
+		  (or (member size (aref entry 2))
-		    ;; exists in the same size and weight as the current
+		      (and (not font-menu-ignore-scaled-fonts)
-		    ;; font (scalable fonts exist in every size).  Only the
+			   (member 0 (aref entry 2)))))
-		    ;; current font is marked as selected.
+	     (enable-menu-item item)
-		    ;;
+	   (disable-menu-item item))
-		    (setq f (aref item 0)
+	 (if (string-equal family f)
-			  entry (vassoc f (aref dcache 0)))
+	     (select-toggle-menu-item item)
-		    (if (and (member weight (aref entry 1))
+	   (deselect-toggle-menu-item item))
-			     (or (member size (aref entry 2))
+	 item)
-				 (and (not font-menu-ignore-scaled-fonts)
+(aref dcache 1)))))
-				      (member 0 (aref entry 2)))))
-			(enable-menu-item item)
-		      (disable-menu-item item))
-		    (if (equal family f)
-			(select-toggle-menu-item item)
-		      (deselect-toggle-menu-item item))
-		    item)
-		(aref dcache 1)))
-)))
 ;;;###autoload
 (defun font-menu-size-constructor (ignored)
-;; by Stig@hackvan.com
+(catch 'menu
-(if (not (eq 'x (device-type (selected-device))))
+(unless (eq 'x (device-type (selected-device)))
-'(["Cannot parse current font" ding nil])
+(throw 'menu '(["Cannot parse current font" ding nil])))
-(let ((dcache (cdr (assq (selected-device) device-fonts-cache)))
+(let* ((dcache (device-fonts-cache))
-	  (name (font-menu-truename 'default))
+	   (font-data (font-menu-font-data 'default dcache))
-	  (case-fold-search t)
+	   (entry  (aref font-data 0))
-	  family size			; parsed from current font
+	   (family (aref font-data 1))
-	  entry				; font cache entry
+	   (size   (aref font-data 2))
-	  s)
+	   ;;(weight (aref font-data 3))
-(or dcache
+	   s)
-	  (setq dcache (reset-device-font-menus (selected-device))))
+(unless family
-(if (not (string-match x-font-regexp name))
+	(throw 'menu '(["Cannot parse current font" ding nil])))
-	  ;; couldn't parse current font
+;; Items on the Size menu are enabled iff current font has
-	  '(["Cannot parse current font" ding nil])
+;; that size.  Only the size of the current font is selected.
-	(setq size (string-to-number (match-string 6 name)))
+;; (If the current font comes in size 0, it is scalable, and
-	(setq family (font-menu-family 'default))
+;; thus has every size.)
-	(setq entry (vassoc family (aref dcache 0)))
+(mapcar
-	(mapcar
+(lambda (item)
-(lambda (item)
+	 (setq s (nth 3 (aref item 1)))
-;;
+	 (if (or (member s (aref entry 2))
-;; Items on the Size menu are enabled iff current font has
+		 (and (not font-menu-ignore-scaled-fonts)
-;; that size.  Only the size of the current font is
+		      (member 0 (aref entry 2))))
-;; selected.  (If the current font comes in size 0, it is
+	     (enable-menu-item item)
-;; scalable, and thus has every size.)
+	   (disable-menu-item item))
-;;
+	 (if (eq size s)
-(setq s (nth 3 (aref item 1)))
+	     (select-toggle-menu-item item)
-(if (or (member s (aref entry 2))
+	   (deselect-toggle-menu-item item))
-(and (not font-menu-ignore-scaled-fonts)
+	 item)
-(member 0 (aref entry 2))))
+(aref dcache 2)))))
-(enable-menu-item item)
-(disable-menu-item item))
-(if (eq size s)
-(select-toggle-menu-item item)
-(deselect-toggle-menu-item item))
-item)
-(aref dcache 2)))
-)))
 ;;;###autoload
 (defun font-menu-weight-constructor (ignored)
-;; by Stig@hackvan.com
+(catch 'menu
-(if (not (eq 'x (device-type (selected-device))))
+(unless (eq 'x (device-type (selected-device)))
-'(["Cannot parse current font" ding nil])
+(throw 'menu '(["Cannot parse current font" ding nil])))
-(let ((dcache (cdr (assq (selected-device) device-fonts-cache)))
+(let* ((dcache (device-fonts-cache))
-	  (name (font-menu-truename 'default))
+	   (font-data (font-menu-font-data 'default dcache))
-	  (case-fold-search t)
+	   (entry  (aref font-data 0))
-	  family weight			; parsed from current font
+	   (family (aref font-data 1))
-	  entry				; font cache entry
+	   ;;(size   (aref font-data 2))
-	  w)
+	   (weight (aref font-data 3))
-(or dcache
+	   w)
-	  (setq dcache (reset-device-font-menus (selected-device))))
+(unless family
-(if (not (string-match x-font-regexp name))
+	(throw 'menu '(["Cannot parse current font" ding nil])))
-	  ;; couldn't parse current font
+;; Items on the Weight menu are enabled iff current font
-	  '(["Cannot parse current font" ding nil])
+;; has that weight.  Only the weight of the current font
-	(setq weight (capitalize (match-string 1 name)))
+;; is selected.
-	(setq family (font-menu-family 'default))
+(mapcar
-	(setq entry (vassoc family (aref dcache 0)))
+(lambda (item)
-	(mapcar #'(lambda (item)
+	 (setq w (aref item 0))
-		    ;; Items on the Weight menu are enabled iff current font
+	 (if (member w (aref entry 1))
-		    ;; has that weight.  Only the weight of the current font
+	     (enable-menu-item item)
-		    ;; is selected.
+	   (disable-menu-item item))
-		    (setq w (aref item 0))
+	 (if (string-equal weight w)
-		    (if (member w (aref entry 1))
+	     (select-toggle-menu-item item)
-			(enable-menu-item item)
+	   (deselect-toggle-menu-item item))
-		      (disable-menu-item item))
+	 item)
-		    (if (equal weight w)
+(aref dcache 3)))))
-			(select-toggle-menu-item item)
-		      (deselect-toggle-menu-item item))
-		    item)
-		(aref dcache 3)))
-)))
 ;;; Changing font sizes
 (defun font-menu-set-font (family weight size)
 ;; This is what gets run when an item is selected from any of the three
 ;; fonts menus.  It needs to be rather clever.
 ;; (size is measured in 10ths of points.)
-(let ((faces (delq 'default (face-list)))
+(let* ((dcache (device-fonts-cache))
-	(default-name (font-menu-truename 'default))
+	 (font-data (font-menu-font-data 'default dcache))
-	(case-fold-search t)
+	 (from-family (aref font-data 1))
-	new-default-face-font
+	 (from-size   (aref font-data 2))
-	from-family from-weight from-size)
+	 (from-weight (aref font-data 3))
-;;
+	 (from-slant  (aref font-data 4))
-;; First, parse out the default face's font.
+	 new-default-face-font)
-;;
+(unless from-family
-(setq from-family (font-menu-family 'default))
+(signal 'error '("couldn't parse font name for default face")))
-(or (string-match x-font-regexp default-name)
-	(signal 'error (list "couldn't parse font name" default-name)))
-(setq from-weight (capitalize (match-string 1 default-name)))
-(setq from-size (match-string 6 default-name))
 (setq new-default-face-font
 	  (font-menu-load-font (or family from-family)
 			       (or weight from-weight)
 			       (or size   from-size)
-			       default-name))
+			       from-slant
-(while faces
+			       font-menu-preferred-resolution))
-(cond ((face-font-instance (car faces))
+(dolist (face (delq 'default (face-list)))
-	     (message "Changing font of `%s'..." (car faces))
+(when (face-font-instance face)
-	     (condition-case c
+	(message "Changing font of `%s'..." face)
-		 (font-menu-change-face (car faces)
+	(condition-case c
-					from-family from-weight from-size
+	    (font-menu-change-face face
-					family weight size)
+				   from-family from-weight from-size
-	       (error
+				   family      weight      size)
-		(display-error c nil)
+	  (error
-		(sit-for 1)))))
+	   (display-error c nil)
-(setq faces (cdr faces)))
+	   (sit-for 1)))))
 ;; Set the default face's font after hacking the other faces, so that
 ;; the frame size doesn't change until we are all done.
 ;;; WMP - we need to honor font-menu-this-frame-only-p here!
 (set-face-font 'default new-default-face-font
 (defun font-menu-change-face (face
 			      from-family from-weight from-size
 			      to-family   to-weight   to-size)
 (or (symbolp face) (signal 'wrong-type-argument (list 'symbolp face)))
-(let* ((name (font-menu-truename face))
+(let* ((dcache (device-fonts-cache))
-	 (case-fold-search t)
+	 (font-data (font-menu-font-data face dcache))
-	 face-family
+	 (face-family (aref font-data 1))
-	 face-weight
+	 (face-size   (aref font-data 2))
-	 face-size)
+	 (face-weight (aref font-data 3))
-;; First, parse out the face's font.
+	 (face-slant  (aref font-data 4)))
-(or (string-match x-font-regexp-foundry-and-family name)
-	(signal 'error (list "couldn't parse font name" name)))
+(or face-family
-(setq face-family (capitalize (match-string 1 name)))
+	(signal 'error (list "couldn't parse font name for face" face)))
-(or (string-match x-font-regexp name)
-	(signal 'error (list "couldn't parse font name" name)))
-(setq face-weight (match-string 1 name))
-(setq face-size (match-string 6 name))
 ;; If this face matches the old default face in the attribute we
 ;; are changing, then change it to the new attribute along that
 ;; dimension.  Also, the face must have its own global attribute.
 ;; If its value is inherited, we don't touch it.  If any of this
 ;; is not true, we leave it alone.
-(if (and (face-font face 'global)
+(when (and (face-font face 'global)
-	     (cond
+	       (cond
-	      (to-family (equal face-family from-family))
+		(to-family (string-equal face-family from-family))
-	      (to-weight (equal face-weight from-weight))
+		(to-weight (string-equal face-weight from-weight))
-	      (to-size   (equal face-size from-size))))
+		(to-size   (=            face-size   from-size))))
-	(set-face-font face
+(set-face-font face
-		       (font-menu-load-font (or to-family face-family)
+		     (font-menu-load-font (or to-family face-family)
-					    (or to-weight face-weight)
+					  (or to-weight face-weight)
-					    (or to-size   face-size)
+					  (or to-size   face-size)
-					    name)
+					  face-slant
-		       (and font-menu-this-frame-only-p
+					  font-menu-preferred-resolution)
-			    (selected-frame)))
+		     (and font-menu-this-frame-only-p
-nil)))
+			  (selected-frame))))))
+(defun font-menu-load-font (family weight size slant resolution)
-(defun font-menu-load-font (family weight size from-font)
+"Try to load a font with the requested properties.
-(and (numberp size) (setq size (int-to-string size)))
+The weight, slant and resolution are only hints."
-(let ((case-fold-search t)
+(when (integerp size) (setq size (int-to-string size)))
-	slant other-slant
+(let (font)
-	registry encoding resx resy)
+(catch 'got-font
-(or (string-match x-font-regexp-registry-and-encoding from-font)
+(dolist (weight (list weight "*"))
-	(signal 'error (list "couldn't parse font name" from-font)))
+	(dolist (slant
-(setq registry (match-string 1 from-font)
+		 (cond ((string-equal slant "O") '("O" "I" "*"))
-	  encoding (match-string 2 from-font))
+		       ((string-equal slant "I") '("I" "O" "*"))
+		       ((string-equal slant "*") '("*"))
-(or (string-match x-font-regexp from-font)
+		       (t (list slant "*"))))
-	(signal 'error (list "couldn't parse font name" from-font)))
+	  (dolist (resolution
-(setq slant (capitalize (match-string 2 from-font))
+		   (if (string-equal resolution "*-*")
-	  resx  (match-string 7 from-font)
+		       (list resolution)
-	  resy  (match-string 8 from-font))
+		     (list resolution "*-*")))
-(setq other-slant (cond ((equal slant "O") "I") ; oh, bite me.
+	    (when (setq font
-			    ((equal slant "I") "O")
+			(make-font-instance
-			    (t nil)))
+			 (concat  "-*-" family "-" weight "-" slant "-*-*-*-"
-;;
+				  size "-" resolution "-*-*-"
-;; Remember these values for the first font we switch away from
+				  font-menu-registry-encoding)
-;; (the original default font).
+			 nil t))
-;;
+	      (throw 'got-font font))))))))
-(or font-menu-preferred-resolution
-	(setq font-menu-preferred-resolution (cons resx resy)))
-(or font-menu-preferred-registry
-	(setq font-menu-preferred-registry (cons registry encoding)))
-;;
-;; Now we know all the interesting properties of the font we want.
-;; Let's see what we can actually *get*.
-;;
-(or ;; First try the default resolution, registry, and encoding.
-(make-font-instance
-	 (concat "-*-" family "-" weight "-" slant "-*-*-*-" size
-		 "-" (car font-menu-preferred-resolution)
-		 "-" (cdr font-menu-preferred-resolution)
-		 "-*-*-"
-		 (car font-menu-preferred-registry) "-"
-		 (cdr font-menu-preferred-registry))
-	 nil t)
-	;; Then try that in the other slant.
-	(and other-slant
-	     (make-font-instance
-	      (concat "-*-" family "-" weight "-" other-slant
-		      "-*-*-*-" size
-		      "-" (car font-menu-preferred-resolution)
-		      "-" (cdr font-menu-preferred-resolution)
-		      "-*-*-"
-		      (car font-menu-preferred-registry) "-"
-		      (cdr font-menu-preferred-registry))
-	      nil t))
-	;; Then try the default resolution and registry, any encoding.
-	(make-font-instance
-	 (concat "-*-" family "-" weight "-" slant "-*-*-*-" size
-		 "-" (car font-menu-preferred-resolution)
-		 "-" (cdr font-menu-preferred-resolution)
-		 "-*-*-"
-		 (car font-menu-preferred-registry) "-*")
-	 nil t)
-	;; Then try that in the other slant.
-	(and other-slant
-	     (make-font-instance
-	      (concat "-*-" family "-" weight "-" other-slant
-		      "-*-*-*-" size
-		      "-" (car font-menu-preferred-resolution)
-		      "-" (cdr font-menu-preferred-resolution)
-		      "-*-*-"
-		      (car font-menu-preferred-registry) "-*")
-	      nil t))
-	;; Then try the default registry and encoding, any resolution.
-	(make-font-instance
-	 (concat "-*-" family "-" weight "-" slant "-*-*-*-" size
-		 "-*-*-*-*-"
-		 (car font-menu-preferred-registry) "-"
-		 (cdr font-menu-preferred-registry))
-	 nil t)
-	;; Then try that in the other slant.
-	(and other-slant
-	     (make-font-instance
-	      (concat "-*-" family "-" weight "-" other-slant
-		      "-*-*-*-" size
-		      "-*-*-*-*-"
-		      (car font-menu-preferred-registry) "-"
-		      (cdr font-menu-preferred-registry))
-	      nil t))
-	;; Then try the default registry, any encoding or resolution.
-	(make-font-instance
-	 (concat "-*-" family "-" weight "-" slant "-*-*-*-" size
-		 "-*-*-*-*-"
-		 (car font-menu-preferred-registry) "-*")
-	 nil t)
-	;; Then try that in the other slant.
-	(and other-slant
-	     (make-font-instance
-	      (concat "-*-" family "-" weight "-" slant "-*-*-*-"
-		      size "-*-*-*-*-"
-		      (car font-menu-preferred-registry) "-*")
-	      nil t))
-	;; Then try anything in the same slant, and error if it fails...
-	(and other-slant
-	     (make-font-instance
-	      (concat "-*-" family "-" weight "-" slant "-*-*-*-"
-		      size "-*-*-*-*-*-*")))
-	(make-font-instance
-	 (concat "-*-" family "-" weight "-" (or other-slant slant)
-		 "-*-*-*-" size "-*-*-*-*-*-*"))
-	)))
 (defun flush-device-fonts-cache (device)
 ;; by Stig@hackvan.com
 (let ((elt (assq device device-fonts-cache)))
 (and elt

Mercurial > hg > xemacs-beta

comparison lisp/x11/x-font-menu.el @ 86:364816949b59 r20-0b93