src/css/css-selector.lisp

   1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CSS; Readtable: GLISP; Encoding: utf-8; -*-
   2 ;;; ---------------------------------------------------------------------------
   3 ;;;     Title: CSS selectors
   4 ;;;            [Split off from css-parse.lisp]
   5 ;;;   Created: 2001-05-19
   6 ;;;    Author: Gilbert Baumann <gilbert@base-engineering.com>
   7 ;;;   License: MIT style (see below)
   8 ;;; ---------------------------------------------------------------------------
   9 ;;;  (c) copyright 1998-2001 by Gilbert Baumann
  10
  11 ;;;  Permission is hereby granted, free of charge, to any person obtaining
  12 ;;;  a copy of this software and associated documentation files (the
  13 ;;;  "Software"), to deal in the Software without restriction, including
  14 ;;;  without limitation the rights to use, copy, modify, merge, publish,
  15 ;;;  distribute, sublicense, and/or sell copies of the Software, and to
  16 ;;;  permit persons to whom the Software is furnished to do so, subject to
  17 ;;;  the following conditions:
  18 ;;;
  19 ;;;  The above copyright notice and this permission notice shall be
  20 ;;;  included in all copies or substantial portions of the Software.
  21 ;;;
  22 ;;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  23 ;;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  24 ;;;  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  25 ;;;  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  26 ;;;  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  27 ;;;  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  28 ;;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  29
  30
  31 (in-package :CSS)
  32
  33 (defun create-style-sheet (super-sheet &key (name "Anonymous style sheet")
  34                                             base-url
  35                                             (media-type :all))
  36   (unless base-url
  37     (warn "A proper style sheet has a base url; ~
  38            (While creating style sheet ~S)." name))
  39   (make-style-sheet :super-sheet super-sheet
  40                     :name name
  41                     :base-url base-url
  42                     :rules nil))
  43
  44 (defun style-sheet-relate (sheet selector slot value &optional important-p)
  45   (cond ((gi-selection-p (car (style-sheet-rules sheet)))
  46          (style-sheet-relate-2 sheet selector slot value important-p))
  47         (t
  48          (let ((rule (find selector (style-sheet-rules sheet)
  49                            :test #'equal :key #'rule-selector)))
  50            (unless rule
  51              (setf rule (make-rule :selector selector
  52                                    :specifity (css2-selector-specificity selector)
  53                                    :media-type '???
  54                                    :assignments nil))
  55              (push rule (style-sheet-rules sheet)))
  56            (let ((a (make-assignment
  57                      :selector :unused
  58                      :importantp important-p
  59                      :media-type '???
  60                      :specifity (concatenate 'vector
  61                                   (rule-specifity rule)
  62                                   (vector
  63                                    (progn
  64                                      (style-sheet-j sheet)
  65                                      (incf (style-sheet-j sheet)))))
  66                      :slot slot
  67                      :value value)))
  68              (push a (rule-assignments rule)) )))))
  69
  70 (defun style-sheet-relate-2 (sheet selector slot value important-p)
  71   (let ((q (car (style-sheet-rules sheet)))
  72         (a (make-assignment
  73             :selector :unused
  74             :importantp important-p
  75             :media-type '???
  76             :specifity (concatenate 'vector
  77                          (css2-selector-specificity selector)
  78                          (vector
  79                           (progn
  80                             (style-sheet-j sheet)
  81                             (incf (style-sheet-j sheet)))))
  82             :slot slot
  83             :value value)))
  84     (style-sheet-relate-3 selector q a)))
  85
  86 (defun style-sheet-relate-3 (selector q a)
  87   (let ((gi (find 'gi selector :key #'car)))
  88     (cond ((null gi)
  89            (maphash (lambda (key value)
  90                       ;; xxx okay?
  91                       (setf (gethash key (gi-selection-hashtable q))
  92                         (augment-to-rules value selector selector a))
  93                       )
  94                     (gi-selection-hashtable q))
  95            (setf (gi-selection-default q)
  96              (augment-to-rules (gi-selection-default q) selector selector a)))
  97           (t
  98            (let ((x (gethash (cadr gi) (gi-selection-hashtable q))))
  99              (cond (x
 100                     (setf (gethash (cadr gi) (gi-selection-hashtable q))
 101                       (augment-to-rules x (remove gi selector) selector a)))
 102                    (t
 103                     ;; hmm now we need to shovel all default rules back.
 104                     (setf (gethash (cadr gi) (gi-selection-hashtable q))
 105                       (augment-to-rules nil (remove gi selector) selector a))
 106                     (dolist (y (prog1 (gi-selection-default q)
 107                                  (setf (gi-selection-default q) nil)))
 108                       (dolist (a (rule-assignments y))
 109                         (style-sheet-relate-3 selector q a))))))))))
 110
 111 (defun augment-to-rules (rules selector selector-orig a)
 112   (let ((rule (find selector rules :test #'equal :key #'rule-selector)))
 113     (unless rule
 114       (setf rule (make-rule :selector selector
 115                             :specifity (css2-selector-specificity selector-orig)
 116                             :media-type '???
 117                             :assignments nil))
 118       (push rule rules))
 119     (push a (rule-assignments rule))
 120     rules))
 121
 122 #||
 123 (defun style-sheet->assignments-list (s)
 124   (error "Do not call me")
 125   (let (res)
 126     (setf res (reverse (style-sheet-assignments s)))
 127     (let ((res0 res))
 128       (setq res (stable-sort res #'selector-lessp :key #'assignment-selector))
 129       '(assert (every (lambda (x) (member x res0)) res))
 130       res)))
 131 ||#
 132
 133 ;;; BUGS:
 134 ;; - implicit style
 135 ;; - important
 136 ;;   das habe ich immer noch nicht ganz verstanden.
 137 ;;   ich meine bilden die important regel ein allererstes element fuer den
 138 ;;   specificity vector?!
 139 ;; - style by `style' attribute
 140
 141 ;; implicit style;
 142 ;;   is at start of author style sheet with specificity set to 0
 143
 144 ;; style attribute:
 145 ;;   specificity = #(0 0 1 0 0 inf)
 146 ;;   origin after everything else
 147
 148 ;; This is both compatible with CSS-1
 149
 150 ;; Diese ganze explicite Unterscheidung zwischen Author/User/Default
 151 ;; ist mir etwas zu speziell. (grade bei !important wird das alles
 152 ;; doch etwas merkwürdig!).
 153
 154 (defun find-style (sheet element implicit-style
 155                    &optional (origin 0) (p 0)
 156                              (res (make-array *n-attrs* :initial-element nil)))
 157   ;; handle imported sheets
 158   (dolist (im (style-sheet-imported-sheets sheet))
 159     (multiple-value-setq (res p) (find-style im element nil origin p res)))
 160   ;; handle rules
 161   (dolist (rule (style-sheet-rules sheet))
 162     (cond ((rule-p rule)
 163            (when (css2-selector-matches-p (rule-selector rule) element)
 164              (dolist (a (rule-assignments rule))
 165                (let ()
 166                  (setf res
 167                        (augment-assignment-to-result* (assignment-slot a)
 168                                                       (assignment-value a)
 169                                                       (if (assignment-importantp a) 1 0) ;CSS-1 modell
 170                                                       origin
 171                                                       (svref (assignment-specifity a) 0)
 172                                                       (svref (assignment-specifity a) 1)
 173                                                       (svref (assignment-specifity a) 2)
 174                                                       (+ p (svref (assignment-specifity a) 3))
 175                                                       res)) ))))
 176           ((gi-selection-p rule)
 177            (let ((q (gethash (element-gi element)
 178                              (gi-selection-hashtable rule)
 179                              (gi-selection-default rule))))
 180              (dolist (rule q)
 181                ;; code duplication alert!
 182                (when (css2-selector-matches-p (rule-selector rule) element)
 183                  (dolist (a (rule-assignments rule))
 184                    (let ()
 185                      (setf res
 186                            (augment-assignment-to-result* (assignment-slot a)
 187                                                           (assignment-value a)
 188                                                           (if (assignment-importantp a) 1 0) ;CSS-1 modell
 189                                                           origin
 190                                                           (svref (assignment-specifity a) 0)
 191                                                           (svref (assignment-specifity a) 1)
 192                                                           (svref (assignment-specifity a) 2)
 193                                                           (+ p (svref (assignment-specifity a) 3))
 194                                                           res)) )))))) ))
 195   ;; adjust p
 196   (incf p (style-sheet-j sheet))
 197   ;; handle implicit style
 198   (dolist (k implicit-style)
 199     (let ((prop (car k)) (value (cdr k)))
 200       (setf res (augment-assignment-to-result* prop value
 201                                                0 origin 0 0 0 (prog1 p (incf p))
 202                                                res))))
 203   ;; recurse into super sheets
 204   (cond ((style-sheet-super-sheet sheet)
 205          (setf res
 206                (find-style (style-sheet-super-sheet sheet) element nil (- origin 1) 0 res))))
 207   ;; return what we found
 208   (values res p))
 209
 210 (defun augment-assignment-to-result (property value v res)
 211   (let ((x (svref res (symbol-value property))))
 212     (cond ((null x)
 213            (setf (svref res (symbol-value property))
 214              (list value v)))
 215           ((vector-greater-p v (second x))
 216            (setf (first x) value
 217                  (second x) v)))
 218     res))
 219
 220 (defun augment-assignment-to-result* (property value v1 v2 v3 v4 v5 v6 res)
 221   (let ((x (svref res (symbol-value property))))
 222     (cond ((null x)
 223            (setf (svref res (symbol-value property))
 224              (list value (vector v1 v2 v3 v4 v5 v6))))
 225           ((vector-greater-p* v1 v2 v3 v4 v5 v6 (second x))
 226            (setf (first x) value
 227                  (svref (second x) 0) v1
 228                  (svref (second x) 1) v2
 229                  (svref (second x) 2) v3
 230                  (svref (second x) 3) v4
 231                  (svref (second x) 4) v5
 232                  (svref (second x) 5) v6)))
 233     res))
 234
 235 (defun css2-selector-matches-p (selector element)
 236   ;; here is a kludge
 237   (cond ((and (pseudo-class-matches-p :first-line element)
 238               (not (find '(pclass #.(rod "first-line")) selector
 239                          :test #'equalp)))
 240          (return-from css2-selector-matches-p nil))
 241         ((and (pseudo-class-matches-p :before element)
 242               (not (find '(pclass #.(rod "before")) selector
 243                          :test #'equalp)))
 244          (return-from css2-selector-matches-p nil))
 245         ((and (pseudo-class-matches-p :after element)
 246               (not (find '(pclass #.(rod "after")) selector
 247                          :test #'equalp)))
 248          (return-from css2-selector-matches-p nil))
 249         ((and (pseudo-class-matches-p :first-letter element)
 250               (not (find '(pclass #.(rod "first-letter")) selector
 251                          :test #'equalp)))
 252          (return-from css2-selector-matches-p nil)))
 253   ;;
 254   (dolist (pred selector t)
 255     (unless
 256         (case (car pred)
 257           ((gi) (css2-gi-match-p (cadr pred) element))
 258           ((id) (css2-id-match-p (cadr pred) element))
 259           ((class) (css2-class-match-p (cadr pred) element))
 260
 261           ((attrib-exists)
 262            (not (null (element-attribute element (intern-attribute-name (cadr pred))))))
 263
 264           ((attrib)
 265            (attribute-equal-p element (cadr pred) (caddr pred) nil)) ;CS or CI??
 266
 267           ((attrib-contain)
 268            (attribute-contains-p element (cadr pred) (caddr pred) nil))
 269
 270           ((attrib-contain-dash)
 271            (attribute-contain-dash-p element (cadr pred) (caddr pred) nil))
 272
 273           ((pclass)
 274            (cond ((and (= (length (cdr pred)) 1)
 275                        (rod-equal #.(map 'vector #'char-code "first-child") (cadr pred)))
 276                   (null (pt-predecessor element)))
 277                  ((and (= (length (cdr pred)) 1)
 278                        (rod-equal #.(map 'vector #'char-code "link") (cadr pred)))
 279                   (pseudo-class-matches-p :link element))
 280                  ((and (= (length (cdr pred)) 1)
 281                        (rod-equal #.(map 'vector #'char-code "first-line") (cadr pred)))
 282                   (pseudo-class-matches-p :first-line element))
 283                  ((and (= (length (cdr pred)) 1)
 284                        (rod-equal #.(map 'vector #'char-code "first-letter") (cadr pred)))
 285                   (pseudo-class-matches-p :first-letter element))
 286                  ((and (= (length (cdr pred)) 1)
 287                        (rod-equal #.(map 'vector #'char-code "before") (cadr pred)))
 288                   (pseudo-class-matches-p :before element))
 289                  ((and (= (length (cdr pred)) 1)
 290                        (rod-equal #.(map 'vector #'char-code "after") (cadr pred)))
 291                   (pseudo-class-matches-p :after element))
 292                  ;; lang fehlt.
 293                  (t
 294                   ;; (print (rod-string (cadr pred)))
 295                   nil)))
 296
 297           ((ancestor)
 298            (css2-ancester-match-p (cdr pred) element))
 299
 300           ((parent)
 301            (and (element-parent element)
 302                 (css2-selector-matches-p (cdr pred) (element-parent element))))
 303           ((preceded-by)
 304            (let ((prec (pt-predecessor element)))
 305              (and prec
 306                   (css2-selector-matches-p (cdr pred) prec))))
 307           (t
 308            t))
 309       (return nil) )))
 310
 311 (defun vector-greater-p (v1 v2)
 312   (dotimes (i (length v1) nil)
 313     (let ((a (aref v1 i))
 314           (b (aref v2 i)))
 315       (cond ((> a b) (return t))
 316             ((< a b) (return nil))))))
 317
 318 (defun vector-greater-p* (v1 v2 v3 v4 v5 v6 w)
 319   (block nil
 320     (let ((a v1)
 321           (b (aref w 0)))
 322       (cond ((> a b) (return t))
 323             ((< a b) (return nil))))
 324     (let ((a v2)
 325           (b (aref w 1)))
 326       (cond ((> a b) (return t))
 327             ((< a b) (return nil))))
 328     (let ((a v3)
 329           (b (aref w 2)))
 330       (cond ((> a b) (return t))
 331             ((< a b) (return nil))))
 332     (let ((a v4)
 333           (b (aref w 3)))
 334       (cond ((> a b) (return t))
 335             ((< a b) (return nil))))
 336     (let ((a v5)
 337           (b (aref w 4)))
 338       (cond ((> a b) (return t))
 339             ((< a b) (return nil))))
 340     (let ((a v6)
 341           (b (aref w 5)))
 342       (cond ((> a b) (return t))
 343             ((< a b) (return nil)))) ))
 344
 345 (defun pt-predecessor (pt)
 346   (let ((par (element-parent pt)))
 347     (and par
 348          (let ((r nil))
 349            (dolist (k (element-children par))
 350              (when (eq k pt)
 351                (return r))
 352              (unless (text-element-p k)
 353                (setf r k)))))))
 354
 355 (defun css2-ancester-match-p (selector element)
 356   (and (element-parent element)
 357        (or (css2-selector-matches-p selector (element-parent element))
 358            (css2-ancester-match-p selector (element-parent element)))))
 359
 360 ;; class, id are case-sensitive in HTML
 361
 362 (defun attribute-contains-p (element attribute string case-sensitive-p)
 363   (let ((v (element-attribute element (intern-attribute-name attribute))))
 364     (and v (rod-contains-p v string case-sensitive-p))))
 365
 366 (defun attribute-equal-p (element attribute string case-sensitive-p)
 367   (let ((v (element-attribute element (intern-attribute-name attribute))))
 368     (and v
 369          (if case-sensitive-p
 370              (rod= v string)
 371            (rod-equal v string)))))
 372
 373 (defun rod-contains-p (haystack needle case-sensitive-p)
 374   ;; what should (rod-contains-p .. "" ..) yield?
 375   (dotimes (i (- (length haystack) (length needle) -1) nil)
 376     (when (and (or (= i 0)
 377                    (white-space-rune-p (rune haystack (1- i))))
 378                (or (= (+ i (length needle)) (length haystack))
 379                    (white-space-rune-p (rune haystack (+ i (length needle))))))
 380       (when (dotimes (j (length needle) t)
 381               (unless (if case-sensitive-p
 382                           (rune= (rune needle j) (rune haystack (+ i j)))
 383                         (rune-equal (rune needle j) (rune haystack (+ i j))))
 384                 (return nil)))
 385         (return t)))))
 386
 387 (defun attribute-contain-dash-p (element attribute string case-sensitive-p)
 388   (let ((v (element-attribute element (intern-attribute-name attribute))))
 389     (and v
 390          (>= (length v) (length string))
 391          (if case-sensitive-p
 392              (rod= (subseq v 0 (length string)) string)
 393            (rod-equal (subseq v 0 (length string)) string))
 394          (or (= (length string) (length v))
 395              (rune= (code-rune #.(char-code #\-)) (rune v (length string)))))))
 396
 397 (defun skip-group (seq p &optional (level 0))
 398   (cond ((>= p (length seq))
 399          nil)
 400         ((= (aref seq p) #.(char-code #\{))
 401          (skip-group seq (+ p 1) (+ level 1)))
 402         ((= (aref seq p) #.(char-code #\}))
 403          (cond ((= level 1) p)
 404                ((skip-group seq (+ p 1) (- level 1)))))
 405         ((skip-group seq (+ p 1) level))))
 406
 407 (defun parse-at-rule-body (seq p0)
 408   ;; An at-rule consists of everything up to and including the next
 409   ;; semicolon (;) or the next block (defined shortly), whichever comes
 410   ;; first.
 411   (do ((i p0 (+ i 1)))
 412       ((= i (length seq))
 413        (warn "EOF before at-rule group.")
 414        (values (length seq)))
 415     (cond ((= (aref seq i) #.(char-code #\;))
 416            (return (values (+ i 1))))
 417           ((= (aref seq i) #.(char-code #\{))
 418            (let ((p1 (skip-group seq i)))
 419              (cond ((null p1)
 420                     (warn "EOF within at-rule group.")
 421                     (return (values nil (length seq))))
 422                    (t
 423                     (return (values (+ p1 1))))))) )))
 424
 425 (defstruct import-rule
 426   url-str
 427   media-type)
 428
 429 (defun parse-media-type-2 (toks)
 430   (let ((r (p/comma-separated-list toks (lambda (x)
 431                                           (let ((r (p/ident x)))
 432                                             (and r (cons (list (intern (string-upcase (car r))
 433                                                                        :keyword))
 434                                                          (cdr r))))))))
 435     (and r
 436          (cons (cons 'or (car r)) (cdr r)))))
 437
 438 (defun parse-media-type (string)
 439   ;; xxx unicode!
 440   (let ((r (parse-media-type-2
 441             (tokenize
 442              (slurp
 443               (cl-char-stream->gstream
 444                (make-string-input-stream string)))))))
 445     (cond ((and r (null (cdr r)))
 446            (car r))
 447           (t
 448            (warn "Bad media type: ~S." string)
 449            nil))))
 450
 451 (defun parse-import-rule (seq)
 452   (let ((toks (tokenize seq))
 453         (media-type :all))
 454     (let ((r (or (p/string toks)
 455                  (p/url toks))))
 456       (when (cdr r)
 457         (let ((s (parse-media-type-2 (cdr r))))
 458           (setf (cdr r) (cdr s)
 459                 media-type (car s))))
 460       (cond ((and r (null (cdr r)))
 461              (let ((url (car r)))
 462                (list (make-import-rule :url-str url :media-type media-type))))
 463             (t
 464              (warn "CSS @import rule does not parse: ~S." (as-string seq))
 465              nil)))))
 466
 467 (defun parse-at-rule (seq start import-ok?)
 468   (let (p1 p2)
 469     (assert (= (aref seq start) #.(char-code #\@)))
 470     (unless (setq p1 (parse-ident seq (+ start 1)))
 471       (warn "Bad syntax: An '@' must be followed by an identifier")
 472       (setf p1 (+ start 1)))
 473     (setq p2 (parse-at-rule-body seq p1))
 474     (cond ((and p1 p2)
 475            (let ((ident (as-string (subseq seq (+ start 1) p1))))
 476              (cond ((string-equal ident "import")
 477                     (if import-ok?
 478                         (values (parse-import-rule (subseq seq p1 p2))
 479                                 p2)
 480                       (progn
 481                         (parse-import-rule (subseq seq p1 p2))
 482                         (warn "@import not at start of style sheet - ignored.")
 483                         (values nil p2))))
 484                    ((string-equal ident "media")
 485                     (values nil p2)
 486                     )
 487                    (t
 488                     (values nil p2)))))
 489           (t
 490            (values nil (length seq))) )))
 491
 492 (defun assignment-list-adjoin (new assignments)
 493   (cons (cons (reverse (car new)) (cdr new)) assignments))
 494
 495 ;;;; new CSS-2 selectors
 496
 497 (defun nmchar-p (ch)
 498   (or (<= #.(char-code #\a) ch #.(char-code #\z))
 499       (<= #.(char-code #\A) ch #.(char-code #\Z))
 500       (<= #.(char-code #\0) ch #.(char-code #\9))
 501       (= ch #.(char-code #\-))
 502       (>= ch 128)))
 503
 504 (defun nmstart-p (ch)
 505   (or (<= #.(char-code #\a) ch #.(char-code #\z))
 506       (<= #.(char-code #\A) ch #.(char-code #\Z))
 507       (>= ch 128)))
 508
 509 (defun q-cons-rod (string start end)
 510   (let ((res (make-array (- end start) :element-type 'rune)))
 511     (dotimes (i (- end start))
 512       (setf (%rune res i) (code-rune
 513                            (logand #xFFFF (aref string (+ i start))))))
 514     res))
 515
 516 (defun q-token (string start end) ;;-> type semantic new-start
 517   (let (p)
 518     (cond ((>= start end)
 519            (values :eof nil start))
 520           (t
 521            (let ((c (aref string start)))
 522              (cond ((= c #.(char-code #\>)) (values :> nil (+ start 1)))
 523                    ((= c #.(char-code #\+)) (values :+ nil (+ start 1)))
 524                    ((= c #.(char-code #\*)) (values :* nil (+ start 1)))
 525                    ((= c #.(char-code #\[)) (values :|[| nil (+ start 1)))
 526                    ((= c #.(char-code #\])) (values :|]| nil (+ start 1)))
 527                    ((= c #.(char-code #\.)) (values :|.| nil (+ start 1)))
 528                    ((= c #.(char-code #\=)) (values :|=| nil (+ start 1)))
 529                    ((= c #.(char-code #\:)) (values :|:| nil (+ start 1)))
 530                    ((= c #.(char-code #\()) (values :|(| nil (+ start 1)))
 531                    ((= c #.(char-code #\))) (values :|)| nil (+ start 1)))
 532                    ((= c #.(char-code #\,)) (values :|,| nil (+ start 1)))
 533                    ((and (= c #.(char-code #\~))
 534                          (< (+ start 1) end)
 535                          (= (aref string (+ start 1)) #.(char-code #\=)))
 536                     (values :|~=| nil (+ start 2)))
 537                    ((and (= c #.(char-code #\|))
 538                          (< (+ start 1) end)
 539                          (= (aref string (+ start 1)) #.(char-code #\=)))
 540                     (values :\|= nil (+ start 2)))
 541                    ((and (= c #.(char-code #\#))
 542                          ;; ID selectors cannot start with an digit
 543                          ;; xxx is that true?
 544                          (nmstart-p (aref string (+ start 1)))
 545                          (setq p (or (position-if-not #'nmchar-p string :start (+ start 1) :end end)
 546                                      end))
 547                          (> p (+ 1 start)))
 548                     (values :hash (q-cons-rod string (+ start 1) p) p))
 549                    ((and (nmstart-p c)
 550                          (setq p (or (position-if-not #'nmchar-p string :start (+ start 1) :end end)
 551                                      end)))
 552                     (values :ident (q-cons-rod string start p) p))
 553                    ((and (= c #.(char-code #\'))
 554                          (setq p (position #.(char-code #\') string :start (+ start 1) :end end)))
 555                     (values :string (q-cons-rod string (+ start 1) p) (+ p 1)))
 556                    ((and (= c #.(char-code #\"))
 557                          (setq p (position #.(char-code #\") string :start (+ start 1) :end end)))
 558                     (values :string (q-cons-rod string (+ start 1) p) (+ p 1)))
 559                    ((member c '(9 10 12 13 32))
 560                     (values :s nil (+ start 1)))
 561                    (t
 562                     (values :junk c (+ start 1))) ))))))
 563
 564 ;;; traditional recursive descent parser for CSS-2 selectors
 565
 566 ;; Each selector is a simple list of predicates, which must turn for
 567 ;; this selector to match; the predicates produced by the parser are:
 568
 569 ;; (GI string)
 570 ;;     the GI of element must be 'string'
 571 ;; (CLASS string)
 572 ;;     the class attribute of the element must contain 'string'
 573 ;; (ID string)
 574 ;;     the ID attribute of the element must be 'string'
 575 ;; (ATTRIB attr string)
 576 ;;     the attribute given by 'attr' must be 'string'
 577 ;; (ATTRIB-EXISTS attr string)
 578 ;;     the attribute given by 'attr' must exist (been set)
 579 ;; (ATTRIB-CONTAIN attr string)
 580 ;;     the attribute given by 'attr' must contain 'string'
 581 ;; (ATTRIB-CONTAIN-DASH attr string)
 582 ;;     the attribute given by 'attr' must contain 'string' (dash variant)
 583 ;; (PCLASS name [argument])
 584 ;;     the element must belong to the given pseudo class
 585 ;; (ANCESTOR . predicates)
 586 ;;     there must be an anchestor matching the selector 'predicates'
 587 ;; (PARENT . predicates)
 588 ;;     the element must have a parent matching the selector 'predicates'
 589 ;; (PRECEDED-BY . predicates)
 590 ;;     the element must have be preceded by an element matching the selector 'predicates'
 591
 592 ;; Example
 593 ;; =======
 594 ;; "A B C[x]" => ((GI "C")
 595 ;;                (ATTRIB-EXISTS "x")
 596 ;;                (ANCESTOR (GI "B")
 597 ;;                          (ANCESTOR (GI "A"))))
 598
 599
 600
 601 (defvar *tok*)
 602 (defvar *sem*)
 603 (defvar *i*)
 604 (defvar *s*)
 605 (defvar *e*)
 606
 607 (defun parse-css2-selector-list (string &optional (start 0) (end (length string)))
 608   (let ((res
 609          (let* ((*s* string)
 610                 (*e* end)
 611                 (*i* start))
 612            (q/consume)
 613            (q/s*)
 614            (prog1
 615                (q/selector-list)
 616              (q/s*)
 617              (unless (eq (q/tok) :eof)
 618                (error "Unexpected token ~S." (q/tok)))))))
 619     (setq res
 620       (mapcar (lambda (selector)
 621                 (let ((x (find 'gi selector :key #'car)))
 622                   (if x
 623                       (cons x (remove x selector))
 624                     selector)))
 625               res))
 626     res))
 627
 628
 629 (defun q/tok () *tok*)
 630 (defun q/sem () *sem*)
 631 (defun q/at? (tok) (eq *tok* tok))
 632
 633 (defun q/consume ()
 634   (multiple-value-bind (tok sem j) (q-token *s* *i* *e*)
 635     (setf *tok* tok)
 636     (setf *sem* sem)
 637     (setf *i* j)))
 638
 639 (defun q/selector-list ()
 640   (let ((x (q/selector)))
 641     (cond ((eq (q/tok) :|,|)
 642            (q/consume)
 643            (q/s*)
 644            (cons x (q/selector-list)))
 645           (t
 646            (list x)))))
 647
 648 (defun q/selector ()
 649   (let ((res nil))
 650     (tagbody
 651       loob
 652       (let ((a (q/simple-selector)))
 653         (q/S*)
 654         (push a res)
 655         (cond ((member (q/tok) '(:ident :hash :|.| :|[| :|:| :|*|))
 656                (push 'ancestor res)
 657                (go loob))
 658               ((eq (q/tok) :>)
 659                (q/consume)
 660                (q/s*)
 661                (push 'parent res)
 662                (go loob))
 663               ((eq (q/tok) :+)
 664                (q/consume)
 665                (q/s*)
 666                (push 'preceded-by res)
 667                (go loob))
 668               (t
 669                (go fin))))
 670      fin)
 671     (parse-combinator-sequence res)))
 672
 673 (defun parse-combinator-sequence (q)
 674   (cond ((null (cdr q)) (car q))
 675         (t
 676          (append (car q)
 677                  (list (cons (cadr q)
 678                              (parse-combinator-sequence (cddr q))))))))
 679
 680
 681
 682 (defun q/simple-selector ()
 683   (multiple-value-bind (element presentp) (q/maybe-element-name)
 684     (let ((modifiers nil)
 685           x)
 686       (unless presentp
 687         (setq x (q/maybe-modifier))
 688         (unless x
 689           (error "When there is no element name at least one modifiers is required."))
 690         (setf modifiers (append modifiers (list x))))
 691       (loop
 692         (setq x (q/maybe-modifier))
 693         (cond (x
 694                (setf modifiers (append modifiers (list x))))
 695               ((null x)
 696                (return))))
 697       (q/s*)
 698       ;; xxx does this apply to CSS2 as well.
 699       ;; xxx also this looks like some bogus random implementation limitation.
 700       (when (member-if-not (lambda (x) (and (consp x) (eq (car x) 'pclass)))
 701                            (member-if (lambda (x) (and (consp x) (eq (car x) 'pclass)))
 702                                       modifiers))
 703         (error "Psuedoclass in non trailing location: ~S." modifiers))
 704       ;;
 705       (append element modifiers))))
 706
 707 (defun q/s* ()
 708   (while (q/at? :s) (q/consume)))
 709
 710 (defun q/maybe-modifier ()
 711   (case (q/tok)
 712     (:hash (prog1 (list 'ID (q/sem)) (q/consume)))
 713     (:|.|
 714       (q/consume)
 715       (cond ((eq (q/tok) :ident)
 716              (prog1 (list 'CLASS (q/sem)) (q/consume)))
 717             (t
 718              (error "Parse error: Expected <ident> after \".\""))))
 719     (:|[|
 720       (q/attrib))
 721     (:|:|
 722       (q/pclass))
 723     (t
 724      nil) ))
 725
 726 (defun q/expect (tok)
 727   (unless (eq (q/tok) tok)
 728     (error "Expected ~A." tok))
 729   (prog1 (q/sem)
 730     (q/consume)))
 731
 732 (defun q/attrib ()
 733   (let (name x)
 734     (q/expect :|[|)
 735     (q/s*)
 736     (setf name
 737       (q/expect :ident))
 738     (q/s*)
 739     (setf x (q/maybe-attribut-value name))
 740     (q/expect :|]|)
 741     x))
 742
 743 (defun q/maybe-attribut-value (name)
 744   (case (q/tok)
 745     (:=
 746      (q/consume)
 747      (q/s*)
 748      (prog1 (list 'attrib name (q/maybe-attribut-value-2))
 749        (q/s*)) )
 750     (:\~=
 751      (q/consume)
 752      (q/s*)
 753      (prog1 (list 'attrib-contain name  (q/maybe-attribut-value-2))
 754        (q/s*)) )
 755     (:\|=
 756      (q/consume)
 757      (q/s*)
 758      (prog1 (list 'attrib-contain-dash name (q/maybe-attribut-value-2))
 759        (q/s*)) )
 760     (t
 761      (list 'attrib-exists name))))
 762
 763 (defun q/pclass ()
 764   (let (nam arg)
 765     (q/expect :|:|)
 766     (setf nam (q/expect :ident))
 767     (cons 'pclass
 768           (cond ((eq (q/tok) :|(|)
 769                  (q/consume)
 770                  (q/s*)
 771                  (setf arg (q/expect :ident))
 772                  (q/s*)
 773                  (q/expect :|)|)
 774                  (list nam arg))
 775                 (t
 776                  (list nam))))))
 777
 778
 779 (defun q/maybe-attribut-value-2 ()
 780   (unless (member (q/tok) '(:ident :string))
 781     (error "Expected either a string or an ident here."))
 782   (prog1
 783       (q/sem)
 784     (q/consume)))
 785
 786 (defun q/maybe-element-name ()
 787   (cond ((q/at? :ident)
 788          (multiple-value-prog1
 789              (values (list (list 'GI (intern-gi (q/sem)))) t)
 790            (q/consume)))
 791         ((q/at? :*)
 792          (multiple-value-prog1
 793              (values nil t)
 794            (q/consume)))
 795         (t
 796          (values nil nil))))
 797
 798 ;;;;
 799
 800 (defun css2-selector-specificity (selector)
 801   (let ((res (vector 0 0 0)))
 802     (dolist (p selector)
 803       (case (car p)
 804         ((gi) (incf (aref res 2)))
 805         ((id) (incf (aref res 0)))
 806         ((class attrib attrib-exists attrib-contain attrib-contain-dash pclass)
 807          (incf (aref res 1)))
 808         ((ancestor parent preceded-by)
 809          (setf res (map 'vector #'+ res (css2-selector-specificity (cdr p)))))))
 810     res))
 811
 812 (defun parse-style-sheet* (seq &optional (start 0) (import-ok? t))
 813   (let (p0 p1)
 814     (when (setq p0 (position-if-not #'white-space-p* seq :start start))
 815       (cond
 816         ((= (aref seq p0) #.(char-code #\@))
 817          (multiple-value-bind (v p1) (parse-at-rule seq p0 import-ok?)
 818            (nconc v (parse-style-sheet* seq p1 import-ok?))))
 819         ((setq p1 (position (char-code #\{) seq :start p0))
 820          (let ((p2 (skip-group seq p1)))
 821            (cond ((null p2)
 822                   (warn "EOF while parsing CSS group.")
 823                   nil)
 824                  (t
 825                   (multiple-value-bind (sel-list condition)
 826                       (ignore-errors (parse-css2-selector-list seq p0 p1))
 827                     (cond (condition
 828                            (warn "CSS selector list does not parse: `~A'."
 829                                  (as-string (subseq seq p0 p1)))
 830                            (setq sel-list nil)))
 831                     (nconc (multiplex-selectors sel-list
 832                                                 (parse-assignment-list
 833                                                  (subseq seq (+ p1 1) p2)))
 834                            (parse-style-sheet* seq (+ p2 1) nil)) )))))
 835             (t
 836              (warn "Bad css syntax: ~A" (as-string seq))
 837              nil)))))
 838
 839
 840 (defun lookup-all-style (style-sheet pt is ss res)
 841   (multiple-value-bind (x p) (find-style style-sheet pt is)
 842     (dolist (k (reverse ss))
 843       (let ((prop (assignment-slot k))
 844             (value (assignment-value k))
 845             (importantp (assignment-importantp k)))
 846         (setf x (augment-assignment-to-result prop value (vector (if importantp 1 0) 0 1 0 0
 847                                                                  (incf p))
 848                                               x))))
 849     (dotimes (i (length x))
 850       (let ((q (svref x i)))
 851         (when q
 852           (setf (svref res i) (first q)))))
 853     res))
 854
 855
 856 ;;;; Media Types
 857
 858 (defparameter *media-types*
 859     '(:screen :all))
 860
 861 (defmethod is-of-media-type-p ((medium T) (media-type (eql :all))) t)
 862 (defmethod is-of-media-type-p ((medium (eql :screen)) (media-type (eql :screen))) t)
 863
 864 (defmethod is-of-media-type-p ((medium T) (media-type T))
 865   nil)
 866
 867 (defmethod is-of-media-type-p ((medium T) (media-type cons))
 868   (ecase (car media-type)
 869     ((OR)
 870      (some (curry #'is-of-media-type-p medium) media-type))
 871     ((AND)
 872      (every (curry #'is-of-media-type-p medium) media-type))))
 873
 874 (defun intern-media-type (rod)
 875   (intern-attribute-name rod))
 876
 877 ;; TODO
 878 ;; - parse-media-type is borken/ugly
 879 ;; - parse-style-sheet -- fixed :screen media type is borken
 880 ;; - p/ident is not unicode safe!
 881 ;; - some how we broke "CSS1 Test Suite: LINK and @import" ;-(
 882