cgit.sxemacs.org Git - packages/blob - xemacs-packages/w3/lisp/css.el

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