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