|
0
|
1 ;;; w3-style.el,v --- Emacs-W3 binding style sheet mechanism
|
|
|
2 ;; Author: wmperry
|
|
|
3 ;; Created: 1996/05/31 21:34:16
|
|
|
4 ;; Version: 1.82
|
|
|
5 ;; Keywords: faces, hypermedia
|
|
|
6
|
|
|
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
8 ;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com)
|
|
|
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))
|
|
|
142 (kill-buffer (current-buffer)))
|
|
|
143 (insert sheet)
|
|
|
144 (goto-char save-pos))))
|
|
|
145
|
|
|
146 (defun w3-style-css-clean ()
|
|
|
147 ;; Nuke comments, etc.
|
|
|
148 (goto-char (point-min))
|
|
|
149 (let ((save-pos nil))
|
|
|
150 (while (search-forward "/*" nil t)
|
|
|
151 (setq save-pos (- (point) 2))
|
|
|
152 (delete-region save-pos
|
|
|
153 (if (search-forward "*/" nil t)
|
|
|
154 (point)
|
|
|
155 (end-of-line)
|
|
|
156 (point)))))
|
|
|
157 (goto-char (point-min))
|
|
|
158 (delete-matching-lines "^[ \t\r]*$") ; Nuke blank lines
|
|
|
159 (w3-replace-regexp "^[ \t\r]+" "") ; Nuke whitespace at beg. of line
|
|
|
160 (w3-replace-regexp "[ \t\r]+$" "") ; Nuke whitespace at end of line
|
|
|
161 (goto-char (point-min)))
|
|
|
162
|
|
|
163 (defun w3-style-css-applies-to (st nd)
|
|
|
164 (let ((results nil)
|
|
|
165 (save-pos nil))
|
|
|
166 (narrow-to-region st nd)
|
|
|
167 (goto-char st)
|
|
|
168 (skip-chars-forward " \t\r\n")
|
|
|
169 (while (not (eobp))
|
|
|
170 (setq save-pos (point))
|
|
|
171 (skip-chars-forward "^,")
|
|
|
172 (skip-chars-backward " \r\t\n")
|
|
|
173 (setq results (cons (buffer-substring save-pos (point)) results))
|
|
|
174 (skip-chars-forward ", \t\r\n"))
|
|
|
175 (widen)
|
|
|
176 results))
|
|
|
177
|
|
|
178 (defun w3-style-parse-css (fname &optional string inherit)
|
|
|
179 (let (
|
|
|
180 (url-mime-accept-string
|
|
|
181 "text/css ; level=2")
|
|
|
182 (save-pos nil)
|
|
|
183 (applies-to nil) ; List of tags to apply style to
|
|
|
184 (attrs nil) ; List of name/value pairs
|
|
|
185 (tag nil)
|
|
|
186 (att nil)
|
|
|
187 (cur nil)
|
|
|
188 (val nil)
|
|
|
189 (class nil)
|
|
|
190 (defines nil)
|
|
|
191 (device-type nil)
|
|
|
192 (active-device-types (list 'normal 'default
|
|
|
193 (if w3-running-FSF19 'emacs 'xemacs)))
|
|
|
194 (sheet inherit))
|
|
|
195 (let ((type (device-type)))
|
|
|
196 (cond
|
|
|
197 ((eq type 'tty)
|
|
|
198 (if (and (fboundp 'tty-color-list)
|
|
|
199 (/= 0 (length (tty-color-list))))
|
|
|
200 (setq active-device-types (cons 'ansi-tty active-device-types))
|
|
|
201 (setq active-device-types (cons 'tty active-device-types))))
|
|
|
202 ((eq 'color (device-class))
|
|
|
203 (setq active-device-types
|
|
|
204 (append
|
|
|
205 (list (intern (format "%dbit-color"
|
|
|
206 (device-bitplanes)))
|
|
|
207 (intern (format "%dbit"
|
|
|
208 (device-bitplanes)))
|
|
|
209 'color) active-device-types))
|
|
|
210 (if (= 24 (device-bitplanes))
|
|
|
211 (setq active-device-types (cons 'truecolor active-device-types))))
|
|
|
212 ((eq 'grayscale (device-class))
|
|
|
213 (setq active-device-types (append
|
|
|
214 (list (intern (format "%dbit-grayscale"
|
|
|
215 (device-bitplanes)))
|
|
|
216 'grayscale)
|
|
|
217 active-device-types)))
|
|
|
218 ((eq 'mono (device-class))
|
|
|
219 (setq active-device-types (append (list 'mono 'monochrome)
|
|
|
220 active-device-types)))
|
|
|
221 (t
|
|
|
222 (setq active-device-types (cons 'unknown active-device-types)))))
|
|
|
223
|
|
|
224 (save-excursion
|
|
|
225 (set-buffer (get-buffer-create
|
|
|
226 (url-generate-new-buffer-name " *style*")))
|
|
|
227 (set-syntax-table w3-style-css-syntax-table)
|
|
|
228 (erase-buffer)
|
|
|
229 (if fname (url-insert-file-contents fname))
|
|
|
230 (goto-char (point-max))
|
|
|
231 (if string (insert string))
|
|
|
232 (w3-style-css-clean)
|
|
|
233 (goto-char (point-min))
|
|
|
234 (while (not (eobp))
|
|
|
235 (setq save-pos (point))
|
|
|
236 (cond
|
|
|
237 ;; C++ style comments, and we are doing IE compatibility
|
|
|
238 ((and (looking-at "//") w3-style-ie-compatibility)
|
|
|
239 (end-of-line))
|
|
|
240 ;; Pre-Processor directives
|
|
|
241 ((looking-at "[ \t\r]*@\\([^ \t\r\n]\\)")
|
|
|
242 (let ((directive nil))
|
|
|
243 (skip-chars-forward " @\t\r") ; Past any leading whitespace
|
|
|
244 (setq save-pos (point))
|
|
|
245 (skip-chars-forward "^ \t\r\n") ; Past the @ directive
|
|
|
246 (downcase-region save-pos (point))
|
|
|
247 (setq directive (buffer-substring save-pos (point)))
|
|
|
248 (skip-chars-forward " \t\r") ; Past any trailing whitespace
|
|
|
249 (setq save-pos (point))
|
|
|
250 (cond
|
|
|
251 ((string= directive "define")
|
|
|
252 (let ((retval (w3-style-css-handle-define)))
|
|
|
253 (and defines
|
|
|
254 (setq defines (cons retval defines)))))
|
|
|
255 ((string= directive "import")
|
|
|
256 (w3-style-css-handle-import))
|
|
|
257 (t
|
|
|
258 (w3-warn 'style (format "Unknown directive: @%s" directive)
|
|
|
259 'warning)))))
|
|
|
260 ;; Giving us some output device information
|
|
|
261 ((looking-at "[ \t\r]*:\\([^:]+\\):")
|
|
|
262 (downcase-region (match-beginning 1) (match-end 1))
|
|
|
263 (setq device-type (intern (buffer-substring (match-beginning 1)
|
|
|
264 (match-end 1))))
|
|
|
265 (goto-char (match-end 0))
|
|
|
266 (if (not (memq device-type active-device-types))
|
|
|
267 ;; Not applicable to us... skip the info
|
|
|
268 (progn
|
|
|
269 (if (re-search-forward ":[^:]*:" nil t)
|
|
|
270 (goto-char (match-beginning 0))
|
|
|
271 (goto-char (point-max))))))
|
|
|
272 ;; Default is to treat it like a stylesheet declaration
|
|
|
273 (t
|
|
|
274 (skip-chars-forward "^{:")
|
|
|
275 (downcase-region save-pos (point))
|
|
|
276 (setq applies-to (w3-style-css-applies-to save-pos (point)))
|
|
|
277 (skip-chars-forward "^{")
|
|
|
278 (setq save-pos (point))
|
|
|
279 (forward-sexp 1)
|
|
|
280 (end-of-line)
|
|
|
281 (skip-chars-backward "\r}")
|
|
|
282 (subst-char-in-region save-pos (point) ?\n ? )
|
|
|
283 (subst-char-in-region save-pos (point) ?\r ? )
|
|
|
284 (setq attrs (w3-style-css-parse-args (1+ save-pos)
|
|
|
285 (point) defines))
|
|
|
286 (skip-chars-forward "}\r\n")
|
|
|
287 (while applies-to
|
|
|
288 (setq cur (car applies-to)
|
|
|
289 applies-to (cdr applies-to))
|
|
|
290 (cond
|
|
|
291 ((string-match "\\(.*\\)\\.\\(.*\\)" cur) ; Normal class
|
|
|
292 (setq tag (intern (downcase (match-string 1 cur)))
|
|
|
293 class (match-string 2 cur)))
|
|
|
294 ((string-match "\\(.*\\):\\(.*\\)" cur) ; Pseudo class
|
|
|
295 (setq tag (intern (downcase (match-string 1 cur)))
|
|
|
296 class (match-string 2 cur)))
|
|
|
297 (t ; No class - global
|
|
|
298 (setq tag (intern (downcase cur))
|
|
|
299 class 'internal)))
|
|
|
300 (let ((loop attrs))
|
|
|
301 (while loop
|
|
|
302 (if (stringp (car (car loop)))
|
|
|
303 (setcar (car loop) (intern (car (car loop)))))
|
|
|
304 (setq att (car (car loop))
|
|
|
305 val (cdr (car loop))
|
|
|
306 loop (cdr loop))
|
|
|
307 (case att
|
|
|
308 ((align textalign text-align display white-space)
|
|
|
309 (setq val (intern (downcase val))))
|
|
|
310 ((indent left-margin right-margin top-margin bottom-margin)
|
|
|
311 (setq val (string-to-int val)))
|
|
|
312 (otherwise
|
|
|
313 nil))
|
|
|
314 (let* ((node-1 (assq tag sheet))
|
|
|
315 (node-2 (and node-1 (assoc class node-1)))
|
|
|
316 (node-3 (and node-2 (assq att node-2))))
|
|
|
317 (cond
|
|
|
318 ((not node-1) ; New top-level element
|
|
|
319 (setq sheet (cons (cons tag (list (cons class
|
|
|
320 (list
|
|
|
321 (cons att val)))))
|
|
|
322 sheet)))
|
|
|
323 ((and node-1 (not node-2)) ; New class for existing element
|
|
|
324 (setcdr node-1 (cons (cons class (list (cons att val)))
|
|
|
325 (cdr node-1))))
|
|
|
326 ((and node-2 (not node-3)) ; attribute/value on old class
|
|
|
327 (setcdr node-2 (cons (cons att val) (cdr node-2))))
|
|
|
328 (node-3 ; Replace existing attribute value
|
|
|
329 (setcdr node-3 val)))))))))
|
|
|
330 (skip-chars-forward " \t\r\n"))
|
|
|
331 (set-buffer-modified-p nil)
|
|
|
332 (kill-buffer (current-buffer)))
|
|
|
333 (cons sheet defines)))
|
|
|
334
|
|
|
335
|
|
|
336 (defvar w3-style-font-size-mappings
|
|
|
337 '(("xx-small" . 0)
|
|
|
338 ("x-small" . 1)
|
|
|
339 ("small" . 2)
|
|
|
340 ("medium" . 3)
|
|
|
341 ("large" . 4)
|
|
|
342 ("x-large" . 5)
|
|
|
343 ("xx-large" . 6)
|
|
|
344 )
|
|
|
345 "A list of font size mappings")
|
|
|
346
|
|
|
347 (defvar w3-style-font-weight-mappings
|
|
|
348 '(("-3" . :extra-light)
|
|
|
349 ("-2" . :light)
|
|
|
350 ("-1" . :demi-light)
|
|
|
351 ("0" . :medium)
|
|
|
352 ("1" . :normal)
|
|
|
353 ("2" . :demi-bold)
|
|
|
354 ("3" . :bold)
|
|
|
355 ("4" . :extrabold)
|
|
|
356 ("bold" . :bold)
|
|
|
357 ("demi-light" . :demi-light)
|
|
|
358 ("demi-bold" . :demi-bold)
|
|
|
359 ("extra-bold" . :extra-bold)
|
|
|
360 ("extra-light". :extra-light)
|
|
|
361 )
|
|
|
362 "A list of font weight mappings.")
|
|
|
363
|
|
|
364 (defun w3-style-font-size-for-index (index)
|
|
|
365 (if (stringp index)
|
|
|
366 (setq index (or
|
|
|
367 (cdr-safe (assoc (downcase index)
|
|
|
368 w3-style-font-size-mappings))
|
|
|
369 3)))
|
|
|
370 (setq index (- index 3))
|
|
|
371 (let ((scaler (if (> index 0)
|
|
|
372 1.44
|
|
|
373 0.695))
|
|
|
374 (size 12))
|
|
|
375 (setq index (abs index))
|
|
|
376 (while (/= index 0)
|
|
|
377 (setq size (* size scaler)
|
|
|
378 index (1- index)))
|
|
|
379 ;; This rounds to the nearest '10'
|
|
|
380 (format "%dpt" (* 10 (round (/ size 10))))))
|
|
|
381
|
|
|
382 (defun w3-generate-stylesheet-faces (sheet)
|
|
|
383 (let ((todo sheet)
|
|
|
384 (cur nil)
|
|
|
385 (cur-classes nil)
|
|
|
386 (node nil)
|
|
|
387 (voice nil)
|
|
|
388 (voice-person nil)
|
|
|
389 (voice-tone nil)
|
|
|
390 (fore nil)
|
|
|
391 (back nil)
|
|
|
392 (pixmap nil)
|
|
|
393 (font nil)
|
|
|
394 (family nil)
|
|
|
395 (decoration nil)
|
|
|
396 (style nil)
|
|
|
397 (size nil)
|
|
|
398 (index nil)
|
|
|
399 (shorthand nil)
|
|
|
400 (weight nil)
|
|
|
401 (break-style nil))
|
|
|
402 (while todo
|
|
|
403 (setq cur (car todo)
|
|
|
404 cur-classes (cdr cur)
|
|
|
405 todo (cdr todo))
|
|
|
406 (while cur-classes
|
|
|
407 (setq node (cdr (car cur-classes))
|
|
|
408 cur (car cur-classes)
|
|
|
409 cur-classes (cdr cur-classes)
|
|
|
410 fore (cdr-safe (assq 'color node))
|
|
|
411 back (cdr-safe (assq 'background node))
|
|
|
412 voice-person (cdr-safe (assq 'voice node))
|
|
|
413 voice-tone (cdr-safe (assq 'voice-tone node))
|
|
|
414 decoration (cdr-safe (assq 'text-decoration node))
|
|
|
415 pixmap (cdr-safe (assq 'backdrop node))
|
|
|
416 index (cdr-safe (assq 'font-size-index node))
|
|
|
417 size (or (and index (w3-style-font-size-for-index index))
|
|
|
418 (cdr-safe (assq 'font-size node)))
|
|
|
419 family (cdr-safe (assq 'font-family node))
|
|
|
420 weight (cdr-safe (assq 'font-weight node))
|
|
|
421 weight (or (cdr-safe (assoc weight
|
|
|
422 w3-style-font-weight-mappings))
|
|
|
423 weight)
|
|
|
424 style (cdr-safe (assq 'font-style node))
|
|
|
425 shorthand (cdr-safe (assq 'font node)))
|
|
|
426
|
|
|
427 (setq voice (if (or voice-person voice-tone)
|
|
|
428 (intern
|
|
|
429 (cond
|
|
|
430 ((and voice-person voice-tone)
|
|
|
431 (concat voice-person "-" voice-tone))
|
|
|
432 (voice-person voice-person)
|
|
|
433 (voice-tone
|
|
|
434 (concat "default-voice-" voice-tone))
|
|
|
435 (t
|
|
|
436 (error "IMPOSSIBLE"))))))
|
|
|
437
|
|
|
438 ;; Make sure all 'break' items get intern'd
|
|
|
439 (if (or style decoration)
|
|
|
440 (setq style (concat style decoration)))
|
|
|
441 (setq break-style (assq 'break node))
|
|
|
442 (if (and (cdr break-style) (stringp (cdr break-style)))
|
|
|
443 (setcdr break-style (intern (cdr break-style))))
|
|
|
444 (if shorthand
|
|
|
445 (let ((shorthand (split-string shorthand "[ \t]")))
|
|
|
446 (setq size (or (nth 0 shorthand) size)
|
|
|
447 family (or (nth 1 shorthand) size)
|
|
|
448 weight (or (nth 2 shorthand) weight)
|
|
|
449 weight (or (cdr-safe
|
|
|
450 (assoc weight
|
|
|
451 w3-style-font-weight-mappings))
|
|
|
452 weight)
|
|
|
453 style (or (nth 3 shorthand) style))))
|
|
|
454 (if style
|
|
|
455 (setq style (mapcar
|
|
|
456 (function
|
|
|
457 (lambda (x)
|
|
|
458 (while (string-match "-" x)
|
|
|
459 (setq x (concat
|
|
|
460 (substring x 0 (match-beginning 0))
|
|
|
461 (substring x (match-end 0) nil))))
|
|
|
462 (intern-soft
|
|
|
463 (concat "font-set-" (downcase x) "-p"))))
|
|
|
464 (delete "" (split-string style "[ \t&,]")))))
|
|
|
465 (if family (setq family (delete "" (split-string family "[ \t]"))))
|
|
|
466 (if (or family weight style size)
|
|
|
467 (progn
|
|
|
468 (setq font (make-font :family family :weight weight :size size))
|
|
|
469 (while style
|
|
|
470 (and (fboundp (car style))
|
|
|
471 (funcall (car style) font t))
|
|
|
472 (setq style (cdr style))))
|
|
|
473 (setq font nil))
|
|
|
474 (if voice (setcdr cur (cons (cons 'voice-spec voice) (cdr cur))))
|
|
|
475 (if font (setcdr cur (cons (cons 'font-spec font) (cdr cur))))
|
|
|
476 (if fore (setcdr cur (cons (cons 'foreground fore) (cdr cur))))
|
|
|
477 (if back (setcdr cur (cons (cons 'background back) (cdr cur))))
|
|
|
478 )
|
|
|
479 )
|
|
|
480 )
|
|
|
481 )
|
|
|
482
|
|
|
483 (defun w3-handle-style (&optional args)
|
|
|
484 (let ((fname (or (cdr-safe (assq 'href args))
|
|
|
485 (cdr-safe (assq 'src args))
|
|
|
486 (cdr-safe (assq 'uri args))))
|
|
|
487 (type (downcase (or (cdr-safe (assq 'notation args))
|
|
|
488 "experimental")))
|
|
|
489 (url-working-buffer " *style*")
|
|
|
490 (base (cdr-safe (assq 'base args)))
|
|
|
491 (stylesheet nil)
|
|
|
492 (defines nil)
|
|
|
493 (cur-sheet w3-current-stylesheet)
|
|
|
494 (string (cdr-safe (assq 'data args))))
|
|
|
495 (if fname (setq fname (url-expand-file-name fname
|
|
|
496 (cdr-safe
|
|
|
497 (assoc base w3-base-alist)))))
|
|
|
498 (save-excursion
|
|
|
499 (set-buffer (get-buffer-create url-working-buffer))
|
|
|
500 (erase-buffer)
|
|
|
501 (setq url-be-asynchronous nil)
|
|
|
502 (cond
|
|
|
503 ((member type '("experimental" "arena" "w3c-style" "css"))
|
|
|
504 (let ((data (w3-style-parse-css fname string cur-sheet)))
|
|
|
505 (setq stylesheet (nth 0 data)
|
|
|
506 defines (nth 1 data))))
|
|
|
507 (t
|
|
|
508 (w3-warn 'html "Unknown stylesheet notation: %s" type))))
|
|
|
509 (setq w3-current-stylesheet stylesheet)
|
|
|
510 (if (and w3-current-stylesheet (fboundp 'make-face))
|
|
|
511 (w3-generate-stylesheet-faces w3-current-stylesheet))))
|
|
|
512
|
|
|
513 (defun w3-display-stylesheet (&optional sheet)
|
|
|
514 (interactive)
|
|
|
515 (if (not sheet) (setq sheet w3-current-stylesheet))
|
|
|
516 (with-output-to-temp-buffer "W3 Stylesheet"
|
|
|
517 (set-buffer standard-output)
|
|
|
518 (emacs-lisp-mode)
|
|
|
519 (require 'pp)
|
|
|
520 (pp sheet (current-buffer))))
|
|
|
521
|
|
|
522 (provide 'w3-style)
|
