1 ;; msw-font-menu.el --- Managing menus of mswindows fonts.
3 ;; Copyright (C) 1999 Free Software Foundation, Inc.
5 ;; Adapted from x-font-menu.el by Andy Piper <andy@xemacs.org>
7 ;; This file is part of XEmacs.
9 ;; XEmacs is free software; you can redistribute it and/or modify it
10 ;; under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; XEmacs is distributed in the hope that it will be useful, but
15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 ;; General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with XEmacs; see the file COPYING. If not, write to the
21 ;; Free Software Foundation, 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA.
24 ;;; mswindows fonts look like:
25 ;;; fontname[:[weight][ style][:pointsize[:effects]]][:charset]
27 ;;; Lucida Console:Regular:10
31 ;;; Courier New:Bold Italic:10:underline strikeout:western
35 ;; #### - implement these...
37 ;;; (defvar font-menu-ignore-proportional-fonts nil
38 ;;; "*If non-nil, then the font menu will only show fixed-width fonts.")
42 (defvar mswindows-font-menu-registry-encoding nil
43 "Registry and encoding to use with font menu fonts.")
45 (defvar mswindows-font-menu-junk-families
51 "A regexp matching font families which are uninteresting (e.g. cursor fonts).")
53 (defvar mswindows-font-regexp-ascii nil
54 "This is used to filter out font families that can't display ASCII text.
55 It must be set at run-time.")
58 (defun mswindows-reset-device-font-menus (device &optional debug)
59 "Generates the `Font', `Size', and `Weight' submenus for the Options menu.
60 This is run the first time that a font-menu is needed for each device.
61 If you don't like the lazy invocation of this function, you can add it to
62 `create-device-hook' and that will make the font menus respond more quickly
63 when they are selected for the first time. If you add fonts to your system,
64 or if you change your font path, you can call this to re-initialize the menus."
65 (unless mswindows-font-regexp-ascii
66 (setq mswindows-font-regexp-ascii (if (featurep 'mule)
67 (charset-registry 'ascii)
69 (setq mswindows-font-menu-registry-encoding (if (featurep 'mule) "" "Western"))
70 (let ((case-fold-search t)
71 family size weight entry
72 dev-cache cache families sizes weights)
73 (dolist (name (cond ((null debug) ; debugging kludge
74 (list-fonts "::::" device))
75 ((stringp debug) (split-string debug "\n"))
77 (when (and (string-match mswindows-font-regexp-ascii name)
78 (string-match mswindows-font-regexp name))
79 (setq weight (capitalize (match-string 2 name))
80 size (string-to-int (or (match-string 4 name) "0"))
81 family (match-string 1 name))
82 (unless (string-match mswindows-font-menu-junk-families family)
83 (setq entry (or (vassoc name cache)
85 (cons (vector family nil nil t)
87 (or (member family families) (push family families))
88 (or (member weight weights) (push weight weights))
89 (or (member size sizes) (push size sizes))
90 (or (member weight (aref entry 1)) (push weight (aref entry 1)))
91 (or (member size (aref entry 2)) (push size (aref entry 2))))))
93 ;; Hack scalable fonts.
94 ;; Some fonts come only in scalable versions (the only size is 0)
95 ;; and some fonts come in both scalable and non-scalable versions
96 ;; (one size is 0). If there are any scalable fonts at all, make
97 ;; sure that the union of all point sizes contains at least some
98 ;; common sizes - it's possible that some sensible sizes might end
99 ;; up not getting mentioned explicitly.
102 (let ((common '(6 8 10 12 14 16 18 24)))
104 (or;;(member (car common) sizes) ; not enough slack
107 (while (and (not done) rest)
108 (if (and (> (car common) (- (car rest) 1))
109 (< (car common) (+ (car rest) 1)))
111 (setq rest (cdr rest)))
113 (setq sizes (cons (car common) sizes)))
114 (setq common (cdr common)))
115 (setq sizes (delq 0 sizes))))
117 (setq families (sort families 'string-lessp)
118 weights (sort weights 'string-lessp)
119 sizes (sort sizes '<))
121 (dolist (entry cache)
122 (aset entry 1 (sort (aref entry 1) 'string-lessp))
123 (aset entry 2 (sort (aref entry 2) '<)))
125 (setq dev-cache (assq device device-fonts-cache))
127 (setq dev-cache (car (push (list device) device-fonts-cache))))
134 (list 'font-menu-set-font x nil nil)
135 ':style 'radio ':active nil ':selected nil))
138 (vector (int-to-string x)
139 (list 'font-menu-set-font nil nil x)
140 ':style 'radio ':active nil ':selected nil))
144 (list 'font-menu-set-font nil x nil)
145 ':style 'radio ':active nil ':selected nil))
149 ;; Extract font information from a face. We examine both the
150 ;; user-specified font name and the canonical (`true') font name.
151 ;; These can appear to have totally different properties.
153 ;; We use the user-specified one if possible, else use the truename.
154 ;; If the user didn't specify one get the truename and use the
155 ;; possibly suboptimal data from that.
157 (defun* mswindows-font-menu-font-data (face dcache)
158 (let* ((case-fold-search t)
159 (domain (if font-menu-this-frame-only-p
162 (name (font-instance-name (face-font-instance face domain)))
163 (truename (font-instance-truename
164 (face-font-instance face domain
165 (if (featurep 'mule) 'ascii))))
166 family size weight entry slant)
167 (when (string-match mswindows-font-regexp name)
168 (setq family (match-string 1 name))
169 (setq entry (vassoc family (aref dcache 0))))
170 (when (and (null entry)
171 (string-match mswindows-font-regexp truename))
172 (setq family (match-string 1 truename))
173 (setq entry (vassoc family (aref dcache 0))))
175 (return-from mswindows-font-menu-font-data (make-vector 5 nil)))
177 (when (string-match mswindows-font-regexp name)
178 (setq weight (match-string 2 name))
179 (setq size (string-to-int (or (match-string 4 name) "0"))))
181 (when (string-match mswindows-font-regexp truename)
182 (when (not (member weight (aref entry 1)))
183 (setq weight (match-string 2 truename)))
184 (when (not (member size (aref entry 2)))
185 (setq size (string-to-int (or (match-string 4 truename) "0"))))
186 (setq slant (match-string 5 truename)))
188 (vector entry family size weight slant)))
190 (defun mswindows-font-menu-load-font (family weight size slant resolution)
191 "Try to load a font with the requested properties.
192 The weight, slant and resolution are only hints."
193 (when (integerp size) (setq size (int-to-string size)))
196 (dolist (weight (list weight ""))
198 ;; oblique is not currently implemented
199 (cond ((string-equal slant "Oblique") '(" Italic" ""))
200 ((string-equal slant "Italic") '(" Italic" ""))
201 (t (list slant ""))))
204 (concat family ":" weight slant ":"
206 mswindows-font-menu-registry-encoding)
208 (throw 'got-font font)))))))
210 (provide 'mswindows-font-menu)
212 ;;; msw-font-menu.el ends here