Mercurial > hg > xemacs-beta
annotate lisp/x-font-menu.el @ 5887:6eca500211f4
Prototype for X509_check_host() has changed, detect this in configure.ac
ChangeLog addition:
2015-04-09 Aidan Kehoe <kehoea@parhasard.net>
* configure.ac:
If X509_check_host() is available, check the number of arguments
it takes. Don't use it if it takes any number of arguments other
than five. Also don't use it if <openssl/x509v3.h> does not
declare it, since if that is so there is no portable way to tell
how many arguments it should take, and so we would end up smashing
the stack.
* configure: Regenerate.
src/ChangeLog addition:
2015-04-09 Aidan Kehoe <kehoea@parhasard.net>
* tls.c:
#include <openssl/x509v3.h> for its prototype for
X509_check_host().
* tls.c (tls_open):
Pass the new fifth argument to X509_check_host().
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Thu, 09 Apr 2015 14:27:02 +0100 |
| parents | bbe4146603db |
| children |
| rev | line source |
|---|---|
| 2297 | 1 ;;; x-font-menu.el --- Managing menus of X fonts. |
| 428 | 2 |
| 3 ;; Copyright (C) 1994 Free Software Foundation, Inc. | |
| 4 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. | |
| 5 ;; Copyright (C) 1997 Sun Microsystems | |
| 6 | |
| 7 ;; Author: Jamie Zawinski <jwz@jwz.org> | |
| 8 ;; Restructured by: Jonathan Stigelman <Stig@hackvan.com> | |
| 9 ;; Mule-ized by: Martin Buchholz | |
| 10 ;; More restructuring for MS-Windows by Andy Piper <andy@xemacs.org> | |
| 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:
4783
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:
4783
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:
4783
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:
4783
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:
4783
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:
4783
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:
4783
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:
4783
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:
4783
diff
changeset
|
25 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 428 | 26 ;;; Code: |
| 27 | |
| 28 ;; #### - implement these... | |
| 29 ;; | |
| 30 ;;; (defvar font-menu-ignore-proportional-fonts nil | |
| 31 ;;; "*If non-nil, then the font menu will only show fixed-width fonts.") | |
| 32 | |
| 33 (require 'font-menu) | |
| 34 | |
| 3094 | 35 (when (featurep 'xft-fonts) |
| 36 (require 'fontconfig)) | |
| 37 | |
| 502 | 38 (globally-declare-boundp |
| 39 '(x-font-regexp | |
| 2297 | 40 x-font-regexp-foundry-and-family |
| 41 x-font-regexp-spacing)) | |
| 502 | 42 |
| 4103 | 43 (globally-declare-boundp |
| 44 '(charset-registries | |
| 45 fc-find-available-font-families | |
| 46 fc-find-available-weights-for-family | |
| 47 fc-font-match | |
| 48 fc-font-slant-translate-from-string | |
| 49 fc-font-slant-translate-to-string | |
| 50 fc-font-weight-translate-from-string | |
| 51 fc-font-weight-translate-to-string | |
| 52 fc-name-parse | |
| 53 fc-name-unparse | |
| 54 fc-pattern-add-family | |
| 55 fc-pattern-add-size | |
| 56 fc-pattern-add-slant | |
| 57 fc-pattern-add-weight | |
| 58 fc-pattern-get-family | |
| 59 fc-pattern-get-size | |
| 60 fc-pattern-get-slant | |
| 61 fc-pattern-get-successp | |
| 62 fc-pattern-get-weight | |
| 63 make-fc-pattern | |
| 64 xlfd-font-name-p)) | |
| 502 | 65 |
| 428 | 66 (defvar x-font-menu-registry-encoding nil |
| 67 "Registry and encoding to use with font menu fonts.") | |
| 68 | |
| 69 (defvar x-fonts-menu-junk-families | |
| 444 | 70 (mapconcat |
| 71 #'identity | |
| 72 '("cursor" "glyph" "symbol" ; Obvious losers. | |
| 73 "\\`Ax...\\'" ; FrameMaker fonts - there are just way too | |
| 428 | 74 ; many of these, and there is a different |
| 75 ; font family for each font face! Losers. | |
| 76 ; "Axcor" -> "Applix Courier Roman", | |
| 77 ; "Axcob" -> "Applix Courier Bold", etc. | |
| 444 | 78 ) |
| 79 "\\|") | |
| 2297 | 80 "Regexp matching font families which should not be menu-selectable. |
| 81 E.g. cursor fonts.") | |
| 428 | 82 |
| 83 (defun hack-font-truename (fn) | |
| 2297 | 84 ;; #### Are "font sets" XFontSets? |
| 85 ;; #### Is this useful if not configure'd --with-xfs? | |
| 86 ;; #### This is duplicated in gtk-font-menu.el. | |
| 87 "Filter the output of `font-instance-truename' to deal with font sets." | |
|
5882
bbe4146603db
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp
Aidan Kehoe <kehoea@parhasard.net>
parents:
5652
diff
changeset
|
88 (let ((font-instance-truename (font-instance-truename fn))) |
|
bbe4146603db
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp
Aidan Kehoe <kehoea@parhasard.net>
parents:
5652
diff
changeset
|
89 (if (find ?, font-instance-truename) |
|
bbe4146603db
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp
Aidan Kehoe <kehoea@parhasard.net>
parents:
5652
diff
changeset
|
90 (let ((fpnt (nth 8 (split-string-by-char (font-instance-name fn) ?-))) |
|
bbe4146603db
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp
Aidan Kehoe <kehoea@parhasard.net>
parents:
5652
diff
changeset
|
91 (flist (split-string-by-char font-instance-truename ?,)) |
|
bbe4146603db
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp
Aidan Kehoe <kehoea@parhasard.net>
parents:
5652
diff
changeset
|
92 ret) |
|
bbe4146603db
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp
Aidan Kehoe <kehoea@parhasard.net>
parents:
5652
diff
changeset
|
93 (while flist |
|
bbe4146603db
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp
Aidan Kehoe <kehoea@parhasard.net>
parents:
5652
diff
changeset
|
94 (if (equal fpnt (nth 8 (split-string-by-char (car flist) ?-))) |
|
bbe4146603db
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp
Aidan Kehoe <kehoea@parhasard.net>
parents:
5652
diff
changeset
|
95 (progn (setq ret (car flist)) (setq flist nil)) |
|
bbe4146603db
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp
Aidan Kehoe <kehoea@parhasard.net>
parents:
5652
diff
changeset
|
96 (setq flist (cdr flist)))) |
|
bbe4146603db
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp
Aidan Kehoe <kehoea@parhasard.net>
parents:
5652
diff
changeset
|
97 ret) |
|
bbe4146603db
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp
Aidan Kehoe <kehoea@parhasard.net>
parents:
5652
diff
changeset
|
98 font-instance-truename))) |
| 428 | 99 |
| 100 (defvar x-font-regexp-ascii nil | |
| 101 "This is used to filter out font families that can't display ASCII text. | |
| 102 It must be set at run-time.") | |
| 103 | |
| 3094 | 104 ;; #### move these to font-menu.el, and maybe make them defcustoms |
| 105 (defvar font-menu-common-sizes | |
| 106 '(60 80 100 110 120 130 140 150 160 170 180 200 220 240 300 360) | |
| 107 "List of commonly desired font sizes in decipoints.") | |
| 108 | |
| 428 | 109 ;;;###autoload |
| 110 (defun x-reset-device-font-menus (device &optional debug) | |
| 3094 | 111 (if (featurep 'xft-fonts) |
| 112 (x-reset-device-font-menus-xft device debug) | |
| 113 (x-reset-device-font-menus-core device debug))) | |
| 114 | |
| 115 (defun fc-make-font-menu-entry (family) | |
| 116 (let ((weights (fc-find-available-weights-for-family family))) | |
| 117 (vector | |
| 118 family | |
| 119 (mapcar | |
|
4783
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
120 (lambda (weight-symbol) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
121 (let ((pair (assoc weight-symbol |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
122 '((:light "Light") |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
123 (:medium "Medium") |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
124 (:demibold "Demibold") |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
125 (:bold "Bold") |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
126 (:black "Black"))))) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
127 (if pair (cadr pair)))) |
| 3094 | 128 weights) |
| 129 '(0) | |
| 130 nil))) | |
| 131 | |
| 132 (defun x-reset-device-font-menus-xft (device &optional debug) | |
| 133 (let* ((families-1 (fc-find-available-font-families device)) | |
| 134 (families (delete-if (lambda (x) | |
| 135 (string-match x-fonts-menu-junk-families x)) | |
| 136 (sort families-1 'string-lessp))) | |
| 137 (data | |
| 138 (vector | |
| 139 (mapcar 'fc-make-font-menu-entry families) | |
| 140 (mapcar | |
|
4783
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
141 (lambda (family) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
142 (vector family `(font-menu-set-font ,family nil nil) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
143 :style 'radio :active nil :selected nil)) |
| 3094 | 144 families) |
| 145 (mapcar | |
|
4783
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
146 (lambda (size) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
147 (vector |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
148 (number-to-string size) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
149 `(font-menu-set-font nil nil ,size) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
150 :style 'radio :active nil :selected nil)) |
| 3094 | 151 ;; common size list in decipoints, fontconfig wants points |
| 152 (mapcar (lambda (x) (/ x 10)) font-menu-common-sizes)) | |
| 153 (mapcar | |
|
4783
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
154 (lambda (weight) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
155 (vector |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
156 weight |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
157 `(font-menu-set-font nil ,weight nil) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
158 :style 'radio :active nil :selected nil)) |
| 3094 | 159 '("Light" "Medium" "Demibold" "Bold" "Black")))) |
| 160 ;; get or initialize the entry for device | |
| 161 (dev-cache (or (assq device device-fonts-cache) | |
| 162 (car (push (list device) device-fonts-cache))))) | |
| 163 ;; update the device-fonts-cache entry for device in place | |
| 164 (setcdr dev-cache data) | |
| 165 data)) | |
| 166 | |
| 167 (defun x-reset-device-font-menus-core (device &optional debug) | |
| 428 | 168 "Generates the `Font', `Size', and `Weight' submenus for the Options menu. |
| 169 This is run the first time that a font-menu is needed for each device. | |
| 170 If you don't like the lazy invocation of this function, you can add it to | |
| 171 `create-device-hook' and that will make the font menus respond more quickly | |
| 172 when they are selected for the first time. If you add fonts to your system, | |
| 173 or if you change your font path, you can call this to re-initialize the menus." | |
| 174 ;; by Stig@hackvan.com | |
| 175 ;; #### - this should implement a `menus-only' option, which would | |
| 2527 | 176 ;; recalculate the menus from the cache w/o having to do font-list again. |
| 428 | 177 (unless x-font-regexp-ascii |
| 3917 | 178 (setq x-font-regexp-ascii |
| 179 (if (fboundp 'charset-registries) | |
| 180 (elt (charset-registries 'ascii) 0) | |
| 181 "iso8859-1"))) | |
| 428 | 182 (setq x-font-menu-registry-encoding |
| 183 (if (featurep 'mule) "*-*" "iso8859-1")) | |
| 184 (let ((case-fold-search t) | |
| 185 family size weight entry monospaced-p | |
| 186 dev-cache cache families sizes weights) | |
| 187 (dolist (name (cond ((null debug) ; debugging kludge | |
| 2527 | 188 (font-list "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device |
| 1701 | 189 font-menu-max-number)) |
|
5882
bbe4146603db
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp
Aidan Kehoe <kehoea@parhasard.net>
parents:
5652
diff
changeset
|
190 ((stringp debug) (split-string-by-char debug ?\n)) |
| 428 | 191 (t debug))) |
| 192 (when (and (string-match x-font-regexp-ascii name) | |
| 193 (string-match x-font-regexp name)) | |
| 194 (setq weight (capitalize (match-string 1 name)) | |
| 195 size (string-to-int (match-string 6 name))) | |
| 196 (or (string-match x-font-regexp-foundry-and-family name) | |
| 197 (error "internal error")) | |
| 198 (setq family (capitalize (match-string 1 name))) | |
| 199 (or (string-match x-font-regexp-spacing name) | |
| 200 (error "internal error")) | |
| 201 (setq monospaced-p (string= "m" (match-string 1 name))) | |
| 202 (unless (string-match x-fonts-menu-junk-families family) | |
| 203 (setq entry (or (vassoc family cache) | |
| 204 (car (setq cache | |
| 205 (cons (vector family nil nil t) | |
| 206 cache))))) | |
| 207 (or (member family families) (push family families)) | |
| 208 (or (member weight weights) (push weight weights)) | |
| 209 (or (member size sizes) (push size sizes)) | |
| 210 (or (member weight (aref entry 1)) (push weight (aref entry 1))) | |
| 211 (or (member size (aref entry 2)) (push size (aref entry 2))) | |
| 212 (aset entry 3 (and (aref entry 3) monospaced-p))))) | |
| 213 ;; | |
| 214 ;; Hack scalable fonts. | |
| 215 ;; Some fonts come only in scalable versions (the only size is 0) | |
| 216 ;; and some fonts come in both scalable and non-scalable versions | |
| 217 ;; (one size is 0). If there are any scalable fonts at all, make | |
| 218 ;; sure that the union of all point sizes contains at least some | |
| 219 ;; common sizes - it's possible that some sensible sizes might end | |
| 220 ;; up not getting mentioned explicitly. | |
| 221 ;; | |
| 222 (if (member 0 sizes) | |
| 3094 | 223 (let ((common font-menu-common-sizes)) |
| 428 | 224 (while common |
| 225 (or;;(member (car common) sizes) ; not enough slack | |
| 226 (let ((rest sizes) | |
| 227 (done nil)) | |
| 228 (while (and (not done) rest) | |
| 229 (if (and (> (car common) (- (car rest) 5)) | |
| 230 (< (car common) (+ (car rest) 5))) | |
| 231 (setq done t)) | |
| 232 (setq rest (cdr rest))) | |
| 233 done) | |
| 234 (setq sizes (cons (car common) sizes))) | |
| 235 (setq common (cdr common))) | |
|
5652
cc6f0266bc36
Avoid #'delq in core Lisp, for the sake of style, a very slightly smaller binary
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
236 (setq sizes (delete* 0 sizes)))) |
| 428 | 237 |
| 238 (setq families (sort families 'string-lessp) | |
| 239 weights (sort weights 'string-lessp) | |
| 240 sizes (sort sizes '<)) | |
| 241 | |
| 242 (dolist (entry cache) | |
| 243 (aset entry 1 (sort (aref entry 1) 'string-lessp)) | |
| 244 (aset entry 2 (sort (aref entry 2) '<))) | |
| 245 | |
| 246 (setq dev-cache (assq device device-fonts-cache)) | |
| 247 (or dev-cache | |
| 248 (setq dev-cache (car (push (list device) device-fonts-cache)))) | |
| 249 (setcdr | |
| 250 dev-cache | |
| 251 (vector | |
| 252 cache | |
| 253 (mapcar (lambda (x) | |
|
5344
2a54dfbe434f
Don't quote keywords, they've been self-quoting for well over a decade.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4783
diff
changeset
|
254 (vector x |
| 428 | 255 (list 'font-menu-set-font x nil nil) |
|
5344
2a54dfbe434f
Don't quote keywords, they've been self-quoting for well over a decade.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4783
diff
changeset
|
256 :style 'radio :active nil :selected nil)) |
| 428 | 257 families) |
| 258 (mapcar (lambda (x) | |
| 259 (vector (if (/= 0 (% x 10)) | |
| 1104 | 260 (number-to-string (/ x 10.0)) |
| 261 (number-to-string (/ x 10))) | |
| 428 | 262 (list 'font-menu-set-font nil nil x) |
|
5344
2a54dfbe434f
Don't quote keywords, they've been self-quoting for well over a decade.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4783
diff
changeset
|
263 :style 'radio :active nil :selected nil)) |
| 428 | 264 sizes) |
| 265 (mapcar (lambda (x) | |
| 266 (vector x | |
| 267 (list 'font-menu-set-font nil x nil) | |
|
5344
2a54dfbe434f
Don't quote keywords, they've been self-quoting for well over a decade.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4783
diff
changeset
|
268 :style 'radio :active nil :selected nil)) |
| 428 | 269 weights))) |
| 270 (cdr dev-cache))) | |
| 271 | |
| 272 ;; Extract font information from a face. We examine both the | |
| 273 ;; user-specified font name and the canonical (`true') font name. | |
| 274 ;; These can appear to have totally different properties. | |
| 275 ;; For examples, see the prolog above. | |
| 276 | |
| 277 ;; We use the user-specified one if possible, else use the truename. | |
| 278 ;; If the user didn't specify one (with "-dt-*-*", for example) | |
| 279 ;; get the truename and use the possibly suboptimal data from that. | |
| 280 ;;;###autoload | |
| 523 | 281 (defun x-font-menu-font-data (face dcache) |
| 3094 | 282 (let* ((case-fold-search t) |
| 283 (domain (if font-menu-this-frame-only-p | |
| 284 (selected-frame) | |
| 285 (selected-device))) | |
| 286 (name (font-instance-name (face-font-instance face domain)))) | |
| 287 (if (featurep 'xft-fonts) | |
| 288 (if (xlfd-font-name-p name) | |
| 289 ;; #### this call to x-font-menu-font-data-core originally | |
| 290 ;; had 4 args, and that's probably the right way to go | |
| 291 (x-font-menu-font-data-core face dcache) | |
| 3394 | 292 (x-font-menu-font-data-xft face dcache name (selected-device))) |
| 3094 | 293 ;; #### this one, too |
| 294 (x-font-menu-font-data-core face dcache)))) | |
| 295 | |
| 296 (defun x-font-menu-font-data-xft (face dcache name domain) | |
| 3360 | 297 ;; DOMAIN is expected to be a device. |
| 3094 | 298 (let* ((truename (font-instance-truename |
| 299 (face-font-instance face domain | |
| 300 (if (featurep 'mule) 'ascii)))) | |
| 301 entry) | |
| 302 (if (xlfd-font-name-p truename) | |
| 303 (progn | |
| 304 nil) | |
| 305 (progn | |
| 3360 | 306 (let* ((pattern (fc-font-match domain (fc-name-parse name))) |
| 3094 | 307 (family (and pattern |
| 308 (fc-pattern-get-family pattern 0)))) | |
| 309 (if (fc-pattern-get-successp family) | |
| 310 (setq entry (vassoc family (aref dcache 0)))) | |
| 311 (if (null entry) | |
| 312 (make-vector 5 nil) | |
| 313 (let ((weight (fc-pattern-get-weight pattern 0)) | |
| 314 (size (fc-pattern-get-size pattern 0)) | |
| 315 (slant (fc-pattern-get-slant pattern 0))) | |
| 316 (vector | |
| 317 entry | |
| 318 (if (fc-pattern-get-successp family) | |
| 319 family) | |
| 320 (if (fc-pattern-get-successp size) | |
| 321 size) | |
| 322 (if (fc-pattern-get-successp weight) | |
| 323 (fc-font-weight-translate-to-string weight)) | |
| 324 (if (fc-pattern-get-successp slant) | |
| 325 (fc-font-slant-translate-to-string slant)))))))))) | |
| 326 | |
| 327 (defun x-font-menu-font-data-core (face dcache) | |
| 428 | 328 (let* ((case-fold-search t) |
| 329 (domain (if font-menu-this-frame-only-p | |
| 330 (selected-frame) | |
| 331 (selected-device))) | |
| 332 (name (font-instance-name (face-font-instance face domain))) | |
| 333 (truename (font-instance-truename | |
| 334 (face-font-instance face domain | |
| 335 (if (featurep 'mule) 'ascii)))) | |
| 336 family size weight entry slant) | |
| 337 (when (string-match x-font-regexp-foundry-and-family name) | |
| 338 (setq family (capitalize (match-string 1 name))) | |
| 339 (setq entry (vassoc family (aref dcache 0)))) | |
| 340 (when (and (null entry) | |
| 341 (string-match x-font-regexp-foundry-and-family truename)) | |
| 342 (setq family (capitalize (match-string 1 truename))) | |
| 343 (setq entry (vassoc family (aref dcache 0)))) | |
| 523 | 344 |
| 345 (if (null entry) | |
| 346 (make-vector 5 nil) | |
| 347 | |
| 348 (when (string-match x-font-regexp name) | |
| 349 (setq weight (capitalize (match-string 1 name))) | |
| 350 (setq size (string-to-int (match-string 6 name)))) | |
| 428 | 351 |
| 523 | 352 (when (string-match x-font-regexp truename) |
| 353 (when (not (member weight (aref entry 1))) | |
| 354 (setq weight (capitalize (match-string 1 truename)))) | |
| 355 (when (not (member size (aref entry 2))) | |
| 356 (setq size (string-to-int (match-string 6 truename)))) | |
| 357 (setq slant (capitalize (match-string 2 truename)))) | |
| 428 | 358 |
| 523 | 359 (vector entry family size weight slant)))) |
| 428 | 360 |
| 361 (defun x-font-menu-load-font (family weight size slant resolution) | |
| 3094 | 362 (if (featurep 'xft-fonts) |
| 363 (x-font-menu-load-font-xft family weight size slant resolution) | |
| 364 (x-font-menu-load-font-core family weight size slant resolution))) | |
| 365 | |
| 366 (defun x-font-menu-load-font-xft (family weight size slant resolution) | |
| 367 (let ((pattern (make-fc-pattern))) | |
| 3354 | 368 (fc-pattern-add-family pattern family) |
| 3094 | 369 (if weight |
| 3354 | 370 (fc-pattern-add-weight pattern |
| 371 (fc-font-weight-translate-from-string weight))) | |
| 3094 | 372 (if size |
| 3354 | 373 (fc-pattern-add-size pattern size)) |
| 3094 | 374 (if slant |
| 3354 | 375 (fc-pattern-add-slant pattern |
| 376 (fc-font-slant-translate-from-string slant))) | |
| 3094 | 377 (make-font-instance (fc-name-unparse pattern)))) |
| 378 | |
| 379 (defun x-font-menu-load-font-core (family weight size slant resolution) | |
| 428 | 380 "Try to load a font with the requested properties. |
| 381 The weight, slant and resolution are only hints." | |
| 382 (when (integerp size) (setq size (int-to-string size))) | |
| 383 (let (font) | |
| 384 (catch 'got-font | |
| 385 (dolist (weight (list weight "*")) | |
| 386 (dolist (slant | |
| 387 (cond ((string-equal slant "O") '("O" "I" "*")) | |
| 388 ((string-equal slant "I") '("I" "O" "*")) | |
| 389 ((string-equal slant "*") '("*")) | |
| 390 (t (list slant "*")))) | |
| 391 (dolist (resolution | |
| 392 (if (string-equal resolution "*-*") | |
| 393 (list resolution) | |
| 394 (list resolution "*-*"))) | |
| 395 (when (setq font | |
| 396 (make-font-instance | |
| 397 (concat "-*-" family "-" weight "-" slant "-*-*-*-" | |
| 398 size "-" resolution "-*-*-" | |
| 399 x-font-menu-registry-encoding) | |
| 400 nil t)) | |
| 401 (throw 'got-font font)))))))) | |
| 402 | |
| 403 (provide 'x-font-menu) | |
| 404 | |
| 405 ;;; x-font-menu.el ends here |