Mercurial > hg > xemacs-beta

comparison lisp/w3/css.el @ 14:9ee227acff29 r19-15b90

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b90
author cvs
date Mon, 13 Aug 2007 08:48:42 +0200
parents
children 0293115a14e9
comparison
equal deleted inserted replaced
13:13c6d0aaafe5 14:9ee227acff29
1 ;;; css.el -- Cascading Style Sheet parser
2 ;; Author: wmperry
3 ;; Created: 1996/12/26 16:49:58
4 ;; Version: 1.18
5 ;; Keywords:
6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; Copyright (c) 1996 Free Software Foundation, Inc.
10 ;;;
11 ;;; This file is not part of GNU Emacs, but the same permissions apply.
12 ;;;
13 ;;; GNU Emacs is free software; you can redistribute it and/or modify
14 ;;; it under the terms of the GNU General Public License as published by
15 ;;; the Free Software Foundation; either version 2, or (at your option)
16 ;;; any later version.
17 ;;;
18 ;;; GNU Emacs is distributed in the hope that it will be useful,
19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;;; GNU General Public License for more details.
22 ;;;
23 ;;; You should have received a copy of the GNU General Public License
24 ;;; along with GNU Emacs; see the file COPYING. If not, write to the
25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26 ;;; Boston, MA 02111-1307, USA.
27 ;;;
28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
29
30 (eval-and-compile
31 (require 'cl)
32 (require 'font)
33 )
34
35 ;; CBI = Cant Be Implemented - due to limitations in emacs/xemacs
36 ;; NYI = Not Yet Implemented - due to limitations of space/time
37 ;; NYPI = Not Yet Partially Implemented - possible partial support, eventually
38
39 (defconst css-properties
40 '(;; Property name Inheritable? Type of data
41 [font-family nil string-list]
42 [font-style nil string]
43 [font-variant nil symbol-list]
44 [font-weight nil weight]
45 [font-size nil length]
46 [font nil font]
47 [color nil color]
48 [background nil color]
49 [word-spacing nil length] ; CBI
50 [letter-spacing nil length] ; CBI
51 [text-decoration nil symbol-list]
52 [vertical-align nil symbol] ; CBI
53 [text-transform nil string]
54 [text-align t symbol]
55 [text-indent t length] ; NYI
56 [line-height t length] ; CBI
57 [margin nil margin]
58 [margin-left nil margin]
59 [margin-right nil margin]
60 [margin-top nil margin]
61 [margin-bottom nil margin]
62 [padding nil padding]
63 [padding-left nil padding]
64 [padding-right nil padding]
65 [padding-top nil padding]
66 [padding-bottom nil padding]
67 [border nil border]
68 [border-left nil border]
69 [border-right nil border]
70 [border-top nil border]
71 [border-bottom nil border]
72 [width nil length] ; NYPI
73 [height nil length] ; NYPI
74 [float nil symbol]
75 [clear nil symbol]
76 [display nil symbol]
77 [list-style t symbol] ;!! can't specify 'inside|outside'
78 [white-space t symbol]
79
80 ;; These are for specifying speech properties
81 [voice-family t string]
82 [gain t integer]
83 [left-volume t integer]
84 [right-volume t integer]
85 [pitch t integer]
86 [pitch-range t integer]
87 [stress t integer]
88 [richness t integer]
89 )
90 "A description of the various CSS properties and how to interpret them.")
91
92 (mapcar
93 (lambda (entry)
94 (put (aref entry 0) 'css-inherit (aref entry 1))
95 (put (aref entry 0) 'css-type (aref entry 2)))
96 css-properties)
97
98 (defconst css-weights
99 '(nil ;never used
100 :extra-light
101 :light
102 :demi-light
103 :medium
104 :normal
105 :demi-bold
106 :bold
107 :extra-bold
108 )
109 "List of CSS font weights.")
110
111 (defvar css-syntax-table
112 (copy-syntax-table emacs-lisp-mode-syntax-table)
113 "The syntax table for parsing stylesheets")
114
115 (modify-syntax-entry ?' "\"" css-syntax-table)
116 (modify-syntax-entry ?` "\"" css-syntax-table)
117 (modify-syntax-entry ?{ "(" css-syntax-table)
118 (modify-syntax-entry ?} ")" css-syntax-table)
119
120 (eval-when-compile
121 (defvar css-scratch-val nil)
122 (defvar css-scratch-id nil)
123 (defvar css-scratch-class nil)
124 (defvar css-scratch-possibles nil)
125 (defvar css-scratch-current nil)
126 (defvar css-scratch-classes nil)
127 (defvar css-scratch-class-match nil)
128 (defvar css-scratch-current-rule nil)
129 (defvar css-scratch-current-value nil)
130 )
131
132 (defconst css-running-xemacs
133 (string-match "XEmacs" (emacs-version))
134 "Whether we are running in XEmacs or not.")
135
136 (defvar css-ie-compatibility t
137 "Whether we want to do Internet Explorer 3.0 compatible parsing of
138 CSS stylesheets.")
139
140 (defsubst css-replace-regexp (regexp to-string)
141 (goto-char (point-min))
142 (while (re-search-forward regexp nil t)
143 (replace-match to-string t nil)))
144
145 (defun css-contextual-match (rule stack)
146 (let ((ancestor)
147 (p-args)
148 (p-class)
149 (matched t))
150 (while rule
151 (setq ancestor (assq (caar rule) stack))
152 (if (not ancestor)
153 (setq rule nil
154 matched nil)
155 (setq p-args (cdr ancestor)
156 p-class (or (cdr-safe (assq 'class p-args)) t))
157 (if (not (equal p-class (cdar rule)))
158 (setq matched nil
159 rule nil)))
160 (setq rule (cdr rule)))
161 matched))
162
163 (defsubst css-get-internal (tag args)
164 (declare (special tag sheet element-stack default))
165 (setq css-scratch-id (or (cdr-safe (assq 'id args))
166 (cdr-safe (assq 'name args)))
167 css-scratch-class (or (cdr-safe (assq 'class args)) t)
168 css-scratch-possibles (cl-gethash tag sheet))
169 (while css-scratch-possibles
170 (setq css-scratch-current (car css-scratch-possibles)
171 css-scratch-current-rule (car css-scratch-current)
172 css-scratch-current-value (cdr css-scratch-current)
173 css-scratch-classes (if (listp (car css-scratch-current-rule))
174 (cdar css-scratch-current-rule)
175 (cdr css-scratch-current-rule))
176 css-scratch-class-match t
177 css-scratch-possibles (cdr css-scratch-possibles))
178 (if (eq t css-scratch-classes)
179 (setq css-scratch-classes nil))
180 (if (eq t css-scratch-class)
181 (setq css-scratch-class nil))
182 (while css-scratch-classes
183 (if (not (member (pop css-scratch-classes) css-scratch-class))
184 (setq css-scratch-class-match nil
185 css-scratch-classes nil)))
186 (cond
187 ((and (listp (car css-scratch-current-rule)) css-scratch-class-match)
188 ;; Contextual!
189 (setq css-scratch-current-rule (cdr css-scratch-current-rule))
190 (if (css-contextual-match css-scratch-current-rule element-stack)
191 (setq css-scratch-val
192 (append css-scratch-val css-scratch-current-value)))
193 )
194 (css-scratch-class-match
195 (setq css-scratch-val (append css-scratch-val css-scratch-current-value))
196 )
197 (t
198 nil))
199 )
200 )
201
202 (defsubst css-get (tag args &optional sheet element-stack)
203 (setq css-scratch-val nil
204 css-scratch-class (or (cdr-safe (assq 'class args)) t))
205
206 ;; check for things without the class
207 (if (listp css-scratch-class)
208 (css-get-internal tag nil))
209
210 ;; check for global class values
211 (css-get-internal '*document args)
212
213 ;; Now check for things with the class - they will be stuck on the front
214 ;; of the list, which will mean we do the right thing
215 (css-get-internal tag args)
216
217 ;; Defaults are up to the calling application to provide
218 css-scratch-val)
219
220 (defun css-ancestor-get (info ancestors sheet)
221 ;; Inheritable property, check ancestors
222 (let (cur)
223 (while ancestors
224 (setq cur (car ancestors)
225 css-scratch-val (css-get info (car cur) (cdr cur) sheet)
226 ancestors (if css-scratch-val nil (cdr ancestors)))))
227 css-scratch-val)
228
229 (defun css-split-selector (tag)
230 ;; Return a list
231 (cond
232 ((string-match " " tag) ; contextual
233 (let ((tags (split-string tag "[ \t]+"))
234 (result nil))
235 (while tags
236 (setq result (cons (css-split-selector (car tags)) result)
237 tags (cdr tags)))
238 result))
239 ((string-match "[:\\.]" tag)
240 (let ((tag (if (= (match-beginning 0) 0)
241 '*document
242 (intern (downcase (substring tag 0 (match-beginning 0))))))
243 (rest (substring tag (match-beginning 0) nil))
244 (classes nil))
245 (while (string-match "^[:\\.][^:\\.]+" rest)
246 (if (= ?. (aref rest 0))
247 (setq classes (cons (substring rest 1 (match-end 0)) classes))
248 (setq classes (cons (substring rest 0 (match-end 0)) classes)))
249 (setq rest (substring rest (match-end 0) nil)))
250 (setq classes (sort classes 'string-lessp))
251 (cons tag classes)))
252 ((string-match "^#" tag) ; id selector
253 (cons '*document tag))
254 (t
255 (cons (intern (downcase tag)) t)
256 )
257 )
258 )
259
260 (defun css-applies-to (st nd)
261 (let ((results nil)
262 (save-pos nil))
263 (narrow-to-region st nd)
264 (goto-char st)
265 (skip-chars-forward " \t\r\n")
266 (while (not (eobp))
267 (setq save-pos (point))
268 (skip-chars-forward "^,")
269 (skip-chars-backward " \r\t\n")
270 (setq results (cons (css-split-selector
271 (buffer-substring save-pos (point))) results))
272 (skip-chars-forward ", \t\r\n"))
273 (widen)
274 results))
275
276 (defun css-split-font-shorthand (font)
277 ;; [<font-weight> || <font-style>]? <font-size> [ / <line-height> ]? <font-family>
278 (let (weight size height family retval)
279 (if (not (string-match " *\\([0-9.]+[^ /]+\\)" font))
280 (error "Malformed font shorthand: %s" font))
281 (setq weight (if (/= 0 (match-beginning 0))
282 (substring font 0 (match-beginning 0)))
283 size (match-string 1 font)
284 font (substring font (match-end 0) nil))
285 (if (string-match " */ *\\([^ ]+\\) *" font)
286 ;; they specified a line-height as well
287 (setq height (match-string 1 font)
288 family (substring font (match-end 0) nil))
289 (if (string-match "^[ \t]+" font)
290 (setq family (substring font (match-end 0) nil))
291 (setq family font)))
292 (if weight (setq retval (cons (cons 'font-weight weight) retval)))
293 (if size (setq retval (cons (cons 'font-size size) retval)))
294 (if height (setq retval (cons (cons 'line-height height) retval)))
295 (if family (setq retval (cons (cons 'font-family family) retval)))
296 retval))
297
298 (defun css-expand-length (spec)
299 (cond
300 ((not (stringp spec)) spec)
301 ((string-equal spec "auto") nil)
302 ((string-match "\([0-9]+\)%" spec) ; A percentage
303 nil)
304 ((string-match "\([0-9]+\)e[mn]" spec) ; Character based
305 (string-to-int (substring spec (match-beginning 1) (match-end 1))))
306 (t
307 (truncate (font-spatial-to-canonical spec)))
308 )
309 )
310
311 (defsubst css-unhex-char (x)
312 (if (> x ?9)
313 (if (>= x ?a)
314 (+ 10 (- x ?a))
315 (+ 10 (- x ?A)))
316 (- x ?0)))
317
318 (defsubst css-pow (x n)
319 (apply '* (make-list n x)))
320
321 (defun css-unhex (x)
322 (let ((ord (length x))
323 (rval 0))
324 (while (> ord 0)
325 (setq rval (+ rval
326 (* (css-pow 16 (- (length x) ord))
327 (css-unhex-char (aref x (1- ord)))))
328 ord (1- ord)))
329 rval))
330
331 (defun css-expand-color (color)
332 (cond
333 ((string-match "^#" color)
334 (let (r g b)
335 (cond
336 ((string-match "^#...$" color)
337 ;; 3-char rgb spec, expand out to six chars by replicating
338 ;; digits, not adding zeros.
339 (setq r (css-unhex (make-string 2 (aref color 1)))
340 g (css-unhex (make-string 2 (aref color 2)))
341 b (css-unhex (make-string 2 (aref color 3)))))
342 ((string-match "^#\\(..\\)\\(..\\)\\(..\\)$" color)
343 (setq r (css-unhex (match-string 1 color))
344 g (css-unhex (match-string 2 color))
345 b (css-unhex (match-string 3 color))))
346 (t
347 (setq color (substring color 1))
348 (let* ((n (/ (length color) 3))
349 (max (float (css-pow 16 n))))
350 (setq r (css-unhex (substring color 0 n))
351 g (css-unhex (substring color n (* n 2)))
352 b (css-unhex (substring color (* n 2) (* n 3)))
353 r (round (* (/ r max) 255))
354 g (round (* (/ g max) 255))
355 b (round (* (/ b max) 255))))))
356 (setq color (vector 'rgb r g b))))
357 ((string-match "^rgb *( *\\([0-9]+\\)[, ]+\\([0-9]+\\)[, ]+\\([0-9]+\\) *) *$" color)
358 ;; rgb(r,g,b) 0 - 255, cutting off at 255
359 (setq color (vector
360 'rgb
361 (min (string-to-int (match-string 1 color)) 255)
362 (min (string-to-int (match-string 2 color)) 255)
363 (min (string-to-int (match-string 3 color)) 255))))
364 ((string-match "^rgb *( *\\([0-9]+\\) *%[, ]+\\([0-9]+\\) *%[, ]+\\([0-9]+\\) *% *) *$" color)
365 ;; rgb(r%,g%,b%) 0 - 100%, cutting off at 100%
366 (let ((r (min (string-to-number (match-string 1 color)) 100.0))
367 (g (min (string-to-number (match-string 2 color)) 100.0))
368 (b (min (string-to-number (match-string 3 color)) 100.0)))
369 (setq r (round (* r 2.55))
370 g (round (* g 2.55))
371 b (round (* b 2.55))
372 color (vector 'rgb r g b))))
373 ((string-match "url *(\\([^ )]+\\) *)" color)
374 ;; A picture in the background
375 (let ((pixmap (match-string 1 color))
376 (attributes nil))
377 (setq color (concat (substring color 0 (match-beginning 0))
378 (substring color (match-end 0) nil))
379 attributes (split-string color " "))
380 )
381 )
382 (t
383 ;; Hmmm... pass it through unmangled and hope the underlying
384 ;; windowing system can handle it.
385 )
386 )
387 color
388 )
389
390 (defun css-expand-value (type value)
391 (case type
392 ((symbol integer) ; Read it in
393 (setq value (read (downcase value))))
394 (symbol-list
395 (setq value (downcase value)
396 value (split-string value "[ ,]+")
397 value (mapcar 'intern value)))
398 (string-list
399 (setq value (split-string value " *, *")))
400 (color ; A color, possibly with URLs
401 (setq value (css-expand-color value)))
402 (length ; Pixels, picas, ems, etc.
403 (setq value (css-expand-length value)))
404 (font ; Font shorthand
405 (setq value (css-split-font-shorthand value)))
406 ((margin padding) ; length|percentage|auto {1,4}
407 (setq value (split-string value "[ ,]+"))
408 (if (/= 1 (length value))
409 ;; More than one value - a shortcut
410 (let* ((top (intern (format "%s-top" type)))
411 (bottom (intern (format "%s-bottom" type)))
412 (left (intern (format "%s-left" type)))
413 (right (intern (format "%s-right" type))))
414 (setq top (cons top (css-expand-length (nth 0 value)))
415 right (cons right (css-expand-length (nth 1 value)))
416 bottom (cons bottom (css-expand-length (nth 2 value)))
417 left (cons left (css-expand-length (nth 3 value)))
418 value (list top right bottom left)))
419 (setq value (css-expand-length (car value)))))
420 (border
421 (cond
422 ((member (downcase value) '("none" "dotted" "dashed" "solid"
423 "double" "groove" "ridge" "inset" "outset"))
424 (setq value (intern (downcase value))))
425 ((string-match "^[0-9]+" value)
426 (setq value (font-spatial-to-canonical value)))
427 (t nil)))
428 (weight ; normal|bold|bolder|lighter|[1-9]00
429 (if (string-match "^[0-9]+" value)
430 (setq value (/ (read value) 100)
431 value (or (nth value css-weights) :bold))
432 (setq value (intern (downcase (concat ":" value))))))
433 (otherwise ; Leave it as is
434 t)
435 )
436 value
437 )
438
439 (defun css-parse-args (st &optional nd)
440 ;; Return an assoc list of attribute/value pairs from a CSS style entry
441 (let (
442 name ; From name=
443 value ; its value
444 results ; Assoc list of results
445 name-pos ; Start of XXXX= position
446 val-pos ; Start of value position
447 )
448 (save-excursion
449 (if (stringp st)
450 (progn
451 (set-buffer (get-buffer-create " *css-style-temp*"))
452 (set-syntax-table css-syntax-table)
453 (erase-buffer)
454 (insert st)
455 (setq st (point-min)
456 nd (point-max)))
457 (set-syntax-table css-syntax-table))
458 (save-restriction
459 (narrow-to-region st nd)
460 (goto-char (point-min))
461 (while (not (eobp))
462 (skip-chars-forward ";, \n\t")
463 (setq name-pos (point))
464 (skip-chars-forward "^ \n\t:=,;")
465 (downcase-region name-pos (point))
466 (setq name (intern (buffer-substring name-pos (point))))
467 (skip-chars-forward " \t\n")
468 (if (not (eq (char-after (point)) ?:)) ; There is no value
469 (setq value nil)
470 (skip-chars-forward " \t\n:")
471 (setq val-pos (point)
472 value
473 (cond
474 ((or (= (or (char-after val-pos) 0) ?\")
475 (= (or (char-after val-pos) 0) ?'))
476 (buffer-substring (1+ val-pos)
477 (condition-case ()
478 (prog2
479 (forward-sexp 1)
480 (1- (point))
481 (skip-chars-forward "\""))
482 (error
483 (skip-chars-forward "^ \t\n")
484 (point)))))
485 (t
486 (buffer-substring val-pos
487 (progn
488 (if css-ie-compatibility
489 (skip-chars-forward "^;")
490 (skip-chars-forward "^,;"))
491 (skip-chars-backward " \t")
492 (point)))))))
493 (setq value (css-expand-value (get name 'css-type) value))
494 (if (eq (get name 'css-type) 'font)
495 (setq results (append value results))
496 (setq results (cons (cons name value) results)))
497 (skip-chars-forward ";, \n\t"))
498 results))))
499
500 (defun css-handle-import ()
501 (let ((url nil)
502 (save-pos (point)))
503 (if (looking-at "'\"")
504 (condition-case ()
505 (forward-sexp 1)
506 (error (skip-chars-forward "^ \t\r\n;")))
507 (skip-chars-forward "^ \t\r\n;"))
508 (setq url (url-expand-file-name (buffer-substring save-pos (point))))
509 (skip-chars-forward "\"; \t\r\n")
510 (setq save-pos (point))
511 (let ((url-working-buffer (generate-new-buffer-name " *styleimport*"))
512 (url-mime-accept-string
513 "text/css ; level=2")
514 (sheet nil))
515 (save-excursion
516 (set-buffer (get-buffer-create url-working-buffer))
517 (setq url-be-asynchronous nil)
518 (url-retrieve url)
519 (css-clean-buffer)
520 (setq sheet (buffer-string))
521 (set-buffer-modified-p nil)
522 (kill-buffer (current-buffer)))
523 (insert sheet)
524 (goto-char save-pos))))
525
526 (defun css-clean-buffer ()
527 ;; Nuke comments, etc.
528 (goto-char (point-min))
529 (let ((save-pos nil))
530 (while (search-forward "/*" nil t)
531 (setq save-pos (- (point) 2))
532 (delete-region save-pos
533 (if (search-forward "*/" nil t)
534 (point)
535 (end-of-line)
536 (point)))))
537 (goto-char (point-min))
538 (delete-matching-lines "^[ \t\r]*$") ; Nuke blank lines
539 (css-replace-regexp "^[ \t\r]+" "") ; Nuke whitespace at beg. of line
540 (css-replace-regexp "[ \t\r]+$" "") ; Nuke whitespace at end of line
541 (goto-char (point-min)))
542
543 (defun css-active-device-types (&optional device)
544 (let ((types (list 'normal 'default (if css-running-xemacs 'xemacs 'emacs)))
545 (type (device-type device)))
546 (cond
547 ((featurep 'emacspeak)
548 (setq types (cons 'speech types)))
549 ((eq type 'tty)
550 (if (and (fboundp 'tty-color-list)
551 (/= 0 (length (tty-color-list))))
552 (setq types (cons 'ansi-tty types))
553 (setq types (cons 'tty types))))
554 ((eq 'color (device-class))
555 (if (not (device-bitplanes))
556 (setq types (cons 'color types))
557 (setq types
558 (append
559 (list (intern (format "%dbit-color"
560 (device-bitplanes)))
561 (intern (format "%dbit"
562 (device-bitplanes)))
563 'color) types))
564 (if (= 24 (device-bitplanes))
565 (setq types (cons 'truecolor types)))))
566 ((eq 'grayscale (device-class))
567 (setq types (append (list (intern (format "%dbit-grayscale"
568 (device-bitplanes)))
569 'grayscale)
570 types)))
571 ((eq 'mono (device-class))
572 (setq types (append (list 'mono 'monochrome) types)))
573 (t
574 (setq types (cons 'unknown types))))
575 types))
576
577 (defmacro css-rule-specificity-internal (rule)
578 (`
579 (progn
580 (setq tmp (cdr (, rule)))
581 (if (listp tmp)
582 (while tmp
583 (if (= ?# (aref (car tmp) 0))
584 (incf a)
585 (incf b))
586 (setq tmp (cdr tmp)))))))
587
588 (defsubst css-specificity (rule)
589 ;; To find specificity, according to the september 1996 CSS draft
590 ;; a = # of ID attributes in the selector
591 ;; b = # of class attributes in the selector
592 ;; c = # of tag names in the selector
593 (let ((a 0) (b 0) (c 0) cur tmp)
594 (if (not (listp (car rule)))
595 (css-rule-specificity-internal rule)
596 (setq c (length rule))
597 (while rule
598 (css-rule-specificity-internal (pop rule))))
599 (+ (* 100 a) (* 10 b) c)
600 )
601 )
602
603 (defun css-copy-stylesheet (sheet)
604 (let ((new (make-hash-table :size (hash-table-count sheet))))
605 (cl-maphash
606 (function
607 (lambda (k v)
608 (cl-puthash k (copy-tree v) new))) sheet)
609 new))
610
611 (defsubst css-store-rule (attrs applies-to)
612 (declare (special sheet))
613 (let (rules cur tag node)
614 (while applies-to
615 (setq cur (pop applies-to)
616 tag (car cur))
617 (if (listp tag)
618 (setq tag (car tag)))
619 (setq rules (cl-gethash tag sheet))
620 (cond
621 ((null rules)
622 ;; First rule for this tag. Create new ruleset
623 (cl-puthash tag (list (cons cur attrs)) sheet))
624 ((setq node (assoc cur rules))
625 ;; Similar rule already exists, splice in our information
626 (setcdr node (append attrs (cdr node))))
627 (t
628 ;; First rule for this particular combination of tag/ancestors/class.
629 ;; Slap it onto the existing set of rules and push back into sheet.
630 (setq rules (cons (cons cur attrs) rules))
631 (cl-puthash tag rules sheet))
632 )
633 )
634 )
635 )
636
637 (defun css-parse (fname &optional string inherit)
638 (let (
639 (url-mime-accept-string
640 "text/css ; level=2")
641 (save-pos nil)
642 (applies-to nil) ; List of tags to apply style to
643 (attrs nil) ; List of name/value pairs
644 (att nil)
645 (cur nil)
646 (val nil)
647 (device-type nil)
648 (active-device-types (css-active-device-types (selected-device)))
649 (sheet inherit))
650 (if (not sheet)
651 (setq sheet (make-hash-table :size 13 :test 'eq)))
652 (save-excursion
653 (set-buffer (get-buffer-create
654 (generate-new-buffer-name " *style*")))
655 (set-syntax-table css-syntax-table)
656 (erase-buffer)
657 (if fname (url-insert-file-contents fname))
658 (goto-char (point-max))
659 (if string (insert string))
660 (css-clean-buffer)
661 (goto-char (point-min))
662 (while (not (eobp))
663 (setq save-pos (point))
664 (cond
665 ;; *sigh* SGML comments are being used to 'hide' data inlined
666 ;; with the <style> tag from older browsers.
667 ((or (looking-at "<!--+") ; begin
668 (looking-at "--+>")) ; end
669 (goto-char (match-end 0)))
670 ;; C++ style comments, and we are doing IE compatibility
671 ((and (looking-at "//") css-ie-compatibility)
672 (end-of-line))
673 ;; Pre-Processor directives
674 ((looking-at "[ \t\r]*@\\([^ \t\r\n]\\)")
675 (let ((directive nil))
676 (skip-chars-forward " @\t\r") ; Past any leading whitespace
677 (setq save-pos (point))
678 (skip-chars-forward "^ \t\r\n") ; Past the @ directive
679 (downcase-region save-pos (point))
680 (setq directive (buffer-substring save-pos (point)))
681 (skip-chars-forward " \t\r") ; Past any trailing whitespace
682 (setq save-pos (point))
683 (cond
684 ((string= directive "import")
685 (css-handle-import))
686 (t
687 (message "Unknown directive in stylesheet: @%s" directive)))))
688 ;; Giving us some output device information
689 ((looking-at "[ \t\r]*:\\([^: \n]+\\):")
690 (downcase-region (match-beginning 1) (match-end 1))
691 (setq device-type (intern (buffer-substring (match-beginning 1)
692 (match-end 1))))
693 (goto-char (match-end 0))
694 (if (not (memq device-type active-device-types))
695 ;; Not applicable to us... skip the info
696 (progn
697 (if (re-search-forward ":[^:{ ]*:" nil t)
698 (goto-char (match-beginning 0))
699 (goto-char (point-max))))))
700 ;; Default is to treat it like a stylesheet declaration
701 (t
702 (skip-chars-forward "^{")
703 ;;(downcase-region save-pos (point))
704 (setq applies-to (css-applies-to save-pos (point)))
705 (skip-chars-forward "^{")
706 (setq save-pos (point))
707 (condition-case ()
708 (forward-sexp 1)
709 (error (goto-char (point-max))))
710 (end-of-line)
711 (skip-chars-backward "\r}")
712 (subst-char-in-region save-pos (point) ?\n ? )
713 (subst-char-in-region save-pos (point) ?\r ? )
714 ;; This is for not choking on garbage at the end of the buffer.
715 ;; I get bit by this every once in a while when going through my
716 ;; socks gateway.
717 (if (eobp)
718 nil
719 (setq attrs (css-parse-args (1+ save-pos) (point)))
720 (skip-chars-forward "}\r\n")
721 (css-store-rule attrs applies-to))
722 )
723 )
724 (skip-chars-forward " \t\r\n"))
725 (set-buffer-modified-p nil)
726 (kill-buffer (current-buffer)))
727 sheet)
728 )
729
730 ;; Tools for pretty-printing an existing stylesheet.
731 (defun css-rule-name (rule)
732 (cond
733 ((listp (car rule)) ; Contextual
734 (mapconcat 'css-rule-name
735 (reverse rule) " "))
736 ((listp (cdr rule)) ; More than one class
737 (let ((classes (cdr rule))
738 (rval (symbol-name (car rule))))
739 (while classes
740 (setq rval (concat rval
741 (if (= (aref (car classes) 0) ?:)
742 (pop classes)
743 (concat "." (pop classes))))))
744 rval))
745 (t
746 (symbol-name (car rule)))))
747
748 (defun css-display (sheet)
749 (with-output-to-temp-buffer "CSS Stylesheet"
750 (set-buffer standard-output)
751 (indented-text-mode)
752 (insert "# Stylesheet auto-regenerated by css.el\n#\n"
753 "# This is a mixture of the default stylesheet and any\n"
754 "# styles specified by the document. The rules are in no\n"
755 "# particular order.\n\n")
756 (let (tmp cur goal-col)
757 (cl-maphash
758 (function
759 (lambda (k v)
760 (while v
761 (setq cur (pop v))
762 (insert (css-rule-name (car cur)))
763 (insert " { ")
764 (setq goal-col (point))
765 (insert "\n")
766 ;; Display the rules
767 (setq tmp (cdr cur))
768 (let (prop val)
769 (while tmp
770 (setq prop (caar tmp)
771 val (cdar tmp)
772 tmp (cdr tmp))
773 (case (get prop 'css-type)
774 (symbol-list
775 (setq val (mapconcat 'symbol-name val ",")))
776 (weight
777 (setq val (substring (symbol-name val) 1 nil)))
778 (otherwise
779 nil)
780 )
781 (insert (format " %s: %s;\n" prop val))))
782 (insert "}\n\n");
783 )))
784 sheet))))
785
786 (provide 'css)