1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
|
;;; font-tests.el --- Test suite for font-related functions. -*- lexical-binding: t -*-
;; Copyright (C) 2011-2021 Free Software Foundation, Inc.
;; Author: Chong Yidong <cyd@stupidchicken.com>
;; Keywords: internal
;; Human-Keywords: internal
;; This file is part of GNU Emacs.
;; GNU Emacs 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 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs 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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Type M-x test-font-parse RET to generate the test buffer.
;;; Code:
(require 'ert)
(defvar font-parse-tests--data
`((" " ,(intern " ") nil nil nil nil)
("Monospace" Monospace nil nil nil nil)
("Monospace Serif" ,(intern "Monospace Serif") nil nil nil nil)
("Foo1" Foo1 nil nil nil nil)
("12" nil 12.0 nil nil nil)
("12 " ,(intern "12 ") nil nil nil nil)
;; Fontconfig format
("Foo:" Foo nil nil nil nil)
("Foo-8" Foo 8.0 nil nil nil)
("Foo-18:" Foo 18.0 nil nil nil)
("Foo-18:light" Foo 18.0 light nil nil)
("Foo 10:weight=bold" ,(intern "Foo 10") nil bold nil nil)
("Foo-12:weight=bold" Foo 12.0 bold nil nil)
("Foo 8-20:slant=oblique" ,(intern "Foo 8") 20.0 nil oblique nil)
("Foo:light:roman" Foo nil light roman nil)
("Foo:italic:roman" Foo nil nil roman nil)
("Foo 12:light:oblique" ,(intern "Foo 12") nil light oblique nil)
("Foo-12:demibold:oblique" Foo 12.0 demibold oblique nil)
("Foo:black:proportional" Foo nil black nil 0)
("Foo-10:black:proportional" Foo 10.0 black nil 0)
("Foo:weight=normal" Foo nil normal nil nil)
("Foo:weight=bold" Foo nil bold nil nil)
("Foo:weight=bold:slant=italic" Foo nil bold italic)
("Foo:weight=bold:slant=italic:mono" Foo nil bold italic 100)
("Foo-10:demibold:slant=normal" Foo 10.0 demibold normal nil)
("Foo 11-16:oblique:weight=bold" ,(intern "Foo 11") 16.0 bold oblique nil)
("Foo:oblique:randomprop=randomtag:weight=bold" Foo nil bold oblique nil)
("Foo:randomprop=randomtag:bar=baz" Foo nil nil nil nil)
("Foo Book Light:bar=baz" ,(intern "Foo Book Light") nil nil nil nil)
("Foo Book Light 10:bar=baz" ,(intern "Foo Book Light 10") nil nil nil nil)
("Foo Book Light-10:bar=baz" ,(intern "Foo Book Light") 10.0 nil nil nil)
;; GTK format
("Oblique" nil nil nil oblique nil)
("Bold 17" nil 17.0 bold nil nil)
("17 Bold" ,(intern "17") nil bold nil nil)
("Book Oblique 2" nil 2.0 book oblique nil)
("Bar 7" Bar 7.0 nil nil nil)
("Bar Ultra-Light" Bar nil ultra-light nil nil)
("Bar Light 8" Bar 8.0 light nil nil)
("Bar Book Medium 9" Bar 9.0 medium nil nil)
("Bar Semi-Bold Italic 10" Bar 10.0 semi-bold italic nil)
("Bar Semi-Condensed Bold Italic 11" Bar 11.0 bold italic nil)
("Foo 10 11" ,(intern "Foo 10") 11.0 nil nil nil)
("Foo 1985 Book" ,(intern "Foo 1985") nil book nil nil)
("Foo 1985 A Book" ,(intern "Foo 1985 A") nil book nil nil)
("Foo 1 Book 12" ,(intern "Foo 1") 12.0 book nil nil)
("Foo A Book 12 A" ,(intern "Foo A Book 12 A") nil nil nil nil)
("Foo 1985 Book 12 Oblique" ,(intern "Foo 1985 Book 12") nil nil oblique nil)
("Foo 1985 Book 12 Italic 10" ,(intern "Foo 1985 Book 12") 10.0 nil italic nil)
("Foo Book Bar 6 Italic" ,(intern "Foo Book Bar 6") nil nil italic nil)
("Foo Book Bar Bold" ,(intern "Foo Book Bar") nil bold nil nil))
"List of font names parse data.
Each element should have the form
(NAME FAMILY SIZE WEIGHT SLANT SPACING)
where NAME is the name to parse, and the remainder are the
expected font properties from parsing NAME.")
(defun font-parse-check (name prop expected)
(let ((result (font-get (font-spec :name name) prop)))
(if (and (symbolp result) (symbolp expected))
(eq result expected)
(equal result expected))))
(put 'font-parse-check 'ert-explainer 'font-parse-explain)
(defun font-parse-explain (name prop expected)
(let ((result (font-get (font-spec :name name) prop))
(propname (symbol-name prop)))
(format "Parsing `%s': expected %s `%s', got `%s'."
name (substring propname 1) expected
(font-get (font-spec :name name) prop))))
(ert-deftest font-parse-tests ()
"Test parsing of Fontconfig-style and GTK-style font names."
(dolist (test font-parse-tests--data)
(let* ((name (nth 0 test)))
(should (font-parse-check name :family (nth 1 test)))
(should (font-parse-check name :size (nth 2 test)))
(should (font-parse-check name :weight (nth 3 test)))
(should (font-parse-check name :slant (nth 4 test)))
(should (font-parse-check name :spacing (nth 5 test))))))
(defun test-font-parse ()
"Test font name parsing."
(interactive)
(switch-to-buffer (generate-new-buffer "*Font Pase Test*"))
(setq show-trailing-whitespace nil)
(let ((pass-face '((t :foreground "green")))
(fail-face '((t :foreground "red"))))
(dolist (test font-parse-tests--data)
(let* ((name (nth 0 test))
(fs (font-spec :name name))
(family (font-get fs :family))
(size (font-get fs :size))
(weight (font-get fs :weight))
(slant (font-get fs :slant))
(spacing (font-get fs :spacing)))
(insert name)
(if (> (current-column) 20)
(insert "\n"))
(indent-to-column 21)
(insert (propertize (symbol-name family)
'face (if (eq family (nth 1 test))
pass-face
fail-face)))
(indent-to-column 40)
(insert (propertize (format "%s" size)
'face (if (equal size (nth 2 test))
pass-face
fail-face)))
(indent-to-column 48)
(insert (propertize (format "%s" weight)
'face (if (eq weight (nth 3 test))
pass-face
fail-face)))
(indent-to-column 60)
(insert (propertize (format "%s" slant)
'face (if (eq slant (nth 4 test))
pass-face
fail-face)))
(indent-to-column 69)
(insert (propertize (format "%s" spacing)
'face (if (eq spacing (nth 5 test))
pass-face
fail-face)))
(insert "\n"))))
(goto-char (point-min)))
(ert-deftest font-parse-xlfd-test ()
;; Normal number of segments.
(should (equal (font-get
(font-spec :name "-GNU -FreeSans-semibold-italic-normal-*-*-*-*-*-*-0-iso10646-1")
:family)
'FreeSans))
(should (equal (font-get
(font-spec :name "-GNU -FreeSans-semibold-italic-normal-*-*-*-*-*-*-0-iso10646-1")
:foundry)
'GNU\ ))
;; Dash in the family name.
(should (equal (font-get
(font-spec :name "-Take-mikachan-PS-normal-normal-normal-*-*-*-*-*-*-0-iso10646-1")
:family)
'mikachan-PS))
(should (equal (font-get
(font-spec :name "-Take-mikachan-PS-normal-normal-normal-*-*-*-*-*-*-0-iso10646-1")
:weight)
'normal))
;; Synthetic test.
(should (equal (font-get
(font-spec :name "-foundry-name-with-lots-of-dashes-normal-normal-normal-*-*-*-*-*-*-0-iso10646-1")
:family)
'name-with-lots-of-dashes)))
;; Local Variables:
;; no-byte-compile: t
;; End:
(provide 'font-tests)
;;; font-tests.el ends here.
|
