428
+ − 1 ;;; msw-faces.el --- mswindows-specific face stuff.
+ − 2
+ − 3 ;;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
793
+ − 4 ;;; Copyright (C) 1995, 1996, 2002 Ben Wing.
428
+ − 5
+ − 6 ;; Author: Jamie Zawinski
+ − 7 ;; Modified by: Chuck Thompson
+ − 8 ;; Modified by: Ben Wing
+ − 9 ;; Modified by: Martin Buchholz
+ − 10 ;; Rewritten for mswindows by: Jonathan Harris
+ − 11
+ − 12 ;; This file is part of XEmacs.
+ − 13
+ − 14 ;; XEmacs is free software; you can redistribute it and/or modify it
+ − 15 ;; under the terms of the GNU General Public License as published by
+ − 16 ;; the Free Software Foundation; either version 2, or (at your option)
+ − 17 ;; any later version.
+ − 18
+ − 19 ;; XEmacs is distributed in the hope that it will be useful, but
+ − 20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
+ − 21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ − 22 ;; General Public License for more details.
+ − 23
+ − 24 ;; You should have received a copy of the GNU General Public License
+ − 25 ;; along with XEmacs; see the file COPYING. If not, write to the
+ − 26 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ − 27 ;; Boston, MA 02111-1307, USA.
+ − 28
+ − 29 ;; This file does the magic to parse mswindows font names, and make sure that
+ − 30 ;; the default and modeline attributes of new frames are specified enough.
+ − 31
1346
+ − 32 (globally-declare-boundp
+ − 33 '(mswindows-font-regexp mswindows-font-regexp-missing-1
+ − 34 mswindows-font-regexp-missing-2 mswindows-font-regexp-missing-3
+ − 35 mswindows-font-regexp-missing-4))
+ − 36
853
+ − 37 (defun mswindows-init-global-faces ()
+ − 38 (set-face-font 'gui-element "MS Sans Serif:Regular:8" nil 'mswindows))
793
+ − 39
428
+ − 40 (defun mswindows-init-device-faces (device)
442
+ − 41 (let ((color-default (device-system-metric device 'color-default))
+ − 42 (color-3d-face (device-system-metric device 'color-3d-face)))
+ − 43 ; Force creation of the default face font so that if it fails we get
+ − 44 ; an error now instead of a crash at frame creation.
+ − 45 (unless (face-font-instance 'default device)
+ − 46 (error "Can't find a suitable default font"))
872
+ − 47
+ − 48 ;; Don't set them on the device because then the global setting won't
+ − 49 ;; override them.
+ − 50 ;; #### Use device tags if we have multiple msprinter devices. (can we?)
442
+ − 51 (if (car color-default)
872
+ − 52 (set-face-foreground 'default (car color-default) nil
+ − 53 (device-type device)))
442
+ − 54 (if (cdr color-default)
872
+ − 55 (set-face-background 'default (cdr color-default) nil
+ − 56 (device-type device)))
442
+ − 57 (if (car color-3d-face)
872
+ − 58 (set-face-foreground 'gui-element (car color-3d-face) nil
+ − 59 (device-type device)))
442
+ − 60 (if (cdr color-3d-face)
872
+ − 61 (set-face-background 'gui-element (cdr color-3d-face) nil
+ − 62 (device-type device)))
793
+ − 63 ))
428
+ − 64
+ − 65 (defun mswindows-init-frame-faces (frame)
+ − 66 )
+ − 67
+ − 68 ;; Other functions expect these regexps
872
+ − 69 (let
+ − 70 ((- ":")
4022
+ − 71 ;; What happens if a font family contains a colon? I can't find any
+ − 72 ;; documentation on that, and don't have a font editor to hand to test.
+ − 73 (fontname "\\([^:]*\\)") ; 1
872
+ − 74 (style "\\(\\(?:[a-zA-Z]+\\(?: +[a-zA-Z]+\\)*\\)?\\)") ; 2
+ − 75 (pointsize "\\([0-9]*\\)") ; 3
+ − 76 (effects "\\(\\(?:[a-zA-Z]+\\(?: +[a-zA-Z]+\\)*\\)?\\)") ; 4
+ − 77 ;; must match "OEM/DOS"
+ − 78 (charset "\\([a-zA-Z/ ]*\\)") ; 5
+ − 79 )
+ − 80 (defconst mswindows-font-regexp
+ − 81 (concat "^" fontname - style - pointsize - effects - charset "$"))
+ − 82 (defconst mswindows-font-regexp-missing-1
+ − 83 (concat "^" fontname - style - pointsize - effects "$"))
+ − 84 (defconst mswindows-font-regexp-missing-2
+ − 85 (concat "^" fontname - style - pointsize "$"))
+ − 86 (defconst mswindows-font-regexp-missing-3
+ − 87 (concat "^" fontname - style "$"))
+ − 88 (defconst mswindows-font-regexp-missing-4
+ − 89 (concat "^" fontname "$"))
+ − 90 )
428
+ − 91
+ − 92 ;;; Fill in missing parts of a font spec. This is primarily intended as a
+ − 93 ;;; helper function for the functions below.
+ − 94 ;;; mswindows fonts look like:
872
+ − 95 ;;; fontname[:[weight][ slant][:pointsize[:effects]]][:charset]
428
+ − 96 ;;; A minimal mswindows font spec looks like:
+ − 97 ;;; Courier New
+ − 98 ;;; A maximal mswindows font spec looks like:
+ − 99 ;;; Courier New:Bold Italic:10:underline strikeout:Western
872
+ − 100 (defun mswindows-canonicalize-font-name (font)
+ − 101 "Given a mswindows font or font name, return its name in canonical form.
+ − 102 This adds missing colons and fills in the style field with \"Regular\".
+ − 103 This does *NOT* fill in the point size or charset fields, because in those
+ − 104 cases an empty field is not equivalent to any particular field value, but a
+ − 105 wildcard allowing for any possible value (charset Western and point size 10
+ − 106 are chosen first, if they exist)."
+ − 107 (if (font-instance-p font) (setq font (font-instance-name font)))
+ − 108 ;; fill in missing colons
+ − 109 (setq font
+ − 110 (cond ((string-match mswindows-font-regexp font) font)
+ − 111 ((string-match mswindows-font-regexp-missing-1 font)
+ − 112 (concat font ":"))
+ − 113 ((string-match mswindows-font-regexp-missing-2 font)
+ − 114 (concat font "::"))
+ − 115 ((string-match mswindows-font-regexp-missing-3 font)
+ − 116 (concat font ":::"))
+ − 117 ((string-match mswindows-font-regexp-missing-4 font)
+ − 118 (concat font "::::"))
+ − 119 (t "::::")))
+ − 120 (or (string-match mswindows-font-regexp font) (error "can't parse %S" font))
+ − 121 (if (equal "" (match-string 2 font))
+ − 122 (concat (substring font 0 (match-beginning 2)) "Regular"
+ − 123 (substring font (match-beginning 2)))
+ − 124 font))
+ − 125
+ − 126 (defun mswindows-parse-font-style (style)
+ − 127 ;; Parse a style into a cons (WEIGHT . SLANT). WEIGHT will never be the
+ − 128 ;; empty string (it may be "Regular"), but SLANT will be empty for
+ − 129 ;; non-italic.
+ − 130 (save-match-data
+ − 131 (let ((case-fold-search t))
+ − 132 (cond ((equalp style "Italic") '("Regular" . "Italic"))
+ − 133 ((string-match "^\\([a-zA-Z ]+?\\) +Italic$" style)
+ − 134 (cons (match-string 1 style) "Italic"))
+ − 135 (t (cons style ""))))))
+ − 136
+ − 137 (defun mswindows-construct-font-style (weight slant)
+ − 138 ;; Construct the style from WEIGHT and SLANT. Opposite of
+ − 139 ;; mswindows-parse-font-style.
+ − 140 (cond ((and (equal slant "") (equal weight "")) "Regular")
+ − 141 ((equal slant "") weight)
+ − 142 ((or (equalp weight "Regular") (equal weight "")) slant)
+ − 143 (t (concat weight " " slant))))
+ − 144
+ − 145 (defun mswindows-frob-font-style (font which)
+ − 146 ;; Given a font name or font instance, return a name with the style field
+ − 147 ;; (which includes weight and/or slant) changed according to WHICH, a plist.
+ − 148 ;; If no entry found, don't change.
+ − 149 (if (null font) nil
+ − 150 (setq font (mswindows-canonicalize-font-name font))
+ − 151 (or (string-match mswindows-font-regexp font)
+ − 152 (error "can't parse %S" font))
+ − 153 (let* ((style (match-string 2 font))
+ − 154 (style-rep
+ − 155 (save-match-data
+ − 156 (or (loop for (x y) on which by #'cddr
+ − 157 if (string-match (concat "^" x "$") style)
+ − 158 return (replace-match y nil nil style))
+ − 159 style))))
+ − 160 (concat (substring font 0 (match-beginning 2))
+ − 161 style-rep
+ − 162 (substring font (match-end 2))))))
+ − 163
+ − 164 (defun mswindows-frob-font-style-and-sizify (font which &optional device)
+ − 165 (if (null font) nil
+ − 166 (let* ((oldwidth (if (font-instance-p font) (font-instance-width font)
+ − 167 (let ((fi (make-font-instance font device t)))
+ − 168 (and fi (font-instance-width fi)))))
+ − 169 (newname (mswindows-frob-font-style font which))
+ − 170 (newfont (make-font-instance newname device t)))
+ − 171 ;; Hack! On MS Windows, bold fonts (even monospaced) are often wider
+ − 172 ;; than the equivalent non-bold font. Making the bold font one point
+ − 173 ;; smaller usually makes it the same width (maybe at the expense of
+ − 174 ;; making it one pixel shorter). Do the same trick in both directions.
+ − 175 (when (font-instance-p newfont)
+ − 176 (let ((newerfont newfont))
+ − 177 (block nil
+ − 178 (while (and newerfont oldwidth)
+ − 179 (setq newfont newerfont)
+ − 180 (cond ((< (font-instance-width newfont) oldwidth)
+ − 181 (setq newerfont
+ − 182 (make-font-instance
+ − 183 (mswindows-find-larger-font newfont device)
+ − 184 device t))
+ − 185 (if (and newerfont
+ − 186 (> (font-instance-width newerfont) oldwidth))
+ − 187 (return nil)))
+ − 188 ((> (font-instance-width newfont) oldwidth)
+ − 189 (setq newerfont
+ − 190 (make-font-instance
+ − 191 (mswindows-find-smaller-font newfont device)
+ − 192 device t))
+ − 193 (if (and newerfont
+ − 194 (< (font-instance-width newerfont) oldwidth))
+ − 195 (return nil)))
+ − 196 (t (return nil))))))
+ − 197 (if (font-instance-p newfont) (font-instance-name newfont) newfont)))))
+ − 198
+ − 199 (defconst mswindows-nonbold-weight-regexp
+ − 200 ;; He looked so, so cool with the ultra light dangling from his mouth as
+ − 201 ;; his fingers spun out demisemiquavers from the keyboard ...
+ − 202 "\\(Regular\\|Thin\\|Extra Light\\|Ultra Light\\|Light\\|Normal\\|Medium\\|Semi Bold\\|Demi Bold\\)"
+ − 203 )
+ − 204 (defconst mswindows-bold-weight-regexp
+ − 205 "\\(Semi Bold\\|Demi Bold\\|Bold\\|Extra Bold\\|Ultra Bold\\|Heavy\\|Black\\)"
+ − 206 )
+ − 207
+ − 208 (defconst mswindows-make-font-bold-mapper
+ − 209 `(,mswindows-nonbold-weight-regexp "Bold"
+ − 210 "Italic" "Bold Italic"
+ − 211 ,(concat mswindows-nonbold-weight-regexp " Italic") "Bold Italic"))
+ − 212
+ − 213 (defconst mswindows-make-font-nonbold-mapper
+ − 214 `(,mswindows-bold-weight-regexp "Regular"
+ − 215 ,(concat mswindows-bold-weight-regexp " Italic") "Italic"))
+ − 216
+ − 217 (defconst mswindows-make-font-italic-mapper
+ − 218 '("\\(.*\\)Italic" "\\1Italic"
+ − 219 "\\(.*\\)" "\\1 Italic"))
+ − 220
+ − 221 (defconst mswindows-make-font-unitalic-mapper
+ − 222 '("Italic" "Regular"
+ − 223 "\\(.*\\) Italic" "\\1"))
+ − 224
+ − 225 (defconst mswindows-make-font-bold-italic-mapper
+ − 226 `(,mswindows-nonbold-weight-regexp "Bold Italic"
+ − 227 ,(concat mswindows-nonbold-weight-regexp " Italic") "Bold Italic"
+ − 228 "Italic" "Bold Italic"
+ − 229 ,mswindows-bold-weight-regexp "\\1 Italic"))
428
+ − 230
+ − 231 (defun mswindows-make-font-bold (font &optional device)
+ − 232 "Given a mswindows font specification, this attempts to make a bold font.
+ − 233 If it fails, it returns nil."
872
+ − 234 (mswindows-frob-font-style-and-sizify font mswindows-make-font-bold-mapper
+ − 235 device))
428
+ − 236
+ − 237 (defun mswindows-make-font-unbold (font &optional device)
+ − 238 "Given a mswindows font specification, this attempts to make a non-bold font.
+ − 239 If it fails, it returns nil."
872
+ − 240 (mswindows-frob-font-style-and-sizify font mswindows-make-font-nonbold-mapper
+ − 241 device))
428
+ − 242
+ − 243 (defun mswindows-make-font-italic (font &optional device)
+ − 244 "Given a mswindows font specification, this attempts to make an `italic'
+ − 245 font. If it fails, it returns nil."
872
+ − 246 (try-font-name (mswindows-frob-font-style
+ − 247 font mswindows-make-font-italic-mapper) device))
428
+ − 248
+ − 249 (defun mswindows-make-font-unitalic (font &optional device)
+ − 250 "Given a mswindows font specification, this attempts to make a non-italic
+ − 251 font. If it fails, it returns nil."
872
+ − 252 (try-font-name (mswindows-frob-font-style
+ − 253 font mswindows-make-font-unitalic-mapper) device))
428
+ − 254
+ − 255 (defun mswindows-make-font-bold-italic (font &optional device)
+ − 256 "Given a mswindows font specification, this attempts to make a `bold-italic'
+ − 257 font. If it fails, it returns nil."
872
+ − 258 (mswindows-frob-font-style-and-sizify font
+ − 259 mswindows-make-font-bold-italic-mapper
+ − 260 device))
+ − 261
+ − 262 (defun mswindows-available-font-sizes (font device)
+ − 263 (if (font-instance-p font) (setq font (font-instance-name font)))
+ − 264 (setq font (mswindows-canonicalize-font-name font))
+ − 265 (or (string-match mswindows-font-regexp font) (error "Can't parse %S" font))
+ − 266 ;; turn pointsize into wildcard
+ − 267 (setq font
+ − 268 (concat (substring font 0 (match-beginning 3))
+ − 269 (substring font (match-end 3) (match-end 0))))
+ − 270 (sort
+ − 271 (delq nil
+ − 272 (mapcar #'(lambda (name)
+ − 273 (and (string-match mswindows-font-regexp name)
+ − 274 (string-to-int (substring name (match-beginning 3)
+ − 275 (match-end 3)))))
2527
+ − 276 (font-list font device)))
872
+ − 277 #'<))
+ − 278
+ − 279 (defun mswindows-frob-font-size (font up-p device)
+ − 280 (if (stringp font) (setq font (make-font-instance font device)))
+ − 281 (let* ((name (font-instance-name font))
+ − 282 (truename (font-instance-truename font))
+ − 283 (available (and truename
+ − 284 (mswindows-available-font-sizes truename device))))
+ − 285 (if (null available) nil
+ − 286 (or (string-match mswindows-font-regexp truename)
+ − 287 (error "can't parse %S" truename))
+ − 288 (let ((old-size (string-to-int
+ − 289 (substring truename
+ − 290 (match-beginning 3) (match-end 3)))))
+ − 291 (or (> old-size 0) (error "font truename has 0 pointsize?"))
+ − 292 (or (string-match mswindows-font-regexp name)
+ − 293 (error "can't parse %S" name))
+ − 294 (let ((newsize
+ − 295 ;; scalable fonts: change size by 1 point.
+ − 296 (if (= 0 (car available))
+ − 297 (if (and (not up-p) (= 1 old-size)) nil
+ − 298 (if up-p (1+ old-size) (1- old-size)))
+ − 299 ;; non-scalable fonts: take the next available size.
+ − 300 (if up-p
+ − 301 (loop for tail on available
+ − 302 if (eql (car tail) old-size)
+ − 303 return (cadr tail))
+ − 304 (loop for tail on available
+ − 305 if (eql (cadr tail) old-size)
+ − 306 return (car tail))))))
+ − 307 (and newsize
+ − 308 (concat (substring name 0 (match-beginning 3))
+ − 309 (int-to-string newsize)
+ − 310 (substring name (match-end 3) (match-end 0)))))))))
428
+ − 311
+ − 312 (defun mswindows-find-smaller-font (font &optional device)
+ − 313 "Loads a new version of the given font (or font name) 1 point smaller.
+ − 314 Returns the font if it succeeds, nil otherwise."
872
+ − 315 (mswindows-frob-font-size font nil device))
428
+ − 316
+ − 317 (defun mswindows-find-larger-font (font &optional device)
+ − 318 "Loads a new version of the given font (or font name) 1 point larger.
+ − 319 Returns the font if it succeeds, nil otherwise."
872
+ − 320 (mswindows-frob-font-size font t device))