14
|
1 ;;; css.el -- Cascading Style Sheet parser
|
|
2 ;; Author: wmperry
|
20
|
3 ;; Created: 1997/02/08 05:24:49
|
|
4 ;; Version: 1.27
|
14
|
5 ;; Keywords:
|
|
6
|
|
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
8 ;;; Copyright (c) 1996 by William M. Perry (wmperry@cs.indiana.edu)
|
16
|
9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
|
14
|
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
|
16
|
41 ;; Base CSS level 1 properties: http://www.w3.org/pub/WWW/TR/REC-CSS1
|
|
42 ;; Font properties, Section 5.2
|
|
43 [font-family t string-list]
|
|
44 [font-style t symbol]
|
|
45 [font-variant t symbol]
|
|
46 [font-weight t weight]
|
|
47 [font-size t length]
|
14
|
48 [font nil font]
|
16
|
49
|
|
50 ;; Color and background properties, Section 5.3
|
|
51 [color t color]
|
|
52 [background nil color-shorthand]
|
|
53 [background-color nil color]
|
|
54 [background-image nil url] ; NYI
|
|
55 [background-repeat nil symbol] ; CBI
|
|
56 [background-attachment nil symbol] ; CBI
|
|
57 [background-position nil symbol] ; CBI
|
|
58
|
|
59 ;; Text properties, Section 5.4
|
|
60 [word-spacing t length] ; CBI
|
|
61 [letter-spacing t length] ; CBI
|
|
62 [text-decoration t symbol-list]
|
|
63 [vertical-align nil symbol]
|
|
64 [text-transform t symbol]
|
14
|
65 [text-align t symbol]
|
|
66 [text-indent t length] ; NYI
|
|
67 [line-height t length] ; CBI
|
16
|
68
|
|
69 ;; Box properties, Section 5.5
|
|
70 [margin nil boundary-shorthand]
|
|
71 [margin-left nil length]
|
|
72 [margin-right nil length]
|
|
73 [margin-top nil length]
|
|
74 [margin-bottom nil length]
|
|
75 [padding nil boundary-shorthand]
|
|
76 [padding-left nil length]
|
|
77 [padding-right nil length]
|
|
78 [padding-top nil length]
|
|
79 [padding-bottom nil length]
|
|
80 [border nil border-shorthand]
|
14
|
81 [border-left nil border]
|
|
82 [border-right nil border]
|
|
83 [border-top nil border]
|
|
84 [border-bottom nil border]
|
16
|
85 [border-top-width nil nil]
|
|
86 [border-right-width nil nil]
|
|
87 [border-bottom-width nil nil]
|
|
88 [border-left-width nil nil]
|
|
89 [border-width nil boundary-shorthand]
|
|
90 [border-color nil color]
|
|
91 [border-style nil symbol]
|
14
|
92 [width nil length] ; NYPI
|
|
93 [height nil length] ; NYPI
|
|
94 [float nil symbol]
|
|
95 [clear nil symbol]
|
16
|
96
|
|
97 ;; Classification properties, Section 5.6
|
14
|
98 [display nil symbol]
|
16
|
99 [list-style-type t symbol]
|
|
100 [list-style-image t url]
|
|
101 [list-style-position t symbol]
|
|
102 [list-style nil list-style]
|
14
|
103 [white-space t symbol]
|
|
104
|
16
|
105 ;; These are for specifying speech properties (ACSS-style)
|
|
106 ;; http://www.w3.org/pub/WWW/Style/CSS/Speech/NOTE-ACSS
|
|
107
|
|
108 ;; General audio properties, Section 3
|
|
109 [volume t string] ; Needs its own type?
|
|
110 [pause-before nil time]
|
|
111 [pause-after nil time]
|
|
112 [pause nil pause]
|
|
113 [cue-before nil string]
|
|
114 [cue-after nil string]
|
|
115 [cue-during nil string]
|
|
116 [cue nil string] ; Needs its own type?
|
|
117
|
|
118 ;; Spatial properties, Section 4
|
|
119 [azimuth t angle]
|
|
120 [elevation t elevation]
|
|
121
|
|
122 ;; Speech properties, Section 5
|
|
123 [speed t string]
|
|
124 [voice-family t string-list]
|
|
125 [pitch t string]
|
|
126 [pitch-range t percentage]
|
|
127 [stress t percentage]
|
|
128 [richness t percentage]
|
|
129 [speak-punctuation t symbol]
|
|
130 [speak-date t symbol]
|
|
131 [speak-numeral t symbol]
|
|
132 [speak-time t symbol]
|
|
133
|
|
134 ;; Proposed printing extensions
|
|
135 ;; http://www.w3.org/pub/WWW/Style/Group/WD-PRINT-961220
|
|
136 ;; These apply only to pages (@page directive)
|
|
137 [size nil symbol]
|
|
138 [orientation nil symbol]
|
|
139 [margin-inside nil length]
|
|
140 ;; These apply to the document
|
|
141 [page-break-before nil symbol]
|
|
142 [page-break-after nil symbol]
|
|
143
|
|
144 ;; These are for specifying speech properties (Raman-style)
|
14
|
145 [voice-family t string]
|
|
146 [gain t integer]
|
|
147 [left-volume t integer]
|
|
148 [right-volume t integer]
|
|
149 [pitch t integer]
|
|
150 [pitch-range t integer]
|
|
151 [stress t integer]
|
|
152 [richness t integer]
|
|
153 )
|
|
154 "A description of the various CSS properties and how to interpret them.")
|
|
155
|
16
|
156 (put 'font 'css-shorthand t)
|
|
157 (put 'background 'css-shorthand t)
|
|
158 (put 'margin 'css-shorthand t)
|
|
159 (put 'padding 'css-shorthand t)
|
|
160 (put 'border 'css-shorthand t)
|
|
161 (put 'list-style 'css-shorthand t)
|
|
162
|
14
|
163 (mapcar
|
|
164 (lambda (entry)
|
|
165 (put (aref entry 0) 'css-inherit (aref entry 1))
|
|
166 (put (aref entry 0) 'css-type (aref entry 2)))
|
|
167 css-properties)
|
|
168
|
|
169 (defconst css-weights
|
|
170 '(nil ;never used
|
|
171 :extra-light
|
|
172 :light
|
|
173 :demi-light
|
|
174 :medium
|
|
175 :normal
|
|
176 :demi-bold
|
|
177 :bold
|
|
178 :extra-bold
|
|
179 )
|
|
180 "List of CSS font weights.")
|
|
181
|
|
182 (defvar css-syntax-table
|
|
183 (copy-syntax-table emacs-lisp-mode-syntax-table)
|
|
184 "The syntax table for parsing stylesheets")
|
|
185
|
|
186 (modify-syntax-entry ?' "\"" css-syntax-table)
|
|
187 (modify-syntax-entry ?` "\"" css-syntax-table)
|
|
188 (modify-syntax-entry ?{ "(" css-syntax-table)
|
|
189 (modify-syntax-entry ?} ")" css-syntax-table)
|
|
190
|
|
191 (eval-when-compile
|
|
192 (defvar css-scratch-val nil)
|
|
193 (defvar css-scratch-id nil)
|
|
194 (defvar css-scratch-class nil)
|
|
195 (defvar css-scratch-possibles nil)
|
|
196 (defvar css-scratch-current nil)
|
|
197 (defvar css-scratch-classes nil)
|
|
198 (defvar css-scratch-class-match nil)
|
|
199 (defvar css-scratch-current-rule nil)
|
|
200 (defvar css-scratch-current-value nil)
|
|
201 )
|
|
202
|
|
203 (defconst css-running-xemacs
|
|
204 (string-match "XEmacs" (emacs-version))
|
|
205 "Whether we are running in XEmacs or not.")
|
|
206
|
|
207 (defsubst css-replace-regexp (regexp to-string)
|
|
208 (goto-char (point-min))
|
|
209 (while (re-search-forward regexp nil t)
|
|
210 (replace-match to-string t nil)))
|
|
211
|
|
212 (defun css-contextual-match (rule stack)
|
|
213 (let ((ancestor)
|
|
214 (p-args)
|
|
215 (p-class)
|
|
216 (matched t))
|
|
217 (while rule
|
|
218 (setq ancestor (assq (caar rule) stack))
|
|
219 (if (not ancestor)
|
|
220 (setq rule nil
|
|
221 matched nil)
|
|
222 (setq p-args (cdr ancestor)
|
|
223 p-class (or (cdr-safe (assq 'class p-args)) t))
|
|
224 (if (not (equal p-class (cdar rule)))
|
|
225 (setq matched nil
|
|
226 rule nil)))
|
|
227 (setq rule (cdr rule)))
|
|
228 matched))
|
|
229
|
|
230 (defsubst css-get-internal (tag args)
|
|
231 (declare (special tag sheet element-stack default))
|
|
232 (setq css-scratch-id (or (cdr-safe (assq 'id args))
|
|
233 (cdr-safe (assq 'name args)))
|
|
234 css-scratch-class (or (cdr-safe (assq 'class args)) t)
|
|
235 css-scratch-possibles (cl-gethash tag sheet))
|
|
236 (while css-scratch-possibles
|
|
237 (setq css-scratch-current (car css-scratch-possibles)
|
|
238 css-scratch-current-rule (car css-scratch-current)
|
|
239 css-scratch-current-value (cdr css-scratch-current)
|
|
240 css-scratch-classes (if (listp (car css-scratch-current-rule))
|
|
241 (cdar css-scratch-current-rule)
|
|
242 (cdr css-scratch-current-rule))
|
|
243 css-scratch-class-match t
|
|
244 css-scratch-possibles (cdr css-scratch-possibles))
|
|
245 (if (eq t css-scratch-classes)
|
|
246 (setq css-scratch-classes nil))
|
|
247 (if (eq t css-scratch-class)
|
|
248 (setq css-scratch-class nil))
|
|
249 (while css-scratch-classes
|
|
250 (if (not (member (pop css-scratch-classes) css-scratch-class))
|
|
251 (setq css-scratch-class-match nil
|
|
252 css-scratch-classes nil)))
|
|
253 (cond
|
|
254 ((and (listp (car css-scratch-current-rule)) css-scratch-class-match)
|
|
255 ;; Contextual!
|
|
256 (setq css-scratch-current-rule (cdr css-scratch-current-rule))
|
|
257 (if (css-contextual-match css-scratch-current-rule element-stack)
|
|
258 (setq css-scratch-val
|
|
259 (append css-scratch-val css-scratch-current-value)))
|
|
260 )
|
|
261 (css-scratch-class-match
|
|
262 (setq css-scratch-val (append css-scratch-val css-scratch-current-value))
|
|
263 )
|
|
264 (t
|
|
265 nil))
|
|
266 )
|
|
267 )
|
|
268
|
|
269 (defsubst css-get (tag args &optional sheet element-stack)
|
|
270 (setq css-scratch-val nil
|
|
271 css-scratch-class (or (cdr-safe (assq 'class args)) t))
|
|
272
|
|
273 ;; check for things without the class
|
|
274 (if (listp css-scratch-class)
|
|
275 (css-get-internal tag nil))
|
|
276
|
|
277 ;; check for global class values
|
|
278 (css-get-internal '*document args)
|
|
279
|
|
280 ;; Now check for things with the class - they will be stuck on the front
|
|
281 ;; of the list, which will mean we do the right thing
|
|
282 (css-get-internal tag args)
|
|
283
|
|
284 ;; Defaults are up to the calling application to provide
|
|
285 css-scratch-val)
|
|
286
|
|
287 (defun css-ancestor-get (info ancestors sheet)
|
|
288 ;; Inheritable property, check ancestors
|
|
289 (let (cur)
|
|
290 (while ancestors
|
|
291 (setq cur (car ancestors)
|
|
292 css-scratch-val (css-get info (car cur) (cdr cur) sheet)
|
|
293 ancestors (if css-scratch-val nil (cdr ancestors)))))
|
|
294 css-scratch-val)
|
|
295
|
|
296 (defun css-split-selector (tag)
|
|
297 ;; Return a list
|
|
298 (cond
|
|
299 ((string-match " " tag) ; contextual
|
|
300 (let ((tags (split-string tag "[ \t]+"))
|
|
301 (result nil))
|
|
302 (while tags
|
|
303 (setq result (cons (css-split-selector (car tags)) result)
|
|
304 tags (cdr tags)))
|
|
305 result))
|
|
306 ((string-match "[:\\.]" tag)
|
|
307 (let ((tag (if (= (match-beginning 0) 0)
|
|
308 '*document
|
|
309 (intern (downcase (substring tag 0 (match-beginning 0))))))
|
|
310 (rest (substring tag (match-beginning 0) nil))
|
|
311 (classes nil))
|
|
312 (while (string-match "^[:\\.][^:\\.]+" rest)
|
|
313 (if (= ?. (aref rest 0))
|
|
314 (setq classes (cons (substring rest 1 (match-end 0)) classes))
|
|
315 (setq classes (cons (substring rest 0 (match-end 0)) classes)))
|
|
316 (setq rest (substring rest (match-end 0) nil)))
|
|
317 (setq classes (sort classes 'string-lessp))
|
|
318 (cons tag classes)))
|
|
319 ((string-match "^#" tag) ; id selector
|
|
320 (cons '*document tag))
|
|
321 (t
|
|
322 (cons (intern (downcase tag)) t)
|
|
323 )
|
|
324 )
|
|
325 )
|
|
326
|
|
327 (defun css-applies-to (st nd)
|
|
328 (let ((results nil)
|
|
329 (save-pos nil))
|
|
330 (narrow-to-region st nd)
|
|
331 (goto-char st)
|
|
332 (skip-chars-forward " \t\r\n")
|
|
333 (while (not (eobp))
|
|
334 (setq save-pos (point))
|
|
335 (skip-chars-forward "^,")
|
|
336 (skip-chars-backward " \r\t\n")
|
|
337 (setq results (cons (css-split-selector
|
|
338 (buffer-substring save-pos (point))) results))
|
|
339 (skip-chars-forward ", \t\r\n"))
|
|
340 (widen)
|
|
341 results))
|
|
342
|
|
343 (defun css-split-font-shorthand (font)
|
|
344 ;; [<font-weight> || <font-style>]? <font-size> [ / <line-height> ]? <font-family>
|
|
345 (let (weight size height family retval)
|
|
346 (if (not (string-match " *\\([0-9.]+[^ /]+\\)" font))
|
|
347 (error "Malformed font shorthand: %s" font))
|
|
348 (setq weight (if (/= 0 (match-beginning 0))
|
|
349 (substring font 0 (match-beginning 0)))
|
|
350 size (match-string 1 font)
|
|
351 font (substring font (match-end 0) nil))
|
|
352 (if (string-match " */ *\\([^ ]+\\) *" font)
|
|
353 ;; they specified a line-height as well
|
|
354 (setq height (match-string 1 font)
|
|
355 family (substring font (match-end 0) nil))
|
|
356 (if (string-match "^[ \t]+" font)
|
|
357 (setq family (substring font (match-end 0) nil))
|
|
358 (setq family font)))
|
|
359 (if weight (setq retval (cons (cons 'font-weight weight) retval)))
|
|
360 (if size (setq retval (cons (cons 'font-size size) retval)))
|
|
361 (if height (setq retval (cons (cons 'line-height height) retval)))
|
|
362 (if family (setq retval (cons (cons 'font-family family) retval)))
|
|
363 retval))
|
|
364
|
|
365 (defun css-expand-length (spec)
|
|
366 (cond
|
|
367 ((not (stringp spec)) spec)
|
|
368 ((string-equal spec "auto") nil)
|
20
|
369 ((string-match "\\([+-]?\\([0-9]+\\|[0-9]*\\.[0-9]+\\)\\)%" spec) ; A percentage
|
14
|
370 nil)
|
20
|
371 ((string-match "\\([+-]?\\([0-9]+\\|[0-9]*\\.[0-9]+\\)\\)e[mx]" spec) ; Character based
|
|
372 (max 0 (round (string-to-number (match-string 1 spec)))))
|
14
|
373 (t
|
|
374 (truncate (font-spatial-to-canonical spec)))
|
|
375 )
|
|
376 )
|
|
377
|
|
378 (defsubst css-unhex-char (x)
|
|
379 (if (> x ?9)
|
|
380 (if (>= x ?a)
|
|
381 (+ 10 (- x ?a))
|
|
382 (+ 10 (- x ?A)))
|
|
383 (- x ?0)))
|
|
384
|
|
385 (defsubst css-pow (x n)
|
|
386 (apply '* (make-list n x)))
|
|
387
|
|
388 (defun css-unhex (x)
|
|
389 (let ((ord (length x))
|
|
390 (rval 0))
|
|
391 (while (> ord 0)
|
|
392 (setq rval (+ rval
|
|
393 (* (css-pow 16 (- (length x) ord))
|
|
394 (css-unhex-char (aref x (1- ord)))))
|
|
395 ord (1- ord)))
|
|
396 rval))
|
|
397
|
16
|
398 (defmacro css-symbol-list-as-regexp (&rest keys)
|
|
399 (` (eval-when-compile
|
|
400 (concat "^\\("
|
|
401 (mapconcat 'symbol-name
|
|
402 (quote (, keys))
|
|
403 "\\|") "\\)$"))))
|
|
404
|
14
|
405 (defun css-expand-color (color)
|
|
406 (cond
|
|
407 ((string-match "^#" color)
|
|
408 (let (r g b)
|
|
409 (cond
|
|
410 ((string-match "^#...$" color)
|
|
411 ;; 3-char rgb spec, expand out to six chars by replicating
|
|
412 ;; digits, not adding zeros.
|
|
413 (setq r (css-unhex (make-string 2 (aref color 1)))
|
|
414 g (css-unhex (make-string 2 (aref color 2)))
|
|
415 b (css-unhex (make-string 2 (aref color 3)))))
|
|
416 ((string-match "^#\\(..\\)\\(..\\)\\(..\\)$" color)
|
|
417 (setq r (css-unhex (match-string 1 color))
|
|
418 g (css-unhex (match-string 2 color))
|
|
419 b (css-unhex (match-string 3 color))))
|
|
420 (t
|
|
421 (setq color (substring color 1))
|
|
422 (let* ((n (/ (length color) 3))
|
|
423 (max (float (css-pow 16 n))))
|
|
424 (setq r (css-unhex (substring color 0 n))
|
|
425 g (css-unhex (substring color n (* n 2)))
|
|
426 b (css-unhex (substring color (* n 2) (* n 3)))
|
|
427 r (round (* (/ r max) 255))
|
|
428 g (round (* (/ g max) 255))
|
|
429 b (round (* (/ b max) 255))))))
|
|
430 (setq color (vector 'rgb r g b))))
|
|
431 ((string-match "^rgb *( *\\([0-9]+\\)[, ]+\\([0-9]+\\)[, ]+\\([0-9]+\\) *) *$" color)
|
|
432 ;; rgb(r,g,b) 0 - 255, cutting off at 255
|
|
433 (setq color (vector
|
|
434 'rgb
|
|
435 (min (string-to-int (match-string 1 color)) 255)
|
|
436 (min (string-to-int (match-string 2 color)) 255)
|
|
437 (min (string-to-int (match-string 3 color)) 255))))
|
|
438 ((string-match "^rgb *( *\\([0-9]+\\) *%[, ]+\\([0-9]+\\) *%[, ]+\\([0-9]+\\) *% *) *$" color)
|
|
439 ;; rgb(r%,g%,b%) 0 - 100%, cutting off at 100%
|
|
440 (let ((r (min (string-to-number (match-string 1 color)) 100.0))
|
|
441 (g (min (string-to-number (match-string 2 color)) 100.0))
|
|
442 (b (min (string-to-number (match-string 3 color)) 100.0)))
|
|
443 (setq r (round (* r 2.55))
|
|
444 g (round (* g 2.55))
|
|
445 b (round (* b 2.55))
|
|
446 color (vector 'rgb r g b))))
|
|
447 (t
|
|
448 ;; Hmmm... pass it through unmangled and hope the underlying
|
|
449 ;; windowing system can handle it.
|
|
450 )
|
|
451 )
|
|
452 color
|
|
453 )
|
|
454
|
|
455 (defun css-expand-value (type value)
|
16
|
456 (if value
|
|
457 (case type
|
|
458 (length ; CSS, Section 6.1
|
|
459 (setq value (css-expand-length value)))
|
|
460 (percentage ; CSS, Section 6.2
|
|
461 (setq value (/ (string-to-number value)
|
|
462 (if (fboundp 'float) (float 100) 1))))
|
|
463 (color ; CSS, Section 6.3
|
|
464 (setq value (css-expand-color value)))
|
|
465 (url ; CSS, Section 6.4
|
|
466 (declare (special url purl))
|
|
467 (if (string-match "url *(\\([^ )]+\\) *)" value)
|
|
468 (setq value (match-string 1 value)))
|
|
469 (if (string-match " *\\([^ ]+\\) *" value)
|
|
470 (setq value (match-string 1 value)))
|
|
471 (setq value (url-expand-file-name value (or url purl))))
|
|
472 (angle ; ACSS, Section 2.2.1
|
|
473 )
|
|
474 (time ; ACSS, Section 2.2.2
|
|
475 (let ((val (string-to-number value))
|
|
476 (units 'ms))
|
|
477 (if (string-match "^[0-9]+ *\\([a-zA-Z.]+\\)" value)
|
|
478 (setq units (intern (downcase (match-string 1 value)))))
|
|
479 (setq value (case units
|
|
480 ((s second seconds)
|
|
481 val)
|
|
482 ((min minute minutes)
|
|
483 (* val 60))
|
|
484 ((hr hour hours)
|
|
485 (* val 60 60))
|
|
486 ((day days)
|
|
487 (* val 24 60 60))
|
|
488 (otherwise
|
|
489 (/ val (float 1000)))))))
|
|
490 (elevation ; ACSS, Section 4.2
|
|
491 (if (string-match
|
|
492 (css-symbol-list-as-regexp below level above higher lower) value)
|
|
493 (setq value (intern (downcase (match-string value 1)))
|
|
494 value (case value
|
|
495 (below -90)
|
|
496 (above 90)
|
|
497 (level 0)
|
|
498 (higher 45)
|
|
499 (lower -45)
|
|
500 ))
|
|
501 (setq value (css-expand-value 'angle value))))
|
|
502 (color-shorthand ; CSS, Section 5.3.7
|
|
503 ;; color|image|repeat|attach|position
|
|
504 (let ((keys (split-string value " +"))
|
|
505 cur color image repeat attach position)
|
|
506 (while (setq cur (pop keys))
|
|
507 (cond
|
|
508 ((string-match "url" cur) ; Only image can have a URL
|
|
509 (setq image (css-expand-value 'url cur)))
|
|
510 ((string-match "%" cur) ; Only position can have a perc.
|
|
511 (setq position (css-expand-value 'percentage cur)))
|
|
512 ((string-match "repeat" cur) ; Only repeat
|
|
513 (setq repeat (intern (downcase cur))))
|
|
514 ((string-match "scroll\\|fixed" cur)
|
|
515 (setq attach (intern (downcase (substring cur
|
|
516 (match-beginning 0)
|
|
517 (match-end 0))))))
|
|
518 ((string-match (css-symbol-list-as-regexp
|
|
519 top center bottom left right) cur)
|
|
520 )
|
|
521 (t
|
|
522 (setq color cur))))
|
|
523 (setq value (list (cons 'background-color color)
|
|
524 (cons 'background-image image)
|
|
525 (cons 'background-repeat repeat)
|
|
526 (cons 'background-attachment attach)
|
|
527 (cons 'background-position position)))))
|
|
528 (font ; CSS, Section 5.2.7
|
|
529 ;; [style | variant | weight]? size[/line-height]? family
|
|
530 (setq value (css-split-font-shorthand value)))
|
|
531 (border ; width | style | color
|
|
532 ;; FIX
|
|
533 )
|
|
534 (border-shorthand ; width | style | color
|
|
535 ;; FIX
|
|
536 )
|
|
537 (list-style ; CSS, Section 5.6.6
|
|
538 ;; keyword | position | url
|
|
539 (setq value (split-string value "[ ,]+"))
|
|
540 (if (= (length value) 1)
|
|
541 (setq value (list (cons 'list-style-type
|
|
542 (intern (downcase (car value))))))
|
|
543 (setq value (list (cons 'list-style-type
|
|
544 (css-expand-value 'symbol (nth 0 value)))
|
|
545 (cons 'list-style-position
|
|
546 (css-expand-value 'symbol (nth 1 value)))
|
|
547 (cons 'list-style-image
|
|
548 (css-expand-value 'url (nth 2 value)))))))
|
|
549 (boundary-shorthand ; CSS, Section 5.5.x
|
|
550 ;; length|percentage|auto {1,4}
|
|
551 (setq value (split-string value "[ ,]+"))
|
14
|
552 (let* ((top (intern (format "%s-top" type)))
|
|
553 (bottom (intern (format "%s-bottom" type)))
|
|
554 (left (intern (format "%s-left" type)))
|
|
555 (right (intern (format "%s-right" type))))
|
16
|
556 (setq top (cons top (css-expand-value (get top 'css-type)
|
|
557 (nth 0 value)))
|
|
558 right (cons right (css-expand-value (get right 'css-type)
|
|
559 (nth 1 value)))
|
|
560 bottom (cons bottom (css-expand-value (get bottom 'css-type)
|
|
561 (nth 2 value)))
|
|
562 left (cons left (css-expand-value (get left 'css-type)
|
|
563 (nth 3 value)))
|
|
564 value (list top right bottom left))))
|
|
565 (weight ; CSS, Section 5.2.5
|
|
566 ;; normal|bold|bolder|lighter|[1-9]00
|
|
567 (cond
|
|
568 ((string-match "^[0-9]+" value)
|
|
569 (setq value (/ (string-to-number value) 100)
|
|
570 value (or (nth value css-weights) :bold)))
|
|
571 ((string-match (css-symbol-list-as-regexp normal bold bolder lighter)
|
|
572 value)
|
|
573 (setq value (intern (downcase (concat ":" value)))))
|
|
574 (t setq value (intern ":bold"))))
|
|
575
|
|
576 ;; The rest of these deal with how we handle things internally
|
|
577 ((symbol integer) ; Read it in
|
|
578 (setq value (read (downcase value))))
|
|
579 (symbol-list ; A space/comma delimited symlist
|
|
580 (setq value (downcase value)
|
|
581 value (split-string value "[ ,]+")
|
|
582 value (mapcar 'intern value)))
|
|
583 (string-list ; A space/comma delimited list
|
|
584 (setq value (split-string value " *, *")))
|
|
585 (otherwise ; Leave it as is
|
|
586 t)
|
|
587 )
|
14
|
588 )
|
|
589 value
|
|
590 )
|
|
591
|
|
592 (defun css-parse-args (st &optional nd)
|
|
593 ;; Return an assoc list of attribute/value pairs from a CSS style entry
|
|
594 (let (
|
|
595 name ; From name=
|
|
596 value ; its value
|
|
597 results ; Assoc list of results
|
|
598 name-pos ; Start of XXXX= position
|
|
599 val-pos ; Start of value position
|
|
600 )
|
|
601 (save-excursion
|
|
602 (if (stringp st)
|
|
603 (progn
|
|
604 (set-buffer (get-buffer-create " *css-style-temp*"))
|
|
605 (set-syntax-table css-syntax-table)
|
|
606 (erase-buffer)
|
|
607 (insert st)
|
|
608 (setq st (point-min)
|
|
609 nd (point-max)))
|
|
610 (set-syntax-table css-syntax-table))
|
|
611 (save-restriction
|
|
612 (narrow-to-region st nd)
|
|
613 (goto-char (point-min))
|
|
614 (while (not (eobp))
|
|
615 (skip-chars-forward ";, \n\t")
|
|
616 (setq name-pos (point))
|
|
617 (skip-chars-forward "^ \n\t:=,;")
|
|
618 (downcase-region name-pos (point))
|
|
619 (setq name (intern (buffer-substring name-pos (point))))
|
|
620 (skip-chars-forward " \t\n")
|
|
621 (if (not (eq (char-after (point)) ?:)) ; There is no value
|
|
622 (setq value nil)
|
|
623 (skip-chars-forward " \t\n:")
|
|
624 (setq val-pos (point)
|
|
625 value
|
|
626 (cond
|
|
627 ((or (= (or (char-after val-pos) 0) ?\")
|
|
628 (= (or (char-after val-pos) 0) ?'))
|
|
629 (buffer-substring (1+ val-pos)
|
|
630 (condition-case ()
|
|
631 (prog2
|
|
632 (forward-sexp 1)
|
|
633 (1- (point))
|
|
634 (skip-chars-forward "\""))
|
|
635 (error
|
|
636 (skip-chars-forward "^ \t\n")
|
|
637 (point)))))
|
|
638 (t
|
|
639 (buffer-substring val-pos
|
|
640 (progn
|
16
|
641 (skip-chars-forward "^;")
|
14
|
642 (skip-chars-backward " \t")
|
|
643 (point)))))))
|
|
644 (setq value (css-expand-value (get name 'css-type) value))
|
16
|
645 (if (get name 'css-shorthand)
|
14
|
646 (setq results (append value results))
|
|
647 (setq results (cons (cons name value) results)))
|
|
648 (skip-chars-forward ";, \n\t"))
|
|
649 results))))
|
|
650
|
16
|
651 (defun css-handle-media-directive (data active)
|
|
652 (let (type)
|
|
653 (if (string-match "\\([^ \t\r\n{]+\\)" data)
|
|
654 (setq type (intern (downcase (substring data (match-beginning 1)
|
|
655 (match-end 1))))
|
|
656 data (substring data (match-end 1)))
|
|
657 (setq type 'unknown))
|
|
658 (if (string-match "^[ \t\r\n]*{" data)
|
|
659 (setq data (substring data (match-end 0))))
|
|
660 (if (memq type active)
|
|
661 (save-excursion
|
|
662 (insert data)))))
|
|
663
|
|
664 (defun css-handle-import (data)
|
|
665 (let (url)
|
|
666 (setq url (css-expand-value 'url data))
|
|
667 (and url
|
|
668 (let ((url-working-buffer (generate-new-buffer-name " *styleimport*"))
|
|
669 (url-mime-accept-string
|
|
670 "text/css ; level=2")
|
|
671 (sheet nil))
|
|
672 (save-excursion
|
|
673 (set-buffer (get-buffer-create url-working-buffer))
|
|
674 (setq url-be-asynchronous nil)
|
|
675 (url-retrieve url)
|
|
676 (css-clean-buffer)
|
|
677 (setq sheet (buffer-string))
|
|
678 (set-buffer-modified-p nil)
|
|
679 (kill-buffer (current-buffer)))
|
|
680 (insert sheet)))))
|
14
|
681
|
|
682 (defun css-clean-buffer ()
|
|
683 ;; Nuke comments, etc.
|
|
684 (goto-char (point-min))
|
|
685 (let ((save-pos nil))
|
|
686 (while (search-forward "/*" nil t)
|
|
687 (setq save-pos (- (point) 2))
|
|
688 (delete-region save-pos
|
|
689 (if (search-forward "*/" nil t)
|
|
690 (point)
|
|
691 (end-of-line)
|
|
692 (point)))))
|
|
693 (goto-char (point-min))
|
|
694 (delete-matching-lines "^[ \t\r]*$") ; Nuke blank lines
|
|
695 (css-replace-regexp "^[ \t\r]+" "") ; Nuke whitespace at beg. of line
|
|
696 (css-replace-regexp "[ \t\r]+$" "") ; Nuke whitespace at end of line
|
|
697 (goto-char (point-min)))
|
|
698
|
|
699 (defun css-active-device-types (&optional device)
|
16
|
700 (let ((types (list 'all (if css-running-xemacs 'xemacs 'emacs)))
|
14
|
701 (type (device-type device)))
|
|
702 (cond
|
|
703 ((featurep 'emacspeak)
|
|
704 (setq types (cons 'speech types)))
|
|
705 ((eq type 'tty)
|
|
706 (if (and (fboundp 'tty-color-list)
|
|
707 (/= 0 (length (tty-color-list))))
|
|
708 (setq types (cons 'ansi-tty types))
|
|
709 (setq types (cons 'tty types))))
|
|
710 ((eq 'color (device-class))
|
|
711 (if (not (device-bitplanes))
|
|
712 (setq types (cons 'color types))
|
|
713 (setq types
|
|
714 (append
|
|
715 (list (intern (format "%dbit-color"
|
|
716 (device-bitplanes)))
|
|
717 (intern (format "%dbit"
|
|
718 (device-bitplanes)))
|
|
719 'color) types))
|
|
720 (if (= 24 (device-bitplanes))
|
|
721 (setq types (cons 'truecolor types)))))
|
|
722 ((eq 'grayscale (device-class))
|
|
723 (setq types (append (list (intern (format "%dbit-grayscale"
|
|
724 (device-bitplanes)))
|
|
725 'grayscale)
|
|
726 types)))
|
|
727 ((eq 'mono (device-class))
|
|
728 (setq types (append (list 'mono 'monochrome) types)))
|
|
729 (t
|
|
730 (setq types (cons 'unknown types))))
|
|
731 types))
|
|
732
|
|
733 (defmacro css-rule-specificity-internal (rule)
|
|
734 (`
|
|
735 (progn
|
|
736 (setq tmp (cdr (, rule)))
|
|
737 (if (listp tmp)
|
|
738 (while tmp
|
|
739 (if (= ?# (aref (car tmp) 0))
|
|
740 (incf a)
|
|
741 (incf b))
|
|
742 (setq tmp (cdr tmp)))))))
|
|
743
|
|
744 (defsubst css-specificity (rule)
|
|
745 ;; To find specificity, according to the september 1996 CSS draft
|
|
746 ;; a = # of ID attributes in the selector
|
|
747 ;; b = # of class attributes in the selector
|
|
748 ;; c = # of tag names in the selector
|
|
749 (let ((a 0) (b 0) (c 0) cur tmp)
|
|
750 (if (not (listp (car rule)))
|
|
751 (css-rule-specificity-internal rule)
|
|
752 (setq c (length rule))
|
|
753 (while rule
|
|
754 (css-rule-specificity-internal (pop rule))))
|
|
755 (+ (* 100 a) (* 10 b) c)
|
|
756 )
|
|
757 )
|
|
758
|
|
759 (defun css-copy-stylesheet (sheet)
|
|
760 (let ((new (make-hash-table :size (hash-table-count sheet))))
|
|
761 (cl-maphash
|
|
762 (function
|
|
763 (lambda (k v)
|
|
764 (cl-puthash k (copy-tree v) new))) sheet)
|
|
765 new))
|
|
766
|
|
767 (defsubst css-store-rule (attrs applies-to)
|
|
768 (declare (special sheet))
|
|
769 (let (rules cur tag node)
|
|
770 (while applies-to
|
|
771 (setq cur (pop applies-to)
|
|
772 tag (car cur))
|
|
773 (if (listp tag)
|
|
774 (setq tag (car tag)))
|
|
775 (setq rules (cl-gethash tag sheet))
|
|
776 (cond
|
|
777 ((null rules)
|
|
778 ;; First rule for this tag. Create new ruleset
|
|
779 (cl-puthash tag (list (cons cur attrs)) sheet))
|
|
780 ((setq node (assoc cur rules))
|
|
781 ;; Similar rule already exists, splice in our information
|
|
782 (setcdr node (append attrs (cdr node))))
|
|
783 (t
|
|
784 ;; First rule for this particular combination of tag/ancestors/class.
|
|
785 ;; Slap it onto the existing set of rules and push back into sheet.
|
|
786 (setq rules (cons (cons cur attrs) rules))
|
|
787 (cl-puthash tag rules sheet))
|
|
788 )
|
|
789 )
|
|
790 )
|
|
791 )
|
|
792
|
16
|
793 (defun css-parse (url &optional string inherit)
|
14
|
794 (let (
|
|
795 (url-mime-accept-string
|
|
796 "text/css ; level=2")
|
|
797 (save-pos nil)
|
|
798 (applies-to nil) ; List of tags to apply style to
|
|
799 (attrs nil) ; List of name/value pairs
|
|
800 (att nil)
|
|
801 (cur nil)
|
|
802 (val nil)
|
|
803 (device-type nil)
|
16
|
804 (purl (url-view-url t))
|
14
|
805 (active-device-types (css-active-device-types (selected-device)))
|
|
806 (sheet inherit))
|
|
807 (if (not sheet)
|
|
808 (setq sheet (make-hash-table :size 13 :test 'eq)))
|
|
809 (save-excursion
|
|
810 (set-buffer (get-buffer-create
|
|
811 (generate-new-buffer-name " *style*")))
|
|
812 (set-syntax-table css-syntax-table)
|
|
813 (erase-buffer)
|
16
|
814 (if url (url-insert-file-contents url))
|
14
|
815 (goto-char (point-max))
|
|
816 (if string (insert string))
|
|
817 (css-clean-buffer)
|
|
818 (goto-char (point-min))
|
|
819 (while (not (eobp))
|
|
820 (setq save-pos (point))
|
|
821 (cond
|
|
822 ;; *sigh* SGML comments are being used to 'hide' data inlined
|
|
823 ;; with the <style> tag from older browsers.
|
|
824 ((or (looking-at "<!--+") ; begin
|
|
825 (looking-at "--+>")) ; end
|
|
826 (goto-char (match-end 0)))
|
|
827 ;; C++ style comments, and we are doing IE compatibility
|
16
|
828 ((looking-at "//")
|
14
|
829 (end-of-line))
|
|
830 ;; Pre-Processor directives
|
|
831 ((looking-at "[ \t\r]*@\\([^ \t\r\n]\\)")
|
16
|
832 (let (data directive)
|
14
|
833 (skip-chars-forward " @\t\r") ; Past any leading whitespace
|
|
834 (setq save-pos (point))
|
|
835 (skip-chars-forward "^ \t\r\n") ; Past the @ directive
|
|
836 (downcase-region save-pos (point))
|
16
|
837 (setq directive (intern (buffer-substring save-pos (point))))
|
|
838 (skip-chars-forward " \t\r")
|
14
|
839 (setq save-pos (point))
|
|
840 (cond
|
16
|
841 ((looking-at ".*\\({\\)")
|
|
842 (goto-char (match-beginning 1))
|
|
843 (forward-sexp 1)
|
|
844 (setq data (buffer-substring save-pos (1- (point)))))
|
|
845 ((looking-at "[\"']+")
|
|
846 (setq save-pos (1+ save-pos))
|
|
847 (forward-sexp 1)
|
|
848 (setq data (buffer-substring save-pos (1- (point)))))
|
14
|
849 (t
|
16
|
850 (skip-chars-forward "^;")))
|
|
851 (if (not data)
|
|
852 (setq data (buffer-substring save-pos (point))))
|
|
853 (setq save-pos (point))
|
|
854 (case directive
|
|
855 (import (css-handle-import data))
|
|
856 (media (css-handle-media-directive data active-device-types))
|
|
857 (t (message "Unknown directive in stylesheet: @%s" directive)))))
|
14
|
858 ;; Giving us some output device information
|
|
859 ((looking-at "[ \t\r]*:\\([^: \n]+\\):")
|
16
|
860 (message "You are using the old way of specifying device-dependent stylesheets! Please upgrade!")
|
|
861 (sleep-for 2)
|
14
|
862 (downcase-region (match-beginning 1) (match-end 1))
|
|
863 (setq device-type (intern (buffer-substring (match-beginning 1)
|
|
864 (match-end 1))))
|
|
865 (goto-char (match-end 0))
|
|
866 (if (not (memq device-type active-device-types))
|
|
867 ;; Not applicable to us... skip the info
|
|
868 (progn
|
|
869 (if (re-search-forward ":[^:{ ]*:" nil t)
|
|
870 (goto-char (match-beginning 0))
|
|
871 (goto-char (point-max))))))
|
|
872 ;; Default is to treat it like a stylesheet declaration
|
|
873 (t
|
|
874 (skip-chars-forward "^{")
|
|
875 ;;(downcase-region save-pos (point))
|
|
876 (setq applies-to (css-applies-to save-pos (point)))
|
|
877 (skip-chars-forward "^{")
|
|
878 (setq save-pos (point))
|
|
879 (condition-case ()
|
|
880 (forward-sexp 1)
|
|
881 (error (goto-char (point-max))))
|
|
882 (end-of-line)
|
|
883 (skip-chars-backward "\r}")
|
|
884 (subst-char-in-region save-pos (point) ?\n ? )
|
|
885 (subst-char-in-region save-pos (point) ?\r ? )
|
|
886 ;; This is for not choking on garbage at the end of the buffer.
|
|
887 ;; I get bit by this every once in a while when going through my
|
|
888 ;; socks gateway.
|
|
889 (if (eobp)
|
|
890 nil
|
|
891 (setq attrs (css-parse-args (1+ save-pos) (point)))
|
|
892 (skip-chars-forward "}\r\n")
|
|
893 (css-store-rule attrs applies-to))
|
|
894 )
|
|
895 )
|
|
896 (skip-chars-forward " \t\r\n"))
|
|
897 (set-buffer-modified-p nil)
|
|
898 (kill-buffer (current-buffer)))
|
|
899 sheet)
|
|
900 )
|
|
901
|
|
902 ;; Tools for pretty-printing an existing stylesheet.
|
|
903 (defun css-rule-name (rule)
|
|
904 (cond
|
|
905 ((listp (car rule)) ; Contextual
|
|
906 (mapconcat 'css-rule-name
|
|
907 (reverse rule) " "))
|
|
908 ((listp (cdr rule)) ; More than one class
|
|
909 (let ((classes (cdr rule))
|
|
910 (rval (symbol-name (car rule))))
|
|
911 (while classes
|
|
912 (setq rval (concat rval
|
|
913 (if (= (aref (car classes) 0) ?:)
|
|
914 (pop classes)
|
|
915 (concat "." (pop classes))))))
|
|
916 rval))
|
|
917 (t
|
|
918 (symbol-name (car rule)))))
|
|
919
|
|
920 (defun css-display (sheet)
|
|
921 (with-output-to-temp-buffer "CSS Stylesheet"
|
|
922 (set-buffer standard-output)
|
|
923 (indented-text-mode)
|
|
924 (insert "# Stylesheet auto-regenerated by css.el\n#\n"
|
|
925 "# This is a mixture of the default stylesheet and any\n"
|
|
926 "# styles specified by the document. The rules are in no\n"
|
|
927 "# particular order.\n\n")
|
|
928 (let (tmp cur goal-col)
|
|
929 (cl-maphash
|
|
930 (function
|
|
931 (lambda (k v)
|
|
932 (while v
|
|
933 (setq cur (pop v))
|
|
934 (insert (css-rule-name (car cur)))
|
|
935 (insert " { ")
|
|
936 (setq goal-col (point))
|
|
937 (insert "\n")
|
|
938 ;; Display the rules
|
|
939 (setq tmp (cdr cur))
|
|
940 (let (prop val)
|
|
941 (while tmp
|
|
942 (setq prop (caar tmp)
|
|
943 val (cdar tmp)
|
|
944 tmp (cdr tmp))
|
|
945 (case (get prop 'css-type)
|
|
946 (symbol-list
|
|
947 (setq val (mapconcat 'symbol-name val ",")))
|
|
948 (weight
|
|
949 (setq val (substring (symbol-name val) 1 nil)))
|
|
950 (otherwise
|
|
951 nil)
|
|
952 )
|
|
953 (insert (format " %s: %s;\n" prop val))))
|
|
954 (insert "}\n\n");
|
|
955 )))
|
|
956 sheet))))
|
|
957
|
|
958 (provide 'css)
|