Mercurial > hg > xemacs-beta
comparison lisp/x-faces.el @ 3094:ad2f4ae9895b
[xemacs-hg @ 2005-11-26 11:45:47 by stephent]
Xft merge. <87k6ev4p8q.fsf@tleepslib.sk.tsukuba.ac.jp>
| author | stephent |
|---|---|
| date | Sat, 26 Nov 2005 11:46:25 +0000 |
| parents | 2f2d12f4f93a |
| children | d97bc868eaaf |
comparison
equal
deleted
inserted
replaced
| 3093:769dc945b085 | 3094:ad2f4ae9895b |
|---|---|
| 63 ;;; Code: | 63 ;;; Code: |
| 64 | 64 |
| 65 (globally-declare-fboundp | 65 (globally-declare-fboundp |
| 66 '(x-get-resource-and-maybe-bogosity-check | 66 '(x-get-resource-and-maybe-bogosity-check |
| 67 x-get-resource x-init-pointer-shape)) | 67 x-get-resource x-init-pointer-shape)) |
| 68 | |
| 69 (require 'fontconfig) | |
| 68 | 70 |
| 69 (defconst x-font-regexp nil) | 71 (defconst x-font-regexp nil) |
| 70 (defconst x-font-regexp-head nil) | 72 (defconst x-font-regexp-head nil) |
| 71 (defconst x-font-regexp-head-2 nil) | 73 (defconst x-font-regexp-head-2 nil) |
| 72 (defconst x-font-regexp-weight nil) | 74 (defconst x-font-regexp-weight nil) |
| 76 (defconst x-font-regexp-foundry-and-family nil) | 78 (defconst x-font-regexp-foundry-and-family nil) |
| 77 (defconst x-font-regexp-registry-and-encoding nil) | 79 (defconst x-font-regexp-registry-and-encoding nil) |
| 78 (defconst x-font-regexp-spacing nil) | 80 (defconst x-font-regexp-spacing nil) |
| 79 | 81 |
| 80 ;;; Regexps matching font names in "Host Portable Character Representation." | 82 ;;; Regexps matching font names in "Host Portable Character Representation." |
| 83 ;;; #### But more recently Latin-1 is permitted, and Xft needs it in C (?). | |
| 81 ;;; | 84 ;;; |
| 82 (let ((- "[-?]") | 85 (let ((- "[-?]") |
| 83 (foundry "[^-]*") | 86 (foundry "[^-]*") |
| 84 (family "[^-]*") | 87 (family "[^-]*") |
| 85 (weight "\\(bold\\|demibold\\|medium\\|black\\)") ; 1 | 88 (weight "\\(bold\\|demibold\\|medium\\|black\\)") ; 1 |
| 132 (setq x-font-regexp-spacing | 135 (setq x-font-regexp-spacing |
| 133 (concat - "\\(" spacing "\\)" - avgwidth | 136 (concat - "\\(" spacing "\\)" - avgwidth |
| 134 - registry - encoding "\\'")) | 137 - registry - encoding "\\'")) |
| 135 ) | 138 ) |
| 136 | 139 |
| 140 (defun x-font-xlfd-font-name-p (font) | |
| 141 "Check if FONT is an XLFD font name" | |
| 142 (and (stringp font) | |
| 143 (string-match x-font-regexp font))) | |
| 144 | |
| 137 ;; A "loser font" is something like "8x13" -> "8x13bold". | 145 ;; A "loser font" is something like "8x13" -> "8x13bold". |
| 138 ;; These are supported only through extreme generosity. | 146 ;; These are supported only through extreme generosity. |
| 139 (defconst x-loser-font-regexp "\\`[0-9]+x[0-9]+\\'") | 147 (defconst x-loser-font-regexp "\\`[0-9]+x[0-9]+\\'") |
| 140 | 148 |
| 141 (defun x-frob-font-weight (font which) | 149 (defun x-frob-font-weight (font which) |
| 165 (t nil))) | 173 (t nil))) |
| 166 | 174 |
| 167 (defun x-make-font-bold (font &optional device) | 175 (defun x-make-font-bold (font &optional device) |
| 168 "Given an X font specification, this attempts to make a `bold' font. | 176 "Given an X font specification, this attempts to make a `bold' font. |
| 169 If it fails, it returns nil." | 177 If it fails, it returns nil." |
| 178 (if (featurep 'xft-fonts) | |
| 179 (if (x-font-xlfd-font-name-p font) | |
| 180 (x-make-font-bold-core font device) | |
| 181 (x-make-font-bold-xft font device)) | |
| 182 (x-make-font-bold-core font device))) | |
| 183 | |
| 184 (defun x-make-font-bold-xft (font &optional device) | |
| 185 (let ((pattern (fc-font-real-pattern | |
| 186 font (or device (default-x-device))))) | |
| 187 (if pattern | |
| 188 (let ((size (fc-pattern-get-size pattern 0)) | |
| 189 (copy (fc-copy-pattern-partial | |
| 190 pattern (list fc-font-name-property-family)))) | |
| 191 (fc-pattern-del copy fc-font-name-property-weight) | |
| 192 (fc-pattern-del copy fc-font-name-property-style) | |
| 193 (when copy | |
| 194 (or | |
| 195 ;; try bold font | |
| 196 (let ((copy-2 (fc-pattern-duplicate copy))) | |
| 197 (fc-pattern-add copy-2 fc-font-name-property-weight | |
| 198 fc-font-name-weight-bold) | |
| 199 (when (fc-try-font copy-2 device) | |
| 200 (fc-pattern-add copy-2 fc-font-name-property-size size) | |
| 201 (fc-name-unparse copy-2))) | |
| 202 ;; try black font | |
| 203 (let ((copy-2 (fc-pattern-duplicate copy))) | |
| 204 (fc-pattern-add copy-2 fc-font-name-property-weight | |
| 205 fc-font-name-weight-black) | |
| 206 (when (fc-try-font copy-2 device) | |
| 207 (fc-pattern-add copy-2 fc-font-name-property-size size) | |
| 208 (fc-name-unparse copy-2))) | |
| 209 ;; try demibold font | |
| 210 (let ((copy-2 (fc-pattern-duplicate copy))) | |
| 211 (fc-pattern-add copy-2 fc-font-name-property-weight | |
| 212 fc-font-name-weight-demibold) | |
| 213 (when (fc-try-font copy-2 device) | |
| 214 (fc-pattern-add copy-2 fc-font-name-property-size size) | |
| 215 (fc-name-unparse copy-2))))))))) | |
| 216 | |
| 217 (defun x-make-font-bold-core (font &optional device) | |
| 170 ;; Certain Type1 fonts know "bold" as "black"... | 218 ;; Certain Type1 fonts know "bold" as "black"... |
| 171 (or (try-font-name (x-frob-font-weight font "bold") device) | 219 (or (try-font-name (x-frob-font-weight font "bold") device) |
| 172 (try-font-name (x-frob-font-weight font "black") device) | 220 (try-font-name (x-frob-font-weight font "black") device) |
| 173 (try-font-name (x-frob-font-weight font "demibold") device))) | 221 (try-font-name (x-frob-font-weight font "demibold") device))) |
| 174 | 222 |
| 175 (defun x-make-font-unbold (font &optional device) | 223 (defun x-make-font-unbold (font &optional device) |
| 176 "Given an X font specification, this attempts to make a non-bold font. | 224 "Given an X font specification, this attempts to make a non-bold font. |
| 177 If it fails, it returns nil." | 225 If it fails, it returns nil." |
| 226 (if (featurep 'xft-fonts) | |
| 227 (if (x-font-xlfd-font-name-p font) | |
| 228 (x-make-font-unbold-core font device) | |
| 229 (x-make-font-unbold-xft font device)) | |
| 230 (x-make-font-unbold-core font device))) | |
| 231 | |
| 232 (defun x-make-font-unbold-xft (font &optional device) | |
| 233 (let ((pattern (fc-font-real-pattern | |
| 234 font (or device (default-x-device))))) | |
| 235 (when pattern | |
| 236 (fc-pattern-del pattern fc-font-name-property-weight) | |
| 237 (fc-pattern-add pattern fc-font-name-property-weight | |
| 238 fc-font-name-weight-medium) | |
| 239 (if (fc-try-font pattern device) | |
| 240 (fc-name-unparse pattern))))) | |
| 241 | |
| 242 (defun x-make-font-unbold-core (font &optional device) | |
| 178 (try-font-name (x-frob-font-weight font "medium") device)) | 243 (try-font-name (x-frob-font-weight font "medium") device)) |
| 179 | 244 |
| 180 (defcustom try-oblique-before-italic-fonts nil | 245 (defcustom try-oblique-before-italic-fonts nil |
| 181 "*If nil, italic fonts are searched before oblique fonts. | 246 "*If nil, italic fonts are searched before oblique fonts. |
| 182 If non-nil, oblique fonts are tried before italic fonts. This is mostly | 247 If non-nil, oblique fonts are tried before italic fonts. This is mostly |
| 187 'try-oblique-before-italic-fonts) | 252 'try-oblique-before-italic-fonts) |
| 188 | 253 |
| 189 (defun x-make-font-italic (font &optional device) | 254 (defun x-make-font-italic (font &optional device) |
| 190 "Given an X font specification, this attempts to make an `italic' font. | 255 "Given an X font specification, this attempts to make an `italic' font. |
| 191 If it fails, it returns nil." | 256 If it fails, it returns nil." |
| 257 (if (featurep 'xft-fonts) | |
| 258 (if (x-font-xlfd-font-name-p font) | |
| 259 (x-make-font-italic-core font device) | |
| 260 (x-make-font-italic-xft font device)) | |
| 261 (x-make-font-italic-core font device))) | |
| 262 | |
| 263 (defun x-make-font-italic-xft (font &optional device) | |
| 264 (let ((pattern (fc-font-real-pattern | |
| 265 font (or device (default-x-device))))) | |
| 266 (if pattern | |
| 267 (let ((size (fc-pattern-get-size pattern 0)) | |
| 268 (copy (fc-copy-pattern-partial | |
| 269 pattern (list fc-font-name-property-family)))) | |
| 270 (when copy | |
| 271 (fc-pattern-del copy fc-font-name-property-slant) | |
| 272 (fc-pattern-del copy fc-font-name-property-style) | |
| 273 (let ((pattern-oblique (fc-pattern-duplicate copy)) | |
| 274 (pattern-italic (fc-pattern-duplicate copy))) | |
| 275 (fc-pattern-add pattern-oblique fc-font-name-property-slant | |
| 276 fc-font-name-slant-oblique) | |
| 277 (fc-pattern-add pattern-italic fc-font-name-property-slant | |
| 278 fc-font-name-slant-italic) | |
| 279 (let ((have-oblique (fc-try-font pattern-oblique device)) | |
| 280 (have-italic (fc-try-font pattern-italic device))) | |
| 281 (if try-oblique-before-italic-fonts | |
| 282 (if have-oblique | |
| 283 (progn | |
| 284 (if size | |
| 285 (fc-pattern-add pattern-oblique fc-font-name-property-size size)) | |
| 286 (fc-name-unparse pattern-oblique)) | |
| 287 (if have-italic | |
| 288 (progn | |
| 289 (if size | |
| 290 (fc-pattern-add pattern-italic fc-font-name-property-size size)) | |
| 291 (fc-name-unparse pattern-italic)))) | |
| 292 (if have-italic | |
| 293 (progn | |
| 294 (if size | |
| 295 (fc-pattern-add pattern-italic fc-font-name-property-size size)) | |
| 296 (fc-name-unparse pattern-italic)) | |
| 297 (if have-oblique | |
| 298 (progn | |
| 299 (if size | |
| 300 (fc-pattern-add pattern-oblique fc-font-name-property-size size)) | |
| 301 (fc-name-unparse pattern-oblique)))))))))))) | |
| 302 | |
| 303 (defun x-make-font-italic-core (font &optional device) | |
| 192 (if try-oblique-before-italic-fonts | 304 (if try-oblique-before-italic-fonts |
| 193 (or (try-font-name (x-frob-font-slant font "o") device) | 305 (or (try-font-name (x-frob-font-slant font "o") device) |
| 194 (try-font-name (x-frob-font-slant font "i") device)) | 306 (try-font-name (x-frob-font-slant font "i") device)) |
| 195 (or (try-font-name (x-frob-font-slant font "i") device) | 307 (or (try-font-name (x-frob-font-slant font "i") device) |
| 196 (try-font-name (x-frob-font-slant font "o") device)))) | 308 (try-font-name (x-frob-font-slant font "o") device)))) |
| 197 | 309 |
| 198 (defun x-make-font-unitalic (font &optional device) | 310 (defun x-make-font-unitalic (font &optional device) |
| 199 "Given an X font specification, this attempts to make a non-italic font. | 311 "Given an X font specification, this attempts to make a non-italic font. |
| 200 If it fails, it returns nil." | 312 If it fails, it returns nil." |
| 313 (if (featurep 'xft-fonts) | |
| 314 (if (x-font-xlfd-font-name-p font) | |
| 315 (x-make-font-unitalic-core font device) | |
| 316 (x-make-font-unitalic-xft font device)) | |
| 317 (x-make-font-unitalic-core font device))) | |
| 318 | |
| 319 (defun x-make-font-unitalic-xft (font &optional device) | |
| 320 (let ((pattern (fc-font-real-pattern | |
| 321 font (or device (default-x-device))))) | |
| 322 (when pattern | |
| 323 (fc-pattern-del pattern fc-font-name-property-slant) | |
| 324 (fc-pattern-add pattern fc-font-name-property-slant | |
| 325 fc-font-name-slant-roman) | |
| 326 (if (fc-try-font pattern device) | |
| 327 (fc-name-unparse pattern))))) | |
| 328 | |
| 329 (defun x-make-font-unitalic-core (font &optional device) | |
| 201 (try-font-name (x-frob-font-slant font "r") device)) | 330 (try-font-name (x-frob-font-slant font "r") device)) |
| 202 | 331 |
| 203 (defun x-make-font-bold-italic (font &optional device) | 332 (defun x-make-font-bold-italic (font &optional device) |
| 204 "Given an X font specification, this attempts to make a `bold-italic' font. | 333 "Given an X font specification, this attempts to make a `bold-italic' font. |
| 205 If it fails, it returns nil." | 334 If it fails, it returns nil." |
| 335 (if (featurep 'xft-fonts) | |
| 336 (if (x-font-xlfd-font-name-p font) | |
| 337 (x-make-font-bold-italic-core font device) | |
| 338 (x-make-font-bold-italic-xft font device)) | |
| 339 (x-make-font-bold-italic-core font device))) | |
| 340 | |
| 341 (defun x-make-font-bold-italic-xft (font &optional device) | |
| 342 (let ((italic (x-make-font-italic-xft font device))) | |
| 343 (if italic | |
| 344 (x-make-font-bold-xft italic device)))) | |
| 345 | |
| 346 (defun x-make-font-bold-italic-core (font &optional device) | |
| 206 ;; This is haired up to avoid loading the "intermediate" fonts. | 347 ;; This is haired up to avoid loading the "intermediate" fonts. |
| 207 (if try-oblique-before-italic-fonts | 348 (if try-oblique-before-italic-fonts |
| 208 (or (try-font-name | 349 (or (try-font-name |
| 209 (x-frob-font-slant (x-frob-font-weight font "bold") "o") device) | 350 (x-frob-font-slant (x-frob-font-weight font "bold") "o") device) |
| 210 (try-font-name | 351 (try-font-name |
| 234 "Return the nominal size of the given font. | 375 "Return the nominal size of the given font. |
| 235 This is done by parsing its name, so it's likely to lose. | 376 This is done by parsing its name, so it's likely to lose. |
| 236 X fonts can be specified (by the user) in either pixels or 10ths of points, | 377 X fonts can be specified (by the user) in either pixels or 10ths of points, |
| 237 and this returns the first one it finds, so you have to decide which units | 378 and this returns the first one it finds, so you have to decide which units |
| 238 the returned value is measured in yourself..." | 379 the returned value is measured in yourself..." |
| 380 (if (featurep 'xft-fonts) | |
| 381 (if (x-font-xlfd-font-name-p font) | |
| 382 (x-font-size-core font) | |
| 383 (x-font-size-xft font)) | |
| 384 (x-font-size-core font))) | |
| 385 | |
| 386 ;; this is unbelievable &*@# | |
| 387 (defun x-font-size-xft (font) | |
| 388 (let ((pattern (fc-font-real-pattern | |
| 389 font (default-x-device)))) | |
| 390 (when pattern | |
| 391 (let ((pixelsize (fc-pattern-get-pixelsize pattern 0))) | |
| 392 (if (floatp pixelsize) (round pixelsize)))))) | |
| 393 | |
| 394 (defun x-font-size-core (font) | |
| 239 (if (font-instance-p font) (setq font (font-instance-name font))) | 395 (if (font-instance-p font) (setq font (font-instance-name font))) |
| 240 (cond ((or (string-match x-font-regexp font) | 396 (cond ((or (string-match x-font-regexp font) |
| 241 (string-match x-font-regexp-head-2 font)) | 397 (string-match x-font-regexp-head-2 font)) |
| 242 (string-to-int (substring font (match-beginning 6) (match-end 6)))) | 398 (string-to-int (substring font (match-beginning 6) (match-end 6)))) |
| 243 ((or (string-match x-font-regexp-pixel font) | 399 ((or (string-match x-font-regexp-pixel font) |
| 352 (defun x-find-smaller-font (font &optional device) | 508 (defun x-find-smaller-font (font &optional device) |
| 353 "Load a new, slightly smaller version of the given font (or font name). | 509 "Load a new, slightly smaller version of the given font (or font name). |
| 354 Returns the font if it succeeds, nil otherwise. | 510 Returns the font if it succeeds, nil otherwise. |
| 355 If scalable fonts are available, this returns a font which is 1 point smaller. | 511 If scalable fonts are available, this returns a font which is 1 point smaller. |
| 356 Otherwise, it returns the next smaller version of this font that is defined." | 512 Otherwise, it returns the next smaller version of this font that is defined." |
| 513 (if (featurep 'xft-fonts) | |
| 514 (if (x-font-xlfd-font-name-p font) | |
| 515 (x-find-smaller-font-core font device) | |
| 516 (x-find-smaller-font-xft font device)) | |
| 517 (x-find-smaller-font-core font device))) | |
| 518 | |
| 519 (defun x-find-xft-font-of-size (font new-size-proc &optional device) | |
| 520 (let* ((pattern (fc-font-real-pattern | |
| 521 font (or device (default-x-device))))) | |
| 522 (when pattern | |
| 523 (let ((size (fc-pattern-get-size pattern 0))) | |
| 524 (if (floatp size) | |
| 525 (let ((copy (fc-pattern-duplicate pattern))) | |
| 526 (fc-pattern-del copy fc-font-name-property-size) | |
| 527 (fc-pattern-add copy fc-font-name-property-size | |
| 528 (funcall new-size-proc size)) | |
| 529 (if (fc-try-font font device) | |
| 530 (fc-name-unparse copy)))))))) | |
| 531 | |
| 532 (defun x-find-smaller-font-xft (font &optional device) | |
| 533 (x-find-xft-font-of-size font '(lambda (old-size) (- old-size 1.0)) device)) | |
| 534 | |
| 535 (defun x-find-smaller-font-core (font &optional device) | |
| 357 (x-frob-font-size font nil device)) | 536 (x-frob-font-size font nil device)) |
| 358 | 537 |
| 359 (defun x-find-larger-font (font &optional device) | 538 (defun x-find-larger-font (font &optional device) |
| 360 "Load a new, slightly larger version of the given font (or font name). | 539 "Load a new, slightly larger version of the given font (or font name). |
| 361 Returns the font if it succeeds, nil otherwise. | 540 Returns the font if it succeeds, nil otherwise. |
| 362 If scalable fonts are available, this returns a font which is 1 point larger. | 541 If scalable fonts are available, this returns a font which is 1 point larger. |
| 363 Otherwise, it returns the next larger version of this font that is defined." | 542 Otherwise, it returns the next larger version of this font that is defined." |
| 543 (if (featurep 'xft-fonts) | |
| 544 (if (x-font-xlfd-font-name-p font) | |
| 545 (x-find-larger-font-core font device) | |
| 546 (x-find-larger-font-xft font device)) | |
| 547 (x-find-larger-font-core font device))) | |
| 548 | |
| 549 (defun x-find-larger-font-xft (font &optional device) | |
| 550 (x-find-xft-font-of-size font '(lambda (old-size) (+ old-size 1.0)) device)) | |
| 551 | |
| 552 (defun x-find-larger-font-core (font &optional device) | |
| 364 (x-frob-font-size font t device)) | 553 (x-frob-font-size font t device)) |
| 365 | 554 |
| 366 (defalias 'x-make-face-bold 'make-face-bold) | 555 (defalias 'x-make-face-bold 'make-face-bold) |
| 367 (defalias 'x-make-face-italic 'make-face-italic) | 556 (defalias 'x-make-face-italic 'make-face-italic) |
| 368 (defalias 'x-make-face-bold-italic 'make-face-bold-italic) | 557 (defalias 'x-make-face-bold-italic 'make-face-bold-italic) |