xemacs-beta: lisp/msw-font-menu.el comparison

comparison lisp/msw-font-menu.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
children	576fb035e263

comparison

equal deleted inserted replaced

-:f4aeb21a5bad
+:74fd4e045ea6
+;; msw-font-menu.el --- Managing menus of mswindows fonts.
+;; Copyright (C) 1999 Free Software Foundation, Inc.
+;; Adapted from x-font-menu.el by Andy Piper <andy@xemacs.org>
+;; 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
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; XEmacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+;; You should have received a copy of the GNU General Public License
+;; along with XEmacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+;;; mswindows fonts look like:
+;;;	fontname[:[weight][ style][:pointsize[:effects]]][:charset]
+;;; ie:
+;;;	Lucida Console:Regular:10
+;;; minimal:
+;;;	Courier New
+;;; maximal:
+;;;	Courier New:Bold Italic:10:underline strikeout:western
+;;; Code:
+;; #### - implement these...
+;;
+;;; (defvar font-menu-ignore-proportional-fonts nil
+;;;   "*If non-nil, then the font menu will only show fixed-width fonts.")
+(require 'font-menu)
+(defvar mswindows-font-menu-registry-encoding nil
+"Registry and encoding to use with font menu fonts.")
+(defvar mswindows-font-menu-junk-families
+(purecopy
+(mapconcat
+#'identity
+'("Symbol"
+)
+"\\|"))
+"A regexp matching font families which are uninteresting (e.g. cursor fonts).")
+(defvar mswindows-font-regexp-ascii nil
+"This is used to filter out font families that can't display ASCII text.
+It must be set at run-time.")
+;;;###autoload
+(defun mswindows-reset-device-font-menus (device &optional debug)
+"Generates the `Font', `Size', and `Weight' submenus for the Options menu.
+This is run the first time that a font-menu is needed for each device.
+If you don't like the lazy invocation of this function, you can add it to
+`create-device-hook' and that will make the font menus respond more quickly
+when they are selected for the first time.  If you add fonts to your system,
+or if you change your font path, you can call this to re-initialize the menus."
+(unless mswindows-font-regexp-ascii
+(setq mswindows-font-regexp-ascii (if (featurep 'mule)
+					  (charset-registry 'ascii)
+					"Western")))
+(setq mswindows-font-menu-registry-encoding (if (featurep 'mule) "" "Western"))
+(let ((case-fold-search t)
+	family size weight entry
+	dev-cache cache families sizes weights)
+(dolist (name (cond ((null debug)	; debugging kludge
+			 (list-fonts "::::" device))
+			((stringp debug) (split-string debug "\n"))
+			(t debug)))
+(when (and (string-match mswindows-font-regexp-ascii name)
+		 (string-match mswindows-font-regexp name))
+	(setq weight (capitalize (match-string 2 name))
+	      size   (string-to-int (or (match-string 4 name) "0"))
+	      family (match-string 1 name))
+	(unless (string-match mswindows-font-menu-junk-families family)
+	  (setq entry (or (vassoc name cache)
+			  (car (setq cache
+				     (cons (vector family nil nil t)
+					   cache)))))
+	  (or (member family families) (push family families))
+	  (or (member weight weights)  (push weight weights))
+	  (or (member size   sizes)    (push size   sizes))
+	  (or (member weight (aref entry 1)) (push weight (aref entry 1)))
+	  (or (member size   (aref entry 2)) (push size   (aref entry 2))))))
+;;
+;; 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
+;; sure that the union of all point sizes contains at least some
+;; common sizes - it's possible that some sensible sizes might end
+;; up not getting mentioned explicitly.
+;;
+(if (member 0 sizes)
+	  (let ((common '(6 8 10 12 14 16 18 24)))
+	    (while common
+	      (or;;(member (car common) sizes)   ; not enough slack
+	       (let ((rest sizes)
+		     (done nil))
+		 (while (and (not done) rest)
+		   (if (and (> (car common) (- (car rest) 1))
+			    (< (car common) (+ (car rest) 1)))
+		       (setq done t))
+		   (setq rest (cdr rest)))
+		 done)
+	       (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)
+	    sizes    (sort sizes '<))
+(dolist (entry cache)
+	(aset entry 1 (sort (aref entry 1) 'string-lessp))
+	(aset entry 2 (sort (aref entry 2) '<)))
+(setq dev-cache (assq device device-fonts-cache))
+(or dev-cache
+	  (setq dev-cache (car (push (list device) device-fonts-cache))))
+(setcdr
+dev-cache
+(vector
+	cache
+	(mapcar (lambda (x)
+		  (vector x
+			  (list 'font-menu-set-font x nil nil)
+			  ':style 'radio ':active nil ':selected nil))
+		families)
+	(mapcar (lambda (x)
+		  (vector (int-to-string x)
+			  (list 'font-menu-set-font nil nil x)
+			  ':style 'radio ':active nil ':selected nil))
+		sizes)
+	(mapcar (lambda (x)
+		  (vector x
+			  (list 'font-menu-set-font nil x nil)
+			  ':style 'radio ':active nil ':selected nil))
+		weights)))
+(cdr dev-cache)))
+;; Extract font information from a face.  We examine both the
+;; user-specified font name and the canonical (`true') font name.
+;; These can appear to have totally different properties.
+;; We use the user-specified one if possible, else use the truename.
+;; If the user didn't specify one get the truename and use the
+;; possibly suboptimal data from that.
+;;;###autoload
+(defun* mswindows-font-menu-font-data (face dcache)
+(let* ((case-fold-search t)
+	 (domain (if font-menu-this-frame-only-p
+				  (selected-frame)
+				(selected-device)))
+	 (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 mswindows-font-regexp name)
+(setq family (match-string 1 name))
+(setq entry (vassoc family (aref dcache 0))))
+(when (and (null entry)
+	       (string-match mswindows-font-regexp truename))
+(setq family (match-string 1 truename))
+(setq entry  (vassoc family (aref dcache 0))))
+(when (null entry)
+(return-from mswindows-font-menu-font-data (make-vector 5 nil)))
+(when (string-match mswindows-font-regexp name)
+(setq weight (match-string 2 name))
+(setq size   (string-to-int (match-string 4 name))))
+(when (string-match mswindows-font-regexp truename)
+(when (not (member weight (aref entry 1)))
+	(setq weight (match-string 2 truename)))
+(when (not (member size   (aref entry 2)))
+	(setq size (string-to-int (match-string 4 truename))))
+(setq slant (match-string 5 truename)))
+(vector entry family size weight slant)))
+(defun mswindows-font-menu-load-font (family weight size slant resolution)
+"Try to load a font with the requested properties.
+The weight, slant and resolution are only hints."
+(when (integerp size) (setq size (int-to-string size)))
+(let (font)
+(catch 'got-font
+(dolist (weight (list weight ""))
+	(dolist (slant
+		 ;; oblique is not currently implemented
+		 (cond ((string-equal slant "Oblique") '(" Italic" ""))
+		       ((string-equal slant "Italic") '(" Italic" ""))
+		       (t (list slant ""))))
+	  (when (setq font
+		      (make-font-instance
+		       (concat  family ":" weight slant ":"
+				size "::"
+				mswindows-font-menu-registry-encoding)
+		       nil t))
+	    (throw 'got-font font)))))))
+(provide 'mswindows-font-menu)
+;;; msw-font-menu.el ends here

Mercurial > hg > xemacs-beta

comparison lisp/msw-font-menu.el @ 398:74fd4e045ea6 r21-2-29