1 ;;; css.el -- Cascading Style Sheet parser
2 ;; Author: $Author: legoscia $
3 ;; Created: $Date: 2007/11/15 12:28:29 $
4 ;; Version: $Revision: 1.12 $
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1996, 97, 98, 1999, 2000, 2001, 2007 Free Software Foundation, Inc.
9 ;;; Copyright (c) 1996 by William M. Perry <wmperry@cs.indiana.edu>
11 ;;; This file is part of GNU Emacs.
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.
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.
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.
28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
33 (autoload 'url-expand-file-name "url-expand")
34 (autoload 'url-insert-file-contents "url-handlers")
35 (autoload 'url-view-url "url-util")
37 (if (not (fboundp 'frame-char-height))
38 (defun frame-char-height (&optional frame)
39 "Height in pixels of a line in the font in frame FRAME.
40 If FRAME is omitted, the selected frame is used.
41 For a terminal frame, the value is always 1."
42 (font-height (face-font 'default frame))))
44 (if (not (fboundp 'frame-char-width))
45 (defun frame-char-width (&optional frame)
46 "Width in pixels of characters in the font in frame FRAME.
47 If FRAME is omitted, the selected frame is used.
48 For a terminal screen, the value is always 1."
49 (font-width (face-font 'default frame))))
51 ;; CBI = Cant Be Implemented - due to limitations in emacs/xemacs
52 ;; NYI = Not Yet Implemented - due to limitations of space/time
53 ;; NYPI = Not Yet Partially Implemented - possible partial support, eventually
55 (defconst css-properties
56 '(;; Property name Inheritable? Type of data
57 ;; Base CSS level 1 properties: http://www.w3.org/pub/WWW/TR/REC-CSS1
58 ;; Font properties, Section 5.2
59 [font-family t string-list]
61 [font-variant t symbol]
62 [font-weight t weight]
66 ;; Color and background properties, Section 5.3
68 [background nil color-shorthand]
69 [background-color nil color]
70 [background-image nil url] ; NYI
71 [background-repeat nil symbol] ; CBI
72 [background-attachment nil symbol] ; CBI
73 [background-position nil symbol] ; CBI
75 ;; Text properties, Section 5.4
76 [word-spacing t length] ; CBI
77 [letter-spacing t length] ; CBI
78 [text-decoration t symbol-list]
79 [vertical-align nil symbol]
80 [text-transform t symbol]
82 [text-indent t length] ; NYI
83 [line-height t length] ; CBI
85 ;; Box properties, Section 5.5
86 [margin nil boundary-shorthand]
87 [margin-left nil length]
88 [margin-right nil length]
89 [margin-top nil length]
90 [margin-bottom nil length]
91 [padding nil boundary-shorthand]
92 [padding-left nil length]
93 [padding-right nil length]
94 [padding-top nil length]
95 [padding-bottom nil length]
96 [border nil border-shorthand]
97 [border-left nil border]
98 [border-right nil border]
99 [border-top nil border]
100 [border-bottom nil border]
101 [border-top-width nil nil]
102 [border-right-width nil nil]
103 [border-bottom-width nil nil]
104 [border-left-width nil nil]
105 [border-width nil boundary-shorthand]
106 [border-color nil color]
107 [border-style nil symbol]
108 [width nil length] ; NYPI
109 [height nil length] ; NYPI
113 ;; Classification properties, Section 5.6
115 [list-style-type t symbol]
116 [list-style-image t url]
117 [list-style-position t symbol]
118 [list-style nil list-style]
119 [white-space t symbol]
121 ;; These are for specifying speech properties (ACSS-style)
122 ;; http://www.w3.org/pub/WWW/Style/CSS/Speech/NOTE-ACSS
124 ;; General audio properties, Section 3
125 [volume t string] ; Needs its own type?
126 [pause-before nil time]
127 [pause-after nil time]
129 [cue-before nil string]
130 [cue-after nil string]
131 [cue-during nil string]
132 [cue nil string] ; Needs its own type?
134 ;; Spatial properties, Section 4
136 [elevation t elevation]
138 ;; Speech properties, Section 5
140 [voice-family t string-list]
142 [pitch-range t percentage]
143 [stress t percentage]
144 [richness t percentage]
145 [speak-punctuation t symbol]
146 [speak-date t symbol]
147 [speak-numeral t symbol]
148 [speak-time t symbol]
150 ;; Proposed printing extensions
151 ;; http://www.w3.org/pub/WWW/Style/Group/WD-PRINT-961220
152 ;; These apply only to pages (@page directive)
154 [orientation nil symbol]
155 [margin-inside nil length]
156 ;; These apply to the document
157 [page-break-before nil symbol]
158 [page-break-after nil symbol]
160 ;; These are for specifying speech properties (Raman-style)
161 [voice-family t string]
163 [left-volume t integer]
164 [right-volume t integer]
166 [pitch-range t integer]
170 "A description of the various CSS properties and how to interpret them.")
172 (put 'font 'css-shorthand t)
173 (put 'background 'css-shorthand t)
174 (put 'margin 'css-shorthand t)
175 (put 'padding 'css-shorthand t)
176 (put 'border 'css-shorthand t)
177 (put 'list-style 'css-shorthand t)
181 (put (aref entry 0) 'css-inherit (aref entry 1))
182 (put (aref entry 0) 'css-type (aref entry 2)))
185 (defconst css-weights
196 "List of CSS font weights.")
198 (defvar css-syntax-table
199 (copy-syntax-table emacs-lisp-mode-syntax-table)
200 "The syntax table for parsing stylesheets")
202 (modify-syntax-entry ?' "\"" css-syntax-table)
203 (modify-syntax-entry ?` "\"" css-syntax-table)
204 (modify-syntax-entry ?{ "(" css-syntax-table)
205 (modify-syntax-entry ?} ")" css-syntax-table)
208 (defvar css-scratch-val nil)
209 (defvar css-scratch-id nil)
210 (defvar css-scratch-class nil)
211 (defvar css-scratch-possibles nil)
212 (defvar css-scratch-current nil)
213 (defvar css-scratch-classes nil)
214 (defvar css-scratch-class-match nil)
215 (defvar css-scratch-current-rule nil)
216 (defvar css-scratch-current-value nil)
219 (defsubst css-replace-regexp (regexp to-string)
220 (goto-char (point-min))
221 (while (re-search-forward regexp nil t)
222 (replace-match to-string t nil)))
224 (defun css-contextual-match (rule stack)
231 (setq p-tag (caar rule)
232 ancestor (assq p-tag stack))
234 (*document ; Class matching only
236 (while (setq ancestor (car stack))
237 (setq stack (cdr stack)
238 p-args (cdr ancestor)
239 p-class (or (cdr-safe (assq 'class p-args)) t))
240 (if (equal p-class (cdar rule))
248 (setq p-args (cdr ancestor)
249 p-class (or (cdr-safe (assq 'class p-args)) t))
250 (if (not (equal p-class (cdar rule)))
253 (setq rule (cdr rule)))
256 (defsubst css-get-internal (tag args)
257 (declare (special tag sheet element-stack default))
258 (setq css-scratch-id (or (cdr-safe (assq 'id args))
259 (cdr-safe (assq 'name args)))
260 css-scratch-class (or (cdr-safe (assq 'class args)) t)
261 css-scratch-possibles (gethash tag sheet))
262 (while css-scratch-possibles
263 (setq css-scratch-current (car css-scratch-possibles)
264 css-scratch-current-rule (car css-scratch-current)
265 css-scratch-current-value (cdr css-scratch-current)
266 css-scratch-classes (if (listp (car css-scratch-current-rule))
267 (cdar css-scratch-current-rule)
268 (cdr css-scratch-current-rule))
269 css-scratch-class-match t
270 css-scratch-possibles (cdr css-scratch-possibles))
271 (if (eq t css-scratch-classes)
272 (setq css-scratch-classes nil))
273 (if (eq t css-scratch-class)
274 (setq css-scratch-class nil))
275 (while css-scratch-classes
276 (if (not (member (pop css-scratch-classes) css-scratch-class))
277 (setq css-scratch-class-match nil
278 css-scratch-classes nil)))
280 ((and (listp (car css-scratch-current-rule)) css-scratch-class-match)
282 (setq css-scratch-current-rule (cdr css-scratch-current-rule))
283 (if (css-contextual-match css-scratch-current-rule element-stack)
284 (setq css-scratch-val
285 (append css-scratch-val css-scratch-current-value)))
287 (css-scratch-class-match
288 (setq css-scratch-val (append css-scratch-val css-scratch-current-value))
295 (defsubst css-get (tag args &optional sheet element-stack)
296 (setq css-scratch-val nil
297 css-scratch-class (or (cdr-safe (assq 'class args)) t))
299 ;; check for things without the class
300 (if (listp css-scratch-class)
301 (css-get-internal tag nil))
303 ;; check for global class values
304 (css-get-internal '*document args)
306 ;; Now check for things with the class - they will be stuck on the front
307 ;; of the list, which will mean we do the right thing
308 (css-get-internal tag args)
310 ;; Defaults are up to the calling application to provide
313 (defun css-ancestor-get (info ancestors sheet)
314 ;; Inheritable property, check ancestors
317 (setq cur (car ancestors)
318 css-scratch-val (css-get info (car cur) (cdr cur) sheet)
319 ancestors (if css-scratch-val nil (cdr ancestors)))))
322 (defun css-split-selector (tag)
325 ((string-match " " tag) ; contextual
326 (let ((tags (split-string tag "[ \t]+"))
329 (setq result (cons (css-split-selector (car tags)) result)
332 ((string-match "[:\\.]" tag)
333 (let ((tag (if (= (match-beginning 0) 0)
335 (intern (downcase (substring tag 0 (match-beginning 0))))))
336 (rest (substring tag (match-beginning 0) nil))
338 (while (string-match "^[:\\.][^:\\.]+" rest)
339 (if (= ?. (aref rest 0))
340 (setq classes (cons (substring rest 1 (match-end 0)) classes))
341 (setq classes (cons (substring rest 0 (match-end 0)) classes)))
342 (setq rest (substring rest (match-end 0) nil)))
343 (setq classes (sort classes 'string-lessp))
345 ((string-match "^#" tag) ; id selector
346 (cons '*document (list tag)))
348 (cons (intern (downcase tag)) t)
353 (defun css-applies-to (st nd)
356 (narrow-to-region st nd)
358 (skip-chars-forward " \t\r\n")
360 (setq save-pos (point))
361 (skip-chars-forward "^,")
362 (skip-chars-backward " \r\t\n")
363 (setq results (cons (css-split-selector
364 (buffer-substring save-pos (point))) results))
365 (skip-chars-forward ", \t\r\n"))
369 (defun css-split-font-shorthand (font)
370 ;; [<font-weight> || <font-style>]? <font-size> [ / <line-height> ]? <font-family>
371 (let (weight size height family retval)
372 (if (not (string-match " *\\([0-9.]+[^ /]+\\)" font))
374 (message "Malformed font shorthand: %s" font)
376 (setq weight (if (/= 0 (match-beginning 0))
377 (substring font 0 (match-beginning 0)))
378 size (match-string 1 font)
379 font (substring font (match-end 0) nil))
380 (if (string-match " */ *\\([^ ]+\\) *" font)
381 ;; they specified a line-height as well
382 (setq height (match-string 1 font)
383 family (substring font (match-end 0) nil))
384 (if (string-match "^[ \t]+" font)
385 (setq family (substring font (match-end 0) nil))
388 (push (cons 'font-weight (css-expand-value 'weight weight)) retval))
390 (push (cons 'font-size (css-expand-length size)) retval))
392 (push (cons 'line-height (css-expand-length height t)) retval))
394 (push (cons 'font-family (css-expand-value 'string-list family)) retval))
397 (if (not (fboundp 'frame-char-height))
398 (defun frame-char-height (&optional frame)
399 "Height in pixels of a line in the font in frame FRAME.
400 If FRAME is omitted, the selected frame is used.
401 For a terminal frame, the value is always 1."
402 (font-height (face-font 'default frame))))
404 (defun css-expand-length (spec &optional height)
406 ((not (stringp spec)) spec)
407 ((string-equal spec "auto") nil)
408 ((and (string-match "\\([+-]?\\([0-9]+\\|[0-9]*\\.[0-9]+\\)\\)%" spec)
409 (fboundp 'frame-char-height))
411 ;; XXX: should be relative to encosing element
412 (setq spec (/ (string-to-int (match-string 1 spec)) 100.0))
414 (round (* (frame-char-height) spec))
415 (max 0 (round (* (frame-char-width) spec)))))
416 ((string-match "\\([+-]?\\([0-9]+\\|[0-9]*\\.[0-9]+\\)\\)%" spec)
417 ;; No frame-char-width/height
418 (setq spec (/ (string-to-int (match-string 1 spec)) 100.0))
420 (max 0 (round (* (/ (frame-pixel-height) (frame-height)) spec)))
421 (max 0 (round (* (/ (frame-pixel-width) (frame-width)) spec)))))
422 ((string-match "\\([+-]?\\([0-9]+\\|[0-9]*\\.[0-9]+\\)\\)e[mx]" spec)
424 ;; XXX: should be relative to font size of enclosing element
425 (round (font-spatial-to-canonical
426 (concat (number-to-string
427 (* (string-to-number (match-string 1 spec))
428 (if height (frame-char-height) (frame-char-width))))
431 (truncate (font-spatial-to-canonical spec)))
435 (defsubst css-unhex-char (x)
442 (defsubst css-pow (x n)
443 (apply '* (make-list n x)))
446 (let ((ord (length x))
450 (* (css-pow 16 (- (length x) ord))
451 (css-unhex-char (aref x (1- ord)))))
455 (defmacro css-symbol-list-as-regexp (&rest keys)
458 (mapconcat 'symbol-name
462 (defun css-expand-color (color)
465 ((string-match "^\\(transparent\\|none\\)$" color)
467 ((string-match "^#" color)
470 ((string-match "^#...$" color)
471 ;; 3-char rgb spec, expand out to six chars by replicating
472 ;; digits, not adding zeros.
473 (setq r (css-unhex (make-string 2 (aref color 1)))
474 g (css-unhex (make-string 2 (aref color 2)))
475 b (css-unhex (make-string 2 (aref color 3)))))
476 ((string-match "^#\\(..\\)\\(..\\)\\(..\\)$" color)
477 (setq r (css-unhex (match-string 1 color))
478 g (css-unhex (match-string 2 color))
479 b (css-unhex (match-string 3 color))))
481 (setq color (substring color 1))
482 (let* ((n (/ (length color) 3))
483 (max (float (css-pow 16 n))))
484 (setq r (css-unhex (substring color 0 n))
485 g (css-unhex (substring color n (* n 2)))
486 b (css-unhex (substring color (* n 2) (* n 3)))
487 r (round (* (/ r max) 255))
488 g (round (* (/ g max) 255))
489 b (round (* (/ b max) 255))))))
490 (setq color (vector 'rgb r g b))))
491 ((string-match "^rgb *( *\\([0-9]+\\)[, ]+\\([0-9]+\\)[, ]+\\([0-9]+\\) *) *$" color)
492 ;; rgb(r,g,b) 0 - 255, cutting off at 255
495 (min (string-to-int (match-string 1 color)) 255)
496 (min (string-to-int (match-string 2 color)) 255)
497 (min (string-to-int (match-string 3 color)) 255))))
498 ((string-match "^rgb *( *\\([0-9]+\\) *%[, ]+\\([0-9]+\\) *%[, ]+\\([0-9]+\\) *% *) *$" color)
499 ;; rgb(r%,g%,b%) 0 - 100%, cutting off at 100%
500 (let ((r (min (string-to-number (match-string 1 color)) 100.0))
501 (g (min (string-to-number (match-string 2 color)) 100.0))
502 (b (min (string-to-number (match-string 3 color)) 100.0)))
503 (setq r (round (* r 2.55))
506 color (vector 'rgb r g b))))
508 ;; Hmmm... pass it through unmangled and hope the underlying
509 ;; windowing system can handle it.
513 (w3-warn 'css (format "Couldn't interpret color value %s" color))
518 (defun css-expand-value (type value)
521 (length ; CSS, Section 6.1
522 (setq value (css-expand-length value)))
524 (setq value (css-expand-length value t)))
525 (percentage ; CSS, Section 6.2
526 (setq value (/ (string-to-number value)
527 (if (fboundp 'float) (float 100) 1))))
528 (color ; CSS, Section 6.3
529 (setq value (css-expand-color value)))
530 (url ; CSS, Section 6.4
531 (declare (special url purl))
532 ;; Potentially remove url(...) from around the URL
533 (if (string-match "url *(\\([^ )]+\\) *)" value)
534 (setq value (match-string 1 value)))
536 (if (string-match "\"\\([^\"]+\\)\"" value)
537 (setq value (match-string 1 value)))
539 (if (string-match " *\\([^ ]+\\) *" value)
540 (setq value (match-string 1 value)))
541 (setq value (url-expand-file-name value (or url purl))))
542 (angle ; ACSS, Section 2.2.1
544 (time ; ACSS, Section 2.2.2
545 (let ((val (string-to-number value))
547 (if (string-match "^[0-9]+ *\\([a-zA-Z.]+\\)" value)
548 (setq units (intern (downcase (match-string 1 value)))))
549 (setq value (case units
552 ((min minute minutes)
559 (/ val (float 1000)))))))
560 (elevation ; ACSS, Section 4.2
562 (css-symbol-list-as-regexp below level above higher lower) value)
563 (setq value (intern (downcase (match-string value 1)))
571 (setq value (css-expand-value 'angle value))))
572 (color-shorthand ; CSS, Section 5.3.7
573 ;; color|image|repeat|attach|position
574 (let ((keys (split-string value " +"))
575 cur color image repeat attach position)
576 (while (setq cur (pop keys))
578 ((string-match "url" cur) ; Only image can have a URL
579 (setq image (css-expand-value 'url cur)))
580 ((string-match "%" cur) ; Only position can have a perc.
581 (setq position (css-expand-value 'percentage cur)))
582 ((string-match "repeat" cur) ; Only repeat
583 (setq repeat (intern (downcase cur))))
584 ((string-match "scroll\\|fixed" cur)
585 (setq attach (intern (downcase (substring cur
588 ((string-match (css-symbol-list-as-regexp
589 top center bottom left right) cur)
592 (setq color (css-expand-value 'color cur)))))
593 (setq value (list (cons 'background-color color)
594 (cons 'background-image image)
595 (cons 'background-repeat repeat)
596 (cons 'background-attachment attach)
597 (cons 'background-position position)))))
598 (font ; CSS, Section 5.2.7
599 ;; [style | variant | weight]? size[/line-height]? family
600 (setq value (css-split-font-shorthand value)))
601 (border ; width | style | color
604 (border-shorthand ; width | style | color
607 (list-style ; CSS, Section 5.6.6
608 ;; keyword | position | url
609 (setq value (split-string value "[ ,]+"))
610 (if (= (length value) 1)
611 (setq value (list (cons 'list-style-type
612 (intern (downcase (car value))))))
613 (setq value (list (cons 'list-style-type
614 (css-expand-value 'symbol (nth 0 value)))
615 (cons 'list-style-position
616 (css-expand-value 'symbol (nth 1 value)))
617 (cons 'list-style-image
618 (css-expand-value 'url (nth 2 value)))))))
619 (boundary-shorthand ; CSS, Section 5.5.x
620 ;; length|percentage|auto {1,4}
621 (setq value (split-string value "[ ,]+"))
622 (let* ((top (intern (format "%s-top" type)))
623 (bottom (intern (format "%s-bottom" type)))
624 (left (intern (format "%s-left" type)))
625 (right (intern (format "%s-right" type))))
626 (setq top (cons top (css-expand-value (get top 'css-type)
628 right (cons right (css-expand-value (get right 'css-type)
630 bottom (cons bottom (css-expand-value (get bottom 'css-type)
632 left (cons left (css-expand-value (get left 'css-type)
634 value (list top right bottom left))))
635 (weight ; CSS, Section 5.2.5
636 ;; normal|bold|bolder|lighter|[1-9]00
638 ((string-match "^[0-9]+" value)
639 (setq value (/ (string-to-number value) 100)
640 value (or (nth value css-weights) :bold)))
641 ((string-match (css-symbol-list-as-regexp normal bold bolder lighter)
643 (setq value (intern (downcase (concat ":" value)))))
644 (t (setq value (intern ":normal")))))
645 ;; The rest of these deal with how we handle things internally
646 ((symbol integer) ; Read it in
647 (setq value (read (downcase value))))
648 (symbol-list ; A space/comma delimited symlist
649 (setq value (downcase value)
650 value (split-string value "[ ,]+")
651 value (mapcar 'intern value)))
652 (string-list ; A space/comma delimited list
653 (setq value (split-string value " *, *")))
654 (otherwise ; Leave it as is
661 (defun css-parse-args (st &optional nd)
662 ;; Return an assoc list of attribute/value pairs from a CSS style entry
666 results ; Assoc list of results
667 name-pos ; Start of XXXX= position
668 val-pos ; Start of value position
674 (set-buffer (get-buffer-create " *css-style-temp*"))
675 (set-syntax-table css-syntax-table)
680 (set-syntax-table css-syntax-table))
682 (narrow-to-region st nd)
683 (goto-char (point-min))
685 (skip-chars-forward ";, \n\t")
686 (setq name-pos (point))
687 (skip-chars-forward "^ \n\t:,;")
688 (downcase-region name-pos (point))
689 (setq name (intern (buffer-substring name-pos (point))))
690 (skip-chars-forward " \t\n")
691 (if (not (eq (char-after (point)) ?:)) ; There is no value
693 (skip-chars-forward " \t\n:")
694 (setq val-pos (point)
697 ((or (= (or (char-after val-pos) 0) ?\")
698 (= (or (char-after val-pos) 0) ?'))
699 (buffer-substring (1+ val-pos)
704 (skip-chars-forward "\""))
706 (skip-chars-forward "^ \t\n")
709 (buffer-substring val-pos
711 (skip-chars-forward "^;")
712 (skip-chars-backward " \t")
714 (setq value (css-expand-value (get name 'css-type) value))
715 (if (get name 'css-shorthand)
716 (setq results (append value results))
717 (setq results (cons (cons name value) results)))
718 (skip-chars-forward ";, \n\t"))
721 (defun css-handle-media-directive (data active)
723 (if (string-match "\\([^ \t\r\n{]+\\)" data)
724 (setq type (intern (downcase (substring data (match-beginning 1)
726 data (substring data (match-end 1)))
727 (setq type 'unknown))
728 (if (string-match "^[ \t\r\n]*{" data)
729 (setq data (substring data (match-end 0))))
730 (if (memq type active)
734 (defun css-handle-import (data)
735 (declare (special url-current-object purl))
737 (setq purl url-current-object)
738 (setq url (css-expand-value 'url data))
740 (let ((url-mime-accept-string "text/css ; level=2")
743 (set-buffer (generate-new-buffer " *styleimport*"))
744 ;; ftp/file URLs can signal an error.
746 (url-insert-file-contents url))
748 (setq sheet (buffer-string))
749 (set-buffer-modified-p nil)
750 (kill-buffer (current-buffer)))
753 (defun css-clean-buffer ()
754 ;; Nuke comments, etc.
755 (goto-char (point-min))
756 (let ((save-pos nil))
757 (while (search-forward "/*" nil t)
758 (setq save-pos (- (point) 2))
759 (delete-region save-pos
760 (if (search-forward "*/" nil t)
764 (goto-char (point-min))
765 (delete-matching-lines "^[ \t\r]*$") ; Nuke blank lines
766 (css-replace-regexp "^[ \t\r]+" "") ; Nuke whitespace at beg. of line
767 (css-replace-regexp "[ \t\r]+$" "") ; Nuke whitespace at end of line
768 (goto-char (point-min)))
770 (if (featurep 'xemacs)
771 (defun css-color-light-p (color-or-face)
774 ((or (facep color-or-face)
775 (and (symbolp color-or-face)
776 (find-face color-or-face)))
777 (setq color (specifier-instance (face-background color-or-face))))
778 ((color-instance-p color-or-face)
779 (setq color color-or-face))
780 ((color-specifier-p color-or-face)
781 (setq color (specifier-instance color-or-face)))
782 ((stringp color-or-face)
783 (setq color (make-color-instance color-or-face)))
784 (t (signal 'wrong-type-argument 'color-or-face-p)))
786 (not (< (apply '+ (color-instance-rgb-components color))
787 (/ (apply '+ (color-instance-rgb-components
788 (make-color-instance "white"))) 3)))
790 (defun css-color-values (color)
792 ((fboundp 'display-color-p)
793 (color-values color))
794 ((eq window-system 'x)
795 (x-color-values color))
796 ((eq window-system 'pm)
797 (pm-color-values color))
798 ((eq window-system 'ns)
799 (ns-color-values color))
801 (defun css-color-light-p (color-or-face)
804 ((null window-system)
806 ((facep color-or-face)
807 (setq color-or-face (face-background color-or-face))
808 (if (null color-or-face)
809 (setq color-or-face (cdr-safe
810 (assq 'background-color (frame-parameters)))))
811 (setq colors (css-color-values color-or-face)))
812 ((stringp color-or-face)
813 (setq colors (css-color-values color-or-face)))
814 ((font-rgb-color-p color-or-face)
815 (setq colors (list (font-rgb-color-red color-or-face)
816 (font-rgb-color-green color-or-face)
817 (font-rgb-color-blue color-or-face))))
819 (signal 'wrong-type-argument 'color-or-face-p)))
820 (not (< (apply '+ colors)
821 (/ (apply '+ (css-color-values "white")) 3)))))
824 (defun css-active-device-types (&optional device)
825 (let ((types (list 'all
826 (if (featurep 'xemacs) 'xemacs 'emacs)
827 (if (or (featurep 'xemacs)
828 (if (fboundp 'display-multi-font-p)
829 (display-multi-font-p)))
831 (if (css-color-light-p 'default) 'light 'dark)))
832 (type (device-type device)))
833 ;; For reasons I don't really want to get into, emacspeak and TTY
834 ;; are mutually exclusive for most of our purposes (insert-before,
836 (if (featurep 'emacspeak)
837 (setq types (cons 'speech types))
839 (setq types (cons 'tty types))))
841 ((eq 'color (device-class))
842 (if (not (device-bitplanes))
843 (setq types (cons 'color types))
846 (list (intern (format "%dbit-color"
848 (intern (format "%dbit"
851 (if (= 24 (device-bitplanes))
852 (setq types (cons 'truecolor types)))))
853 ((eq 'grayscale (device-class))
854 (setq types (append (list (intern (format "%dbit-grayscale"
858 ((eq 'mono (device-class))
859 (setq types (append (list 'mono 'monochrome) types)))
861 (setq types (cons 'unknown types))))
862 ;; FIXME: Remove me when the real 3.0 comes out
863 (if (and (memq 'tty types) (memq 'color types))
864 (setq types (cons 'ansi-tty types)))
867 (defmacro css-rule-specificity-internal (rule)
869 (setq tmp (cdr ,rule))
872 (if (= ?# (aref (car tmp) 0))
875 (setq tmp (cdr tmp))))))
877 (defsubst css-specificity (rule)
878 ;; To find specificity, according to the september 1996 CSS draft
879 ;; a = # of ID attributes in the selector
880 ;; b = # of class attributes in the selector
881 ;; c = # of tag names in the selector
882 (let ((a 0) (b 0) (c 0) tmp)
883 (if (not (listp (car rule)))
884 (css-rule-specificity-internal rule)
885 (setq c (length rule))
887 (css-rule-specificity-internal (pop rule))))
888 (+ (* 100 a) (* 10 b) c)
892 (defun css-copy-stylesheet (sheet)
893 (let ((new (make-hash-table :size (hash-table-count sheet))))
897 (puthash k (copy-tree v) new))) sheet)
900 (defsubst css-store-rule (attrs applies-to)
901 (declare (special sheet))
902 (let (rules cur tag node)
904 (setq cur (pop applies-to)
907 (setq tag (car tag)))
908 (setq rules (gethash tag sheet))
911 ;; First rule for this tag. Create new ruleset
912 (puthash tag (list (cons cur attrs)) sheet))
913 ((setq node (assoc cur rules))
914 ;; Similar rule already exists, splice in our information
915 (setcdr node (append attrs (cdr node))))
917 ;; First rule for this particular combination of tag/ancestors/class.
918 ;; Slap it onto the existing set of rules and push back into sheet.
919 (setq rules (cons (cons cur attrs) rules))
920 (puthash tag rules sheet))
926 (defun css-parse (url &optional string inherit)
927 (declare (special url-current-object purl))
929 (url-mime-accept-string
930 "text/css ; level=2")
932 (applies-to nil) ; List of tags to apply style to
933 (attrs nil) ; List of name/value pairs
935 (purl (url-view-url t))
936 (pobj url-current-object)
937 (active-device-types (css-active-device-types (selected-device)))
940 (setq sheet (make-hash-table :size 13 :test 'eq)))
942 (set-buffer (generate-new-buffer " *style*"))
943 (setq url-current-object pobj)
944 (set-syntax-table css-syntax-table)
947 (if url (url-insert-file-contents url)))
948 (goto-char (point-max))
949 (if string (insert string))
951 (goto-char (point-min))
953 (setq save-pos (point))
955 ;; *sigh* SGML comments are being used to 'hide' data inlined
956 ;; with the <style> tag from older browsers.
957 ((or (looking-at "<!--+") ; begin
958 (looking-at "--+>")) ; end
959 (goto-char (match-end 0)))
960 ;; C++ style comments
961 ((looking-at "[ \t]*//")
963 ;; Pre-Processor directives
964 ((looking-at "[ \t\r]*@\\([^ \t\r\n]\\)")
965 (let (data directive)
966 (skip-chars-forward " @\t\r") ; Past any leading whitespace
967 (setq save-pos (point))
968 (skip-chars-forward "^ \t\r\n") ; Past the @ directive
969 (downcase-region save-pos (point))
970 (setq directive (intern (buffer-substring save-pos (point))))
971 (skip-chars-forward " \t\r")
972 (setq save-pos (point))
974 ((looking-at "[^{]*\\({\\)")
975 (goto-char (match-beginning 1))
978 (error (goto-char (point-max))))
979 (setq data (buffer-substring save-pos (1- (point)))))
980 ((looking-at "[\"']+")
981 (setq save-pos (1+ save-pos))
984 (error (goto-char (point-max))))
985 (setq data (buffer-substring save-pos (1- (point)))))
987 (skip-chars-forward "^;")))
989 (setq data (buffer-substring save-pos (point))))
990 (setq save-pos (point))
992 (import (css-handle-import data))
993 (media (css-handle-media-directive data active-device-types))
994 (t (message "Unknown directive in stylesheet: @%s" directive)))))
995 ;; Giving us some output device information, old way
996 ((looking-at "[ \t\r]*:\\([^: \n]+\\):")
997 (downcase-region (match-beginning 1) (match-end 1))
998 (setq device-type (intern (buffer-substring (match-beginning 1)
1000 (goto-char (match-end 0))
1001 (if (not (memq device-type active-device-types))
1002 ;; Not applicable to us... skip the info
1004 (if (re-search-forward ":[^:{ ]*:" nil t)
1005 (goto-char (match-beginning 0))
1006 (goto-char (point-max))))))
1007 ;; Default is to treat it like a stylesheet declaration
1009 (skip-chars-forward "^{")
1010 ;;(downcase-region save-pos (point))
1011 (setq applies-to (css-applies-to save-pos (point)))
1012 (skip-chars-forward "^{")
1013 (setq save-pos (point))
1016 (error (goto-char (point-max))))
1017 (skip-chars-backward "\r}")
1018 (subst-char-in-region save-pos (point) ?\n ? )
1019 (subst-char-in-region save-pos (point) ?\r ? )
1020 ;; This is for not choking on garbage at the end of the buffer.
1021 ;; I get bit by this every once in a while when going through my
1025 (setq attrs (css-parse-args (1+ save-pos) (point)))
1026 (skip-chars-forward "}\r\n")
1027 (css-store-rule attrs applies-to))
1030 (skip-chars-forward " \t\r\n"))
1031 (set-buffer-modified-p nil)
1032 (kill-buffer (current-buffer)))
1036 ;; Tools for pretty-printing an existing stylesheet.
1037 (defun css-rule-name (rule)
1039 ((listp (car rule)) ; Contextual
1040 (mapconcat 'css-rule-name
1041 (reverse rule) " "))
1042 ((listp (cdr rule)) ; More than one class
1043 (let ((classes (cdr rule))
1044 (rval (symbol-name (car rule))))
1046 (setq rval (concat rval
1047 (if (= (aref (car classes) 0) ?:)
1049 (concat "." (pop classes))))))
1052 (symbol-name (car rule)))))
1054 (defun css-display (sheet)
1055 (with-output-to-temp-buffer "CSS Stylesheet"
1056 (set-buffer standard-output)
1057 (indented-text-mode)
1058 (insert "# Stylesheet auto-regenerated by css.el\n#\n"
1059 "# This is a mixture of the default stylesheet and any\n"
1060 "# styles specified by the document. The rules are in no\n"
1061 "# particular order.\n\n")
1068 (insert (css-rule-name (car cur)))
1071 ;; Display the rules
1072 (setq tmp (cdr cur))
1075 (setq prop (caar tmp)
1078 (case (get prop 'css-type)
1080 (setq val (mapconcat 'symbol-name val ",")))
1082 (setq val (substring (symbol-name val) 1 nil)))
1086 (insert (format " %s: %s;\n" prop val))))