Mercurial > hg > xemacs-beta

comparison lisp/msw-faces.el @ 371:cc15677e0335 r21-2b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2b1
author cvs
date Mon, 13 Aug 2007 11:03:08 +0200
parents 19dcec799385
children 6240c7796c7a
comparison
equal deleted inserted replaced
370:bd866891f083 371:cc15677e0335
24 ;; You should have received a copy of the GNU General Public License 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 25 ;; along with XEmacs; see the file COPYING. If not, write to the
26 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 26 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
27 ;; Boston, MA 02111-1307, USA. 27 ;; Boston, MA 02111-1307, USA.
28 28
29 ;; This file does the magic to parse mswindows font names, and make sure that 29 ;; This file does the magic to parse mswindows font names, and make sure that the
30 ;; the default and modeline attributes of new frames are specified enough. 30 ;; default and modeline attributes of new frames are specified enough.
31 31
32 ;;; Force creation of the default face font so that if it fails we get an 32 ;;; ensure that the default face has some reasonable fallbacks if nothing
33 ;;; error now instead of a crash at frame creation. 33 ;;; else is specified.
34 (defun mswindows-init-device-faces (device) 34 (defun mswindows-init-device-faces (device)
35 (unless (face-font-instance 'default device) 35 (set-face-font 'default
36 (error "Can't find a suitable default font"))) 36 '((mswindows default) . "Courier New:Regular:10") 'global)
37 )
37 38
38 39
39 (defun mswindows-init-frame-faces (frame) 40 (defun mswindows-init-frame-faces (frame)
40 ) 41 )
41 42
45 ;;; mswindows fonts look like: 46 ;;; mswindows fonts look like:
46 ;;; fontname[:[weight][ style][:pointsize[:effects]]][:charset] 47 ;;; fontname[:[weight][ style][:pointsize[:effects]]][:charset]
47 ;;; A minimal mswindows font spec looks like: 48 ;;; A minimal mswindows font spec looks like:
48 ;;; Courier New 49 ;;; Courier New
49 ;;; A maximal mswindows font spec looks like: 50 ;;; A maximal mswindows font spec looks like:
50 ;;; Courier New:Bold Italic:10:underline strikeout:Western 51 ;;; Courier New:Bold Italic:10:underline strikeout:western
51 ;;; Missing parts of the font spec should be filled in with these values: 52 ;;; Missing parts of the font spec should be filled in with these values:
52 ;;; Courier New:Regular:10::Western 53 ;;; Courier New:Normal:10::western
53 (defun mswindows-font-canonicalize-name (font) 54 (defun mswindows-font-canonicalize-name (font)
54 "Given a mswindows font or font name, this returns its name in 55 "Given a mswindows font or font specification, this returns its
55 canonical form." 56 specification in canonical form."
56 (if (or (font-instance-p font) 57 (if (or (font-instance-p font)
57 (stringp font)) 58 (stringp font))
58 (let ((name (if (font-instance-p font) 59 (let ((name (if (font-instance-p font)
59 (font-instance-name font) 60 (font-instance-name font)
60 font))) 61 font)))
61 (cond ((string-match 62 (cond ((string-match
62 "^[a-zA-Z ]+:[a-zA-Z ]*:[0-9]+:[a-zA-Z ]*:[a-zA-Z 0-9]*$" 63 "^[a-zA-Z ]+:[a-zA-Z ]*:[0-9]+:[a-zA-Z ]*:[a-zA-Z 0-9]*$"
63 name) name) 64 name) name)
64 ((string-match "^[a-zA-Z ]+:[a-zA-Z ]*:[0-9]+:[a-zA-Z ]*$" 65 ((string-match "^[a-zA-Z ]+:[a-zA-Z ]*:[0-9]+:[a-zA-Z ]*$"
65 name) (concat name ":Western")) 66 name) (concat name ":western"))
66 ((string-match "^[a-zA-Z ]+:[a-zA-Z ]*:[0-9]+$" name) 67 ((string-match "^[a-zA-Z ]+:[a-zA-Z ]*:[0-9]+$" name)
67 (concat name "::Western")) 68 (concat name "::western"))
68 ((string-match "^[a-zA-Z ]+:[a-zA-Z ]*$" name) 69 ((string-match "^[a-zA-Z ]+:[a-zA-Z ]*$" name)
69 (concat name ":10::Western")) 70 (concat name ":10::western"))
70 ((string-match "^[a-zA-Z ]+$" name) 71 ((string-match "^[a-zA-Z ]+$" name)
71 (concat name ":Regular:10::Western")) 72 (concat name ":Normal:10::western"))
72 (t "Courier New:Regular:10::Western"))))) 73 (t "Courier New:Normal:10::western")))))
73 74
74 (defun mswindows-make-font-bold (font &optional device) 75 (defun mswindows-make-font-bold (font &optional device)
75 "Given a mswindows font specification, this attempts to make a bold font. 76 "Given a mswindows font specification, this attempts to make a bold font.
76 If it fails, it returns nil." 77 If it fails, it returns nil."
77 (if (font-instance-p font) 78 (if (font-instance-p font)
85 ; Hack! on mswindows, bold fonts (even monospaced) are often wider than the 86 ; Hack! on mswindows, bold fonts (even monospaced) are often wider than the
86 ; equivalent non-bold font. Making the bold font one point smaller usually 87 ; equivalent non-bold font. Making the bold font one point smaller usually
87 ; makes it the same width (maybe at the expense of making it one pixel shorter) 88 ; makes it the same width (maybe at the expense of making it one pixel shorter)
88 (if (font-instance-p newfont) 89 (if (font-instance-p newfont)
89 (if (> (font-instance-width newfont) oldwidth) 90 (if (> (font-instance-width newfont) oldwidth)
90 (mswindows-find-smaller-font newfont device) 91 (mswindows-find-smaller-font newfont)
91 newfont)))))) 92 newfont))))))
92 93
93 (defun mswindows-make-font-unbold (font &optional device) 94 (defun mswindows-make-font-unbold (font &optional device)
94 "Given a mswindows font specification, this attempts to make a non-bold font. 95 "Given a mswindows font specification, this attempts to make a non-bold font.
95 If it fails, it returns nil." 96 If it fails, it returns nil."
96 (if (font-instance-p font) 97 (if (font-instance-p font)
97 (let ((name (mswindows-font-canonicalize-name font))) 98 (let ((name (mswindows-font-canonicalize-name font)))
98 (string-match "^[a-zA-Z ]+:\\([a-zA-Z ]*\\):" name) 99 (string-match "^[a-zA-Z ]+:\\([a-zA-Z ]*\\):" name)
99 (make-font-instance (concat 100 (make-font-instance (concat
100 (substring name 0 (match-beginning 1)) 101 (substring name 0 (match-beginning 1))
101 "Regular" (substring name (match-end 1))) 102 "Normal" (substring name (match-end 1)))
102 device t)))) 103 device t))))
103 104
104 (defun mswindows-make-font-italic (font &optional device) 105 (defun mswindows-make-font-italic (font &optional device)
105 "Given a mswindows font specification, this attempts to make an `italic' 106 "Given a mswindows font specification, this attempts to make an `italic'
106 font. If it fails, it returns nil." 107 font. If it fails, it returns nil."
118 (if (font-instance-p font) 119 (if (font-instance-p font)
119 (let ((name (mswindows-font-canonicalize-name font))) 120 (let ((name (mswindows-font-canonicalize-name font)))
120 (string-match "^[a-zA-Z ]+:\\([a-zA-Z ]*\\):" name) 121 (string-match "^[a-zA-Z ]+:\\([a-zA-Z ]*\\):" name)
121 (make-font-instance (concat 122 (make-font-instance (concat
122 (substring name 0 (match-beginning 1)) 123 (substring name 0 (match-beginning 1))
123 "Regular" (substring name (match-end 1))) 124 "Normal" (substring name (match-end 1)))
124 device t)))) 125 device t))))
125 126
126 (defun mswindows-make-font-bold-italic (font &optional device) 127 (defun mswindows-make-font-bold-italic (font &optional device)
127 "Given a mswindows font specification, this attempts to make a `bold-italic' 128 "Given a mswindows font specification, this attempts to make a `bold-italic'
128 font. If it fails, it returns nil." 129 font. If it fails, it returns nil."
137 ; Hack! on mswindows, bold fonts (even monospaced) are often wider than the 138 ; Hack! on mswindows, bold fonts (even monospaced) are often wider than the
138 ; equivalent non-bold font. Making the bold font one point smaller usually 139 ; equivalent non-bold font. Making the bold font one point smaller usually
139 ; makes it the same width (maybe at the expense of making it one pixel shorter) 140 ; makes it the same width (maybe at the expense of making it one pixel shorter)
140 (if (font-instance-p newfont) 141 (if (font-instance-p newfont)
141 (if (> (font-instance-width newfont) oldwidth) 142 (if (> (font-instance-width newfont) oldwidth)
142 (mswindows-find-smaller-font newfont device) 143 (mswindows-find-smaller-font newfont)
143 newfont)))))) 144 newfont))))))
144 145
145 (defun mswindows-find-smaller-font (font &optional device) 146 (defun mswindows-find-smaller-font (font &optional device)
146 "Loads a new version of the given font (or font name) 1 point smaller. 147 "Loads a new version of the given font (or font name) 1 point smaller.
147 Returns the font if it succeeds, nil otherwise." 148 Returns the font if it succeeds, nil otherwise."
148 (if (stringp font) (setq font (make-font-instance font device)))
149 (if (font-instance-p font) (setq font (font-instance-truename font)))
150 (if (stringp font) (setq font (make-font-instance font device)))
151 (if (font-instance-p font) 149 (if (font-instance-p font)
152 (let (old-size (name (mswindows-font-canonicalize-name font))) 150 (let (old-size (name (mswindows-font-canonicalize-name font)))
153 (string-match "^[a-zA-Z ]+:[a-zA-Z ]*:\\([0-9]+\\):" name) 151 (string-match "^[a-zA-Z ]+:[a-zA-Z ]*:\\([0-9]+\\):" name)
154 (setq old-size (string-to-int 152 (setq old-size (string-to-int
155 (substring name (match-beginning 1) (match-end 1)))) 153 (substring name (match-beginning 1) (match-end 1))))
161 device t))))) 159 device t)))))
162 160
163 (defun mswindows-find-larger-font (font &optional device) 161 (defun mswindows-find-larger-font (font &optional device)
164 "Loads a new version of the given font (or font name) 1 point larger. 162 "Loads a new version of the given font (or font name) 1 point larger.
165 Returns the font if it succeeds, nil otherwise." 163 Returns the font if it succeeds, nil otherwise."
166 (if (stringp font) (setq font (make-font-instance font device)))
167 (if (font-instance-p font) (setq font (font-instance-truename font)))
168 (if (stringp font) (setq font (make-font-instance font device)))
169 (if (font-instance-p font) 164 (if (font-instance-p font)
170 (let (old-size (name (mswindows-font-canonicalize-name font))) 165 (let (old-size (name (mswindows-font-canonicalize-name font)))
171 (string-match "^[a-zA-Z ]+:[a-zA-Z ]*:\\([0-9]+\\):" name) 166 (string-match "^[a-zA-Z ]+:[a-zA-Z ]*:\\([0-9]+\\):" name)
172 (setq old-size (string-to-int 167 (setq old-size (string-to-int
173 (substring name (match-beginning 1) (match-end 1)))) 168 (substring name (match-beginning 1) (match-end 1))))