Mercurial > hg > xemacs-beta

comparison lisp/font.el @ 5458:97968d099404

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