|
2
|
1 ;;; w3-style.el --- Emacs-W3 binding style sheet mechanism
|
|
0
|
2 ;; Author: wmperry
|
|
2
|
3 ;; Created: 1996/08/12 03:10:30
|
|
|
4 ;; Version: 1.13
|
|
0
|
5 ;; Keywords: faces, hypermedia
|
|
|
6
|
|
|
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
2
|
8 ;;; Copyright (c) 1993 - 1996 by William M. Perry (wmperry@cs.indiana.edu)
|
|
0
|
9 ;;;
|
|
|
10 ;;; This file is not part of GNU Emacs, but the same permissions apply.
|
|
|
11 ;;;
|
|
|
12 ;;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
|
13 ;;; it under the terms of the GNU General Public License as published by
|
|
|
14 ;;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
15 ;;; any later version.
|
|
|
16 ;;;
|
|
|
17 ;;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
20 ;;; GNU General Public License for more details.
|
|
|
21 ;;;
|
|
|
22 ;;; You should have received a copy of the GNU General Public License
|
|
|
23 ;;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
|
24 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
26
|
|
|
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
28 ;;; A style sheet mechanism for emacs-w3
|
|
|
29 ;;;
|
|
|
30 ;;; This will eventually be able to under DSSSL[-lite] as well as the
|
|
|
31 ;;; experimental W3C mechanism
|
|
|
32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
33 (require 'font)
|
|
|
34 (require 'w3-keyword)
|
|
|
35 (require 'cl)
|
|
|
36
|
|
|
37 (defvar w3-style-css-syntax-table
|
|
|
38 (copy-syntax-table mm-parse-args-syntax-table)
|
|
|
39 "The syntax table for parsing stylesheets")
|
|
|
40
|
|
|
41 (defvar w3-style-ie-compatibility nil
|
|
|
42 "*Whether we want to do Internet Explorer 3.0 compatible parsing of
|
|
|
43 CSS stylesheets.")
|
|
|
44
|
|
|
45 (defun w3-style-css-parse-args (st &optional nd defines)
|
|
|
46 ;; Return an assoc list of attribute/value pairs from a CSS style entry
|
|
|
47 (let (
|
|
|
48 name ; From name=
|
|
|
49 value ; its value
|
|
|
50 results ; Assoc list of results
|
|
|
51 name-pos ; Start of XXXX= position
|
|
|
52 val-pos ; Start of value position
|
|
|
53 )
|
|
|
54 (save-excursion
|
|
|
55 (if (stringp st)
|
|
|
56 (progn
|
|
|
57 (set-buffer (get-buffer-create " *w3-style-temp*"))
|
|
|
58 (set-syntax-table w3-style-css-syntax-table)
|
|
|
59 (erase-buffer)
|
|
|
60 (insert st)
|
|
|
61 (setq st (point-min)
|
|
|
62 nd (point-max)))
|
|
|
63 (set-syntax-table w3-style-css-syntax-table))
|
|
|
64 (save-restriction
|
|
|
65 (if (< nd st)
|
|
|
66 (narrow-to-region nd nd)
|
|
|
67 (narrow-to-region st nd))
|
|
|
68 (goto-char (point-min))
|
|
|
69 (while (not (eobp))
|
|
|
70 (skip-chars-forward ";, \n\t")
|
|
|
71 (setq name-pos (point))
|
|
|
72 (skip-chars-forward "^ \n\t:=,;")
|
|
|
73 (downcase-region name-pos (point))
|
|
|
74 (setq name (buffer-substring name-pos (point)))
|
|
|
75 (skip-chars-forward " \t\n")
|
|
|
76 (if (not (eq (char-after (point)) ?:)) ; There is no value
|
|
|
77 (setq value nil)
|
|
|
78 (skip-chars-forward " \t\n:")
|
|
|
79 (setq val-pos (point)
|
|
|
80 value
|
|
|
81 (cond
|
|
|
82 ((or (= (or (char-after val-pos) 0) ?\")
|
|
|
83 (= (or (char-after val-pos) 0) ?'))
|
|
|
84 (buffer-substring (1+ val-pos)
|
|
|
85 (condition-case ()
|
|
|
86 (prog2
|
|
|
87 (forward-sexp 1)
|
|
|
88 (1- (point))
|
|
|
89 (skip-chars-forward "\""))
|
|
|
90 (error
|
|
|
91 (skip-chars-forward "^ \t\n")
|
|
|
92 (point)))))
|
|
|
93 (t
|
|
|
94 (buffer-substring val-pos
|
|
|
95 (progn
|
|
|
96 (if w3-style-ie-compatibility
|
|
|
97 (skip-chars-forward "^;")
|
|
|
98 (skip-chars-forward "^,;"))
|
|
|
99 (skip-chars-backward " \t")
|
|
|
100 (point)))))))
|
|
|
101 (setq results (cons (cons name value) results))
|
|
|
102 (skip-chars-forward ";, \n\t"))
|
|
|
103 results))))
|
|
|
104
|
|
|
105 (defvar w3-style-css-define-table nil)
|
|
|
106
|
|
|
107 (defun w3-style-css-handle-define ()
|
|
|
108 (let ((name nil)
|
|
|
109 (save-pos (point))
|
|
|
110 (retval nil))
|
|
|
111 (skip-chars-forward "^ \t\r\n") ; Past the name token
|
|
|
112 (downcase-region save-pos (point))
|
|
|
113 (setq name (buffer-substring save-pos (point)))
|
|
|
114 (skip-chars-forward "= \t\r")
|
|
|
115 (setq save-pos (point))
|
|
|
116 (skip-chars-forward "^;")
|
|
|
117 (setq retval (cons name (buffer-substring save-pos (point))))
|
|
|
118 (skip-chars-forward " \t\r\n")
|
|
|
119 retval))
|
|
|
120
|
|
|
121 (defun w3-style-css-handle-import ()
|
|
|
122 (let ((url nil)
|
|
|
123 (save-pos (point)))
|
|
|
124 (if (looking-at "'\"")
|
|
|
125 (condition-case ()
|
|
|
126 (forward-sexp 1)
|
|
|
127 (error (skip-chars-forward "^ \t\r\n;")))
|
|
|
128 (skip-chars-forward "^ \t\r\n;"))
|
|
|
129 (setq url (url-expand-file-name (buffer-substring save-pos (point))))
|
|
|
130 (skip-chars-forward "\"; \t\r\n")
|
|
|
131 (setq save-pos (point))
|
|
|
132 (let ((url-working-buffer (url-generate-new-buffer-name " *styleimport*"))
|
|
|
133 (url-mime-accept-string
|
|
|
134 "text/css ; level=2")
|
|
|
135 (sheet nil))
|
|
|
136 (save-excursion
|
|
|
137 (set-buffer (get-buffer-create url-working-buffer))
|
|
|
138 (setq url-be-asynchronous nil)
|
|
|
139 (url-retrieve url)
|
|
|
140 (w3-style-css-clean)
|
|
|
141 (setq sheet (buffer-string))
|
|
2
|
142 (set-buffer-modified-p nil)
|
|
0
|
143 (kill-buffer (current-buffer)))
|
|
|
144 (insert sheet)
|
|
|
145 (goto-char save-pos))))
|
|
|
146
|
|
|
147 (defun w3-style-css-clean ()
|
|
|
148 ;; Nuke comments, etc.
|
|
|
149 (goto-char (point-min))
|
|
|
150 (let ((save-pos nil))
|
|
|
151 (while (search-forward "/*" nil t)
|
|
|
152 (setq save-pos (- (point) 2))
|
|
|
153 (delete-region save-pos
|
|
|
154 (if (search-forward "*/" nil t)
|
|
|
155 (point)
|
|
|
156 (end-of-line)
|
|
|
157 (point)))))
|
|
|
158 (goto-char (point-min))
|
|
|
159 (delete-matching-lines "^[ \t\r]*$") ; Nuke blank lines
|
|
|
160 (w3-replace-regexp "^[ \t\r]+" "") ; Nuke whitespace at beg. of line
|
|
|
161 (w3-replace-regexp "[ \t\r]+$" "") ; Nuke whitespace at end of line
|
|
|
162 (goto-char (point-min)))
|
|
|
163
|
|
|
164 (defun w3-style-css-applies-to (st nd)
|
|
|
165 (let ((results nil)
|
|
|
166 (save-pos nil))
|
|
|
167 (narrow-to-region st nd)
|
|
|
168 (goto-char st)
|
|
|
169 (skip-chars-forward " \t\r\n")
|
|
|
170 (while (not (eobp))
|
|
|
171 (setq save-pos (point))
|
|
|
172 (skip-chars-forward "^,")
|
|
|
173 (skip-chars-backward " \r\t\n")
|
|
|
174 (setq results (cons (buffer-substring save-pos (point)) results))
|
|
|
175 (skip-chars-forward ", \t\r\n"))
|
|
|
176 (widen)
|
|
|
177 results))
|
|
|
178
|
|
2
|
179 (defun w3-style-active-device-types (&optional device)
|
|
|
180 (let ((types (list 'normal 'default (if w3-running-xemacs 'xemacs 'emacs)))
|
|
|
181 (type (device-type device)))
|
|
|
182 (cond
|
|
|
183 ((featurep 'emacspeak)
|
|
|
184 (setq types (cons 'speech types)))
|
|
|
185 ((eq type 'tty)
|
|
|
186 (if (and (fboundp 'tty-color-list)
|
|
|
187 (/= 0 (length (tty-color-list))))
|
|
|
188 (setq types (cons 'ansi-tty types))
|
|
|
189 (setq types (cons 'tty types))))
|
|
|
190 ((eq 'color (device-class))
|
|
|
191 (if (not (device-bitplanes))
|
|
|
192 (setq types (cons 'color types))
|
|
|
193 (setq types
|
|
|
194 (append
|
|
|
195 (list (intern (format "%dbit-color"
|
|
|
196 (device-bitplanes)))
|
|
|
197 (intern (format "%dbit"
|
|
|
198 (device-bitplanes)))
|
|
|
199 'color) types))
|
|
|
200 (if (= 24 (device-bitplanes))
|
|
|
201 (setq types (cons 'truecolor types)))))
|
|
|
202 ((eq 'grayscale (device-class))
|
|
|
203 (setq types (append (list (intern (format "%dbit-grayscale"
|
|
|
204 (device-bitplanes)))
|
|
|
205 'grayscale)
|
|
|
206 types)))
|
|
|
207 ((eq 'mono (device-class))
|
|
|
208 (setq types (append (list 'mono 'monochrome) types)))
|
|
|
209 (t
|
|
|
210 (setq types (cons 'unknown types))))
|
|
|
211 types))
|
|
|
212
|
|
0
|
213 (defun w3-style-parse-css (fname &optional string inherit)
|
|
|
214 (let (
|
|
|
215 (url-mime-accept-string
|
|
|
216 "text/css ; level=2")
|
|
|
217 (save-pos nil)
|
|
|
218 (applies-to nil) ; List of tags to apply style to
|
|
|
219 (attrs nil) ; List of name/value pairs
|
|
|
220 (tag nil)
|
|
|
221 (att nil)
|
|
|
222 (cur nil)
|
|
|
223 (val nil)
|
|
|
224 (class nil)
|
|
|
225 (defines nil)
|
|
|
226 (device-type nil)
|
|
2
|
227 (active-device-types (w3-style-active-device-types (selected-device)))
|
|
0
|
228 (sheet inherit))
|
|
|
229 (save-excursion
|
|
|
230 (set-buffer (get-buffer-create
|
|
|
231 (url-generate-new-buffer-name " *style*")))
|
|
|
232 (set-syntax-table w3-style-css-syntax-table)
|
|
|
233 (erase-buffer)
|
|
|
234 (if fname (url-insert-file-contents fname))
|
|
|
235 (goto-char (point-max))
|
|
|
236 (if string (insert string))
|
|
|
237 (w3-style-css-clean)
|
|
|
238 (goto-char (point-min))
|
|
|
239 (while (not (eobp))
|
|
|
240 (setq save-pos (point))
|
|
|
241 (cond
|
|
2
|
242 ;; *sigh* SGML comments are being used to 'hide' data inlined
|
|
|
243 ;; with the <style> tag from older browsers.
|
|
|
244 ((or (looking-at "<!--+") ; begin
|
|
|
245 (looking-at "--+>")) ; end
|
|
|
246 (goto-char (match-end 0)))
|
|
0
|
247 ;; C++ style comments, and we are doing IE compatibility
|
|
|
248 ((and (looking-at "//") w3-style-ie-compatibility)
|
|
|
249 (end-of-line))
|
|
|
250 ;; Pre-Processor directives
|
|
|
251 ((looking-at "[ \t\r]*@\\([^ \t\r\n]\\)")
|
|
|
252 (let ((directive nil))
|
|
|
253 (skip-chars-forward " @\t\r") ; Past any leading whitespace
|
|
|
254 (setq save-pos (point))
|
|
|
255 (skip-chars-forward "^ \t\r\n") ; Past the @ directive
|
|
|
256 (downcase-region save-pos (point))
|
|
|
257 (setq directive (buffer-substring save-pos (point)))
|
|
|
258 (skip-chars-forward " \t\r") ; Past any trailing whitespace
|
|
|
259 (setq save-pos (point))
|
|
|
260 (cond
|
|
|
261 ((string= directive "define")
|
|
|
262 (let ((retval (w3-style-css-handle-define)))
|
|
|
263 (and defines
|
|
|
264 (setq defines (cons retval defines)))))
|
|
|
265 ((string= directive "import")
|
|
|
266 (w3-style-css-handle-import))
|
|
|
267 (t
|
|
|
268 (w3-warn 'style (format "Unknown directive: @%s" directive)
|
|
|
269 'warning)))))
|
|
|
270 ;; Giving us some output device information
|
|
2
|
271 ((looking-at "[ \t\r]*:\\([^: \n]+\\):")
|
|
0
|
272 (downcase-region (match-beginning 1) (match-end 1))
|
|
|
273 (setq device-type (intern (buffer-substring (match-beginning 1)
|
|
|
274 (match-end 1))))
|
|
|
275 (goto-char (match-end 0))
|
|
|
276 (if (not (memq device-type active-device-types))
|
|
|
277 ;; Not applicable to us... skip the info
|
|
|
278 (progn
|
|
2
|
279 (if (re-search-forward ":[^:{ ]*:" nil t)
|
|
0
|
280 (goto-char (match-beginning 0))
|
|
|
281 (goto-char (point-max))))))
|
|
|
282 ;; Default is to treat it like a stylesheet declaration
|
|
|
283 (t
|
|
2
|
284 (skip-chars-forward "^{")
|
|
|
285 ;;(downcase-region save-pos (point))
|
|
0
|
286 (setq applies-to (w3-style-css-applies-to save-pos (point)))
|
|
|
287 (skip-chars-forward "^{")
|
|
|
288 (setq save-pos (point))
|
|
|
289 (forward-sexp 1)
|
|
|
290 (end-of-line)
|
|
|
291 (skip-chars-backward "\r}")
|
|
|
292 (subst-char-in-region save-pos (point) ?\n ? )
|
|
|
293 (subst-char-in-region save-pos (point) ?\r ? )
|
|
|
294 (setq attrs (w3-style-css-parse-args (1+ save-pos)
|
|
|
295 (point) defines))
|
|
|
296 (skip-chars-forward "}\r\n")
|
|
|
297 (while applies-to
|
|
|
298 (setq cur (car applies-to)
|
|
|
299 applies-to (cdr applies-to))
|
|
|
300 (cond
|
|
2
|
301 ((string-match "\\([^.]*\\)\\.\\(.*\\)" cur) ; Normal class
|
|
0
|
302 (setq tag (intern (downcase (match-string 1 cur)))
|
|
|
303 class (match-string 2 cur)))
|
|
|
304 ((string-match "\\(.*\\):\\(.*\\)" cur) ; Pseudo class
|
|
|
305 (setq tag (intern (downcase (match-string 1 cur)))
|
|
|
306 class (match-string 2 cur)))
|
|
|
307 (t ; No class - global
|
|
|
308 (setq tag (intern (downcase cur))
|
|
|
309 class 'internal)))
|
|
|
310 (let ((loop attrs))
|
|
|
311 (while loop
|
|
|
312 (if (stringp (car (car loop)))
|
|
|
313 (setcar (car loop) (intern (car (car loop)))))
|
|
|
314 (setq att (car (car loop))
|
|
|
315 val (cdr (car loop))
|
|
|
316 loop (cdr loop))
|
|
|
317 (case att
|
|
|
318 ((align textalign text-align display white-space)
|
|
|
319 (setq val (intern (downcase val))))
|
|
|
320 ((indent left-margin right-margin top-margin bottom-margin)
|
|
|
321 (setq val (string-to-int val)))
|
|
|
322 (otherwise
|
|
|
323 nil))
|
|
|
324 (let* ((node-1 (assq tag sheet))
|
|
|
325 (node-2 (and node-1 (assoc class node-1)))
|
|
|
326 (node-3 (and node-2 (assq att node-2))))
|
|
|
327 (cond
|
|
|
328 ((not node-1) ; New top-level element
|
|
|
329 (setq sheet (cons (cons tag (list (cons class
|
|
|
330 (list
|
|
|
331 (cons att val)))))
|
|
|
332 sheet)))
|
|
|
333 ((and node-1 (not node-2)) ; New class for existing element
|
|
|
334 (setcdr node-1 (cons (cons class (list (cons att val)))
|
|
|
335 (cdr node-1))))
|
|
|
336 ((and node-2 (not node-3)) ; attribute/value on old class
|
|
|
337 (setcdr node-2 (cons (cons att val) (cdr node-2))))
|
|
|
338 (node-3 ; Replace existing attribute value
|
|
|
339 (setcdr node-3 val)))))))))
|
|
|
340 (skip-chars-forward " \t\r\n"))
|
|
|
341 (set-buffer-modified-p nil)
|
|
|
342 (kill-buffer (current-buffer)))
|
|
|
343 (cons sheet defines)))
|
|
|
344
|
|
|
345
|
|
|
346 (defvar w3-style-font-size-mappings
|
|
|
347 '(("xx-small" . 0)
|
|
|
348 ("x-small" . 1)
|
|
|
349 ("small" . 2)
|
|
|
350 ("medium" . 3)
|
|
|
351 ("large" . 4)
|
|
|
352 ("x-large" . 5)
|
|
|
353 ("xx-large" . 6)
|
|
|
354 )
|
|
|
355 "A list of font size mappings")
|
|
|
356
|
|
|
357 (defvar w3-style-font-weight-mappings
|
|
|
358 '(("-3" . :extra-light)
|
|
|
359 ("-2" . :light)
|
|
|
360 ("-1" . :demi-light)
|
|
|
361 ("0" . :medium)
|
|
|
362 ("1" . :normal)
|
|
|
363 ("2" . :demi-bold)
|
|
|
364 ("3" . :bold)
|
|
|
365 ("4" . :extrabold)
|
|
|
366 ("bold" . :bold)
|
|
|
367 ("demi-light" . :demi-light)
|
|
|
368 ("demi-bold" . :demi-bold)
|
|
|
369 ("extra-bold" . :extra-bold)
|
|
|
370 ("extra-light". :extra-light)
|
|
|
371 )
|
|
|
372 "A list of font weight mappings.")
|
|
|
373
|
|
|
374 (defun w3-style-font-size-for-index (index)
|
|
|
375 (if (stringp index)
|
|
|
376 (setq index (or
|
|
|
377 (cdr-safe (assoc (downcase index)
|
|
|
378 w3-style-font-size-mappings))
|
|
|
379 3)))
|
|
|
380 (setq index (- index 3))
|
|
|
381 (let ((scaler (if (> index 0)
|
|
|
382 1.44
|
|
|
383 0.695))
|
|
|
384 (size 12))
|
|
|
385 (setq index (abs index))
|
|
|
386 (while (/= index 0)
|
|
|
387 (setq size (* size scaler)
|
|
|
388 index (1- index)))
|
|
|
389 ;; This rounds to the nearest '10'
|
|
|
390 (format "%dpt" (* 10 (round (/ size 10))))))
|
|
|
391
|
|
2
|
392 (defsubst w3-style-speech-normalize-number (num)
|
|
|
393 (if num (% (abs (read num)) 9)))
|
|
|
394
|
|
|
395 (defun w3-generate-stylesheet-voices (sheet)
|
|
|
396 (let ((todo sheet)
|
|
|
397 cur cur-classes
|
|
|
398 node family gain
|
|
|
399 left right pitch
|
|
|
400 pitch-range stress
|
|
|
401 richness voice
|
|
|
402 )
|
|
|
403 (while todo
|
|
|
404 (setq cur (car todo)
|
|
|
405 cur-classes (cdr cur)
|
|
|
406 todo (cdr todo))
|
|
|
407 (while cur-classes
|
|
|
408 (setq node (cdr (car cur-classes))
|
|
|
409 cur (car cur-classes)
|
|
|
410 cur-classes (cdr cur-classes)
|
|
|
411 family (cdr-safe (assq 'voice-family node))
|
|
|
412 family (if family (intern (downcase family)))
|
|
|
413 gain (w3-style-speech-normalize-number
|
|
|
414 (cdr-safe (assq 'gain node)))
|
|
|
415 left (w3-style-speech-normalize-number
|
|
|
416 (cdr-safe (assq 'left-volume node)))
|
|
|
417 right (w3-style-speech-normalize-number
|
|
|
418 (cdr-safe (assq 'right-volume node)))
|
|
|
419 pitch (w3-style-speech-normalize-number
|
|
|
420 (cdr-safe (assq 'pitch node)))
|
|
|
421 pitch-range (w3-style-speech-normalize-number
|
|
|
422 (cdr-safe (assq 'pitch-range node)))
|
|
|
423 stress (w3-style-speech-normalize-number
|
|
|
424 (cdr-safe (assq 'stress node)))
|
|
|
425 richness (w3-style-speech-normalize-number
|
|
|
426 (cdr-safe (assq 'richness node))))
|
|
|
427 (if (or family gain left right pitch pitch-range stress richness)
|
|
|
428 (setq voice (dtk-personality-from-speech-style
|
|
|
429 (make-dtk-speech-style :family (or family 'paul)
|
|
|
430 :gain (or gain 5)
|
|
|
431 :left-volume (or left 5)
|
|
|
432 :right-volume (or right 5)
|
|
|
433 :average-pitch (or pitch 5)
|
|
|
434 :pitch-range (or pitch-range 5)
|
|
|
435 :stress (or stress 5)
|
|
|
436 :richness (or richness 5))))
|
|
|
437 (setq voice nil))
|
|
|
438 (if voice (setcdr cur (cons (cons 'voice-spec voice) (cdr cur))))
|
|
|
439 )
|
|
|
440 )
|
|
|
441 )
|
|
|
442 )
|
|
|
443
|
|
|
444 (defun w3-style-post-process-stylesheet (sheet)
|
|
|
445 (w3-generate-stylesheet-faces sheet)
|
|
|
446 (if (featurep 'emacspeak)
|
|
|
447 (w3-generate-stylesheet-voices w3-user-stylesheet)))
|
|
|
448
|
|
|
449 (defun w3-style-css-split-font-shorthand (font)
|
|
|
450 ;; [<font-weight> || <font-style>]? <font-size> [ / <line-height> ]? <font-family>
|
|
|
451 (let (weight size height family)
|
|
|
452 (if (not (string-match " *\\([0-9.]+[^ /]+\\)" font))
|
|
|
453 (error "Malformed font shorthand: %s" font))
|
|
|
454 (setq weight (if (/= 0 (match-beginning 0))
|
|
|
455 (substring font 0 (match-beginning 0)))
|
|
|
456 size (match-string 1 font)
|
|
|
457 font (substring font (match-end 0) nil))
|
|
|
458 (if (string-match " */ *\\([^ ]+\\) *" font)
|
|
|
459 ;; they specified a line-height as well
|
|
|
460 (setq height (match-string 1 font)
|
|
|
461 family (substring font (match-end 0) nil))
|
|
|
462 (setq family (url-strip-leading-spaces font)))
|
|
|
463 (list weight size height family)))
|
|
|
464
|
|
0
|
465 (defun w3-generate-stylesheet-faces (sheet)
|
|
|
466 (let ((todo sheet)
|
|
|
467 (cur nil)
|
|
|
468 (cur-classes nil)
|
|
|
469 (node nil)
|
|
|
470 (fore nil)
|
|
|
471 (back nil)
|
|
|
472 (pixmap nil)
|
|
|
473 (font nil)
|
|
|
474 (family nil)
|
|
|
475 (decoration nil)
|
|
|
476 (style nil)
|
|
|
477 (size nil)
|
|
|
478 (index nil)
|
|
|
479 (shorthand nil)
|
|
|
480 (weight nil)
|
|
|
481 (break-style nil))
|
|
|
482 (while todo
|
|
|
483 (setq cur (car todo)
|
|
|
484 cur-classes (cdr cur)
|
|
|
485 todo (cdr todo))
|
|
|
486 (while cur-classes
|
|
|
487 (setq node (cdr (car cur-classes))
|
|
|
488 cur (car cur-classes)
|
|
|
489 cur-classes (cdr cur-classes)
|
|
|
490 fore (cdr-safe (assq 'color node))
|
|
|
491 back (cdr-safe (assq 'background node))
|
|
|
492 decoration (cdr-safe (assq 'text-decoration node))
|
|
|
493 pixmap (cdr-safe (assq 'backdrop node))
|
|
|
494 index (cdr-safe (assq 'font-size-index node))
|
|
|
495 size (or (and index (w3-style-font-size-for-index index))
|
|
|
496 (cdr-safe (assq 'font-size node)))
|
|
|
497 family (cdr-safe (assq 'font-family node))
|
|
|
498 weight (cdr-safe (assq 'font-weight node))
|
|
|
499 weight (or (cdr-safe (assoc weight
|
|
|
500 w3-style-font-weight-mappings))
|
|
|
501 weight)
|
|
|
502 style (cdr-safe (assq 'font-style node))
|
|
|
503 shorthand (cdr-safe (assq 'font node)))
|
|
|
504
|
|
|
505 ;; Make sure all 'break' items get intern'd
|
|
|
506 (if (or style decoration)
|
|
|
507 (setq style (concat style decoration)))
|
|
|
508 (setq break-style (assq 'break node))
|
|
|
509 (if (and (cdr break-style) (stringp (cdr break-style)))
|
|
|
510 (setcdr break-style (intern (cdr break-style))))
|
|
|
511 (if shorthand
|
|
2
|
512 (progn
|
|
|
513 (setq shorthand (w3-style-css-split-font-shorthand shorthand))
|
|
|
514 (setq weight (or (nth 0 shorthand) weight)
|
|
|
515 size (or (nth 1 shorthand) size)
|
|
|
516 family (or (nth 3 shorthand) family)
|
|
0
|
517 weight (or (cdr-safe
|
|
|
518 (assoc weight
|
|
|
519 w3-style-font-weight-mappings))
|
|
2
|
520 weight))))
|
|
0
|
521 (if style
|
|
|
522 (setq style (mapcar
|
|
|
523 (function
|
|
|
524 (lambda (x)
|
|
|
525 (while (string-match "-" x)
|
|
|
526 (setq x (concat
|
|
|
527 (substring x 0 (match-beginning 0))
|
|
|
528 (substring x (match-end 0) nil))))
|
|
|
529 (intern-soft
|
|
|
530 (concat "font-set-" (downcase x) "-p"))))
|
|
|
531 (delete "" (split-string style "[ \t&,]")))))
|
|
2
|
532 (if family (setq family (delete "" (split-string family ","))))
|
|
0
|
533 (if (or family weight style size)
|
|
|
534 (progn
|
|
|
535 (setq font (make-font :family family :weight weight :size size))
|
|
|
536 (while style
|
|
|
537 (and (fboundp (car style))
|
|
|
538 (funcall (car style) font t))
|
|
|
539 (setq style (cdr style))))
|
|
|
540 (setq font nil))
|
|
|
541 (if font (setcdr cur (cons (cons 'font-spec font) (cdr cur))))
|
|
|
542 (if fore (setcdr cur (cons (cons 'foreground fore) (cdr cur))))
|
|
|
543 (if back (setcdr cur (cons (cons 'background back) (cdr cur))))
|
|
|
544 )
|
|
|
545 )
|
|
|
546 )
|
|
|
547 )
|
|
|
548
|
|
|
549 (defun w3-handle-style (&optional args)
|
|
|
550 (let ((fname (or (cdr-safe (assq 'href args))
|
|
|
551 (cdr-safe (assq 'src args))
|
|
|
552 (cdr-safe (assq 'uri args))))
|
|
|
553 (type (downcase (or (cdr-safe (assq 'notation args))
|
|
|
554 "experimental")))
|
|
|
555 (url-working-buffer " *style*")
|
|
|
556 (base (cdr-safe (assq 'base args)))
|
|
|
557 (stylesheet nil)
|
|
|
558 (defines nil)
|
|
|
559 (cur-sheet w3-current-stylesheet)
|
|
|
560 (string (cdr-safe (assq 'data args))))
|
|
|
561 (if fname (setq fname (url-expand-file-name fname
|
|
|
562 (cdr-safe
|
|
|
563 (assoc base w3-base-alist)))))
|
|
|
564 (save-excursion
|
|
|
565 (set-buffer (get-buffer-create url-working-buffer))
|
|
|
566 (erase-buffer)
|
|
|
567 (setq url-be-asynchronous nil)
|
|
|
568 (cond
|
|
|
569 ((member type '("experimental" "arena" "w3c-style" "css"))
|
|
|
570 (let ((data (w3-style-parse-css fname string cur-sheet)))
|
|
|
571 (setq stylesheet (nth 0 data)
|
|
|
572 defines (nth 1 data))))
|
|
|
573 (t
|
|
|
574 (w3-warn 'html "Unknown stylesheet notation: %s" type))))
|
|
|
575 (setq w3-current-stylesheet stylesheet)
|
|
2
|
576 (w3-style-post-process-stylesheet w3-current-stylesheet)))
|
|
0
|
577
|
|
|
578 (defun w3-display-stylesheet (&optional sheet)
|
|
|
579 (interactive)
|
|
|
580 (if (not sheet) (setq sheet w3-current-stylesheet))
|
|
|
581 (with-output-to-temp-buffer "W3 Stylesheet"
|
|
|
582 (set-buffer standard-output)
|
|
|
583 (emacs-lisp-mode)
|
|
|
584 (require 'pp)
|
|
|
585 (pp sheet (current-buffer))))
|
|
|
586
|
|
|
587 (provide 'w3-style)
|
