|
14
|
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)
|
