Mercurial > hg > xemacs-beta

comparison lisp/font.el @ 5475:248176c74e6b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge with trunk.
author Mats Lidell <matsl@xemacs.org>
date Sat, 23 Apr 2011 23:47:13 +0200
parents ac37a5f7e5be 97968d099404
children 23dc211f4d2f
comparison
equal deleted inserted replaced
5474:4dee0387b9de 5475:248176c74e6b
46 (globally-declare-fboundp 46 (globally-declare-fboundp
47 '(internal-facep fontsetp get-font-info 47 '(internal-facep fontsetp get-font-info
48 get-fontset-info mswindows-define-rgb-color cancel-function-timers 48 get-fontset-info mswindows-define-rgb-color cancel-function-timers
49 mswindows-font-regexp mswindows-canonicalize-font-name 49 mswindows-font-regexp mswindows-canonicalize-font-name
50 mswindows-parse-font-style mswindows-construct-font-style 50 mswindows-parse-font-style mswindows-construct-font-style
51 ;; #### perhaps we should rewrite font-warn to avoid the warning
52 ;; Eh, now I look at the code, we definitely should.
53 font-warn
54 fc-pattern-get-family fc-pattern-get-size fc-pattern-get-weight 51 fc-pattern-get-family fc-pattern-get-size fc-pattern-get-weight
55 fc-font-weight-translate-from-constant make-fc-pattern 52 fc-font-weight-translate-from-constant make-fc-pattern
56 fc-pattern-add-family fc-pattern-add-size)) 53 fc-pattern-add-family fc-pattern-add-size))
57 54
58 (globally-declare-boundp 55 (globally-declare-boundp
1068 (set-face-font face font-spec cur-device))))))) 1065 (set-face-font face font-spec cur-device)))))))
1069 1066
1070 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1067 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1071 ;;; Various color related things 1068 ;;; Various color related things
1072 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1069 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1073 (cond
1074 ((fboundp 'display-warning)
1075 (fset 'font-warn 'display-warning))
1076 ((fboundp 'w3-warn)
1077 (fset 'font-warn 'w3-warn))
1078 ((fboundp 'url-warn)
1079 (fset 'font-warn 'url-warn))
1080 ((fboundp 'warn)
1081 (defun font-warn (class message &optional level)
1082 (warn "(%s/%s) %s" class (or level 'warning) message)))
1083 (t
1084 (defun font-warn (class message &optional level)
1085 (save-excursion
1086 (set-buffer (get-buffer-create "*W3-WARNINGS*"))
1087 (goto-char (point-max))
1088 (save-excursion
1089 (insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
1090 (display-buffer (current-buffer))))))
1091 1070
1092 (defun font-lookup-rgb-components (color) 1071 (defun font-lookup-rgb-components (color)
1093 "Lookup COLOR (a color name) in rgb.txt and return a list of RGB values. 1072 "Lookup COLOR (a color name) in rgb.txt and return a list of RGB values.
1094 The list (R G B) is returned, or an error is signaled if the lookup fails." 1073 The list (R G B) is returned, or an error is signaled if the lookup fails."
1095 (let ((lib-list (if-boundp 'x-library-search-path 1074 (let ((lib-list (if-boundp 'x-library-search-path
1140 (progn 1119 (progn
1141 (beginning-of-line) 1120 (beginning-of-line)
1142 (setq r (* (read (current-buffer)) 256) 1121 (setq r (* (read (current-buffer)) 256)
1143 g (* (read (current-buffer)) 256) 1122 g (* (read (current-buffer)) 256)
1144 b (* (read (current-buffer)) 256))) 1123 b (* (read (current-buffer)) 256)))
1145 (font-warn 'color (format "No such color: %s" color)) 1124 (display-warning 'color (format "No such color: %s" color))
1146 (setq r 0 1125 (setq r 0
1147 g 0 1126 g 0
1148 b 0)) 1127 b 0))
1149 (list r g b) )))))) 1128 (list r g b) ))))))
1150
1151 (defun font-hex-string-to-number (string)
1152 "Convert STRING to an integer by parsing it as a hexadecimal number."
1153 (let ((conv-list '((?0 . 0) (?a . 10) (?A . 10)
1154 (?1 . 1) (?b . 11) (?B . 11)
1155 (?2 . 2) (?c . 12) (?C . 12)
1156 (?3 . 3) (?d . 13) (?D . 13)
1157 (?4 . 4) (?e . 14) (?E . 14)
1158 (?5 . 5) (?f . 15) (?F . 15)
1159 (?6 . 6)
1160 (?7 . 7)
1161 (?8 . 8)
1162 (?9 . 9)))
1163 (n 0)
1164 (i 0)
1165 (lim (length string)))
1166 (while (< i lim)
1167 (setq n (+ (* n 16) (or (cdr (assq (aref string i) conv-list)) 0))
1168 i (1+ i)))
1169 n ))
1170 1129
1171 (defun font-parse-rgb-components (color) 1130 (defun font-parse-rgb-components (color)
1172 "Parse RGB color specification and return a list of integers (R G B). 1131 "Parse RGB color specification and return a list of integers (R G B).
1173 #FEFEFE and rgb:fe/fe/fe style specifications are parsed." 1132 #FEFEFE and rgb:fe/fe/fe style specifications are parsed."
1174 (let ((case-fold-search t) 1133 (let ((case-fold-search t)
1175 r g b str) 1134 r g b str)
1176 (cond ((string-match "^#[0-9a-f]+$" color) 1135 (cond ((string-match "^#[0-9a-f]+$" color)
1177 (cond 1136 (cond
1178 ((eql (length color) 4) 1137 ((eql (length color) 4)
1179 (setq r (font-hex-string-to-number (substring color 1 2)) 1138 (setq r (string-to-number (substring color 1 2) 16)
1180 g (font-hex-string-to-number (substring color 2 3)) 1139 g (string-to-number (substring color 2 3) 16)
1181 b (font-hex-string-to-number (substring color 3 4)) 1140 b (string-to-number (substring color 3 4) 16)
1182 r (* r 4096) 1141 r (* r 4096)
1183 g (* g 4096) 1142 g (* g 4096)
1184 b (* b 4096))) 1143 b (* b 4096)))
1185 ((eql (length color) 7) 1144 ((eql (length color) 7)
1186 (setq r (font-hex-string-to-number (substring color 1 3)) 1145 (setq r (string-to-number (substring color 1 3) 16)
1187 g (font-hex-string-to-number (substring color 3 5)) 1146 g (string-to-number (substring color 3 5) 16)
1188 b (font-hex-string-to-number (substring color 5 7)) 1147 b (string-to-number (substring color 5 7) 16)
1189 r (* r 256) 1148 r (* r 256)
1190 g (* g 256) 1149 g (* g 256)
1191 b (* b 256))) 1150 b (* b 256)))
1192 ((eql (length color) 10) 1151 ((eql (length color) 10)
1193 (setq r (font-hex-string-to-number (substring color 1 4)) 1152 (setq r (string-to-number (substring color 1 4) 16)
1194 g (font-hex-string-to-number (substring color 4 7)) 1153 g (string-to-number (substring color 4 7) 16)
1195 b (font-hex-string-to-number (substring color 7 10)) 1154 b (string-to-number (substring color 7 10) 16)
1196 r (* r 16) 1155 r (* r 16)
1197 g (* g 16) 1156 g (* g 16)
1198 b (* b 16))) 1157 b (* b 16)))
1199 ((eql (length color) 13) 1158 ((eql (length color) 13)
1200 (setq r (font-hex-string-to-number (substring color 1 5)) 1159 (setq r (string-to-number (substring color 1 5) 16)
1201 g (font-hex-string-to-number (substring color 5 9)) 1160 g (string-to-number (substring color 5 9) 16)
1202 b (font-hex-string-to-number (substring color 9 13)))) 1161 b (string-to-number (substring color 9 13) 16)))
1203 (t 1162 (t
1204 (font-warn 'color (format "Invalid RGB color specification: %s" 1163 (display-warning 'color
1205 color)) 1164 (format "Invalid RGB color specification: %s" color))
1206 (setq r 0 1165 (setq r 0
1207 g 0 1166 g 0
1208 b 0)))) 1167 b 0))))
1209 ((string-match "rgb:\\([0-9a-f]+\\)/\\([0-9a-f]+\\)/\\([0-9a-f]+\\)" 1168 ((string-match "rgb:\\([0-9a-f]+\\)/\\([0-9a-f]+\\)/\\([0-9a-f]+\\)"
1210 color) 1169 color)
1211 (if (or (> (- (match-end 1) (match-beginning 1)) 4) 1170 (if (or (> (- (match-end 1) (match-beginning 1)) 4)
1212 (> (- (match-end 2) (match-beginning 2)) 4) 1171 (> (- (match-end 2) (match-beginning 2)) 4)
1213 (> (- (match-end 3) (match-beginning 3)) 4)) 1172 (> (- (match-end 3) (match-beginning 3)) 4))
1214 (error "Invalid RGB color specification: %s" color) 1173 (error "Invalid RGB color specification: %s" color)
1215 (setq str (match-string 1 color) 1174 (setq str (match-string 1 color)
1216 r (* (font-hex-string-to-number str) 1175 r (* (string-to-number str 16)
1217 (expt 16 (- 4 (length str)))) 1176 (expt 16 (- 4 (length str))))
1218 str (match-string 2 color) 1177 str (match-string 2 color)
1219 g (* (font-hex-string-to-number str) 1178 g (* (string-to-number str 16)
1220 (expt 16 (- 4 (length str)))) 1179 (expt 16 (- 4 (length str))))
1221 str (match-string 3 color) 1180 str (match-string 3 color)
1222 b (* (font-hex-string-to-number str) 1181 b (* (string-to-number str 16)
1223 (expt 16 (- 4 (length str))))))) 1182 (expt 16 (- 4 (length str)))))))
1224 (t 1183 (t
1225 (font-warn 'html (format "Invalid RGB color specification: %s" 1184 (display-warning 'color (format "Invalid RGB color specification: %s"
1226 color)) 1185 color))
1227 (setq r 0 1186 (setq r 0
1228 g 0 1187 g 0
1229 b 0))) 1188 b 0)))
1230 (list r g b) )) 1189 (list r g b) ))
1231 1190