--- a/lisp/w3/w3-style.el	Mon Aug 13 09:05:44 2007 +0200
+++ b/lisp/w3/w3-style.el	Mon Aug 13 09:06:37 2007 +0200
@@ -1,13 +1,14 @@
 ;;; w3-style.el --- Emacs-W3 binding style sheet mechanism
 ;; Author: wmperry
-;; Created: 1996/08/12 03:10:30
-;; Version: 1.13
+;; Created: 1996/12/13 18:01:46
+;; Version: 1.23
 ;; Keywords: faces, hypermedia
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Copyright (c) 1993 - 1996 by William M. Perry (wmperry@cs.indiana.edu)
+;;; Copyright (c) 1996 Free Software Foundation, Inc.
 ;;;
-;;; This file is not part of GNU Emacs, but the same permissions apply.
+;;; This file is part of GNU Emacs.
 ;;;
 ;;; GNU Emacs is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
@@ -20,8 +21,9 @@
 ;;; GNU General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Emacs; see the file COPYING.  If not, write to
-;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;;; Boston, MA 02111-1307, USA.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -33,518 +35,9 @@
 (require 'font)
 (require 'w3-keyword)
 (require 'cl)
-
-(defvar w3-style-css-syntax-table
-  (copy-syntax-table mm-parse-args-syntax-table)
-  "The syntax table for parsing stylesheets")
-
-(defvar w3-style-ie-compatibility nil
-  "*Whether we want to do Internet Explorer 3.0 compatible parsing of
-CSS stylesheets.")
-
-(defun w3-style-css-parse-args (st &optional nd defines)
-  ;; Return an assoc list of attribute/value pairs from a CSS style entry
-  (let (
-	name				; From name=
-	value				; its value
-	results				; Assoc list of results
-	name-pos			; Start of XXXX= position
-	val-pos				; Start of value position
-	)
-    (save-excursion
-      (if (stringp st)
-	  (progn
-	    (set-buffer (get-buffer-create " *w3-style-temp*"))
-	    (set-syntax-table w3-style-css-syntax-table)
-	    (erase-buffer)
-	    (insert st)
-	    (setq st (point-min)
-		  nd (point-max)))
-	(set-syntax-table w3-style-css-syntax-table))
-      (save-restriction
-	(if (< nd st)
-	    (narrow-to-region nd nd)
-	  (narrow-to-region st nd))
-	(goto-char (point-min))
-	(while (not (eobp))
-	  (skip-chars-forward ";, \n\t")
-	  (setq name-pos (point))
-	  (skip-chars-forward "^ \n\t:=,;")
-	  (downcase-region name-pos (point))
-	  (setq name (buffer-substring name-pos (point)))
-	  (skip-chars-forward " \t\n")
-	  (if (not (eq (char-after (point)) ?:)) ; There is no value
-	      (setq value nil)
-	    (skip-chars-forward " \t\n:")
-	    (setq val-pos (point)
-		  value
-		  (cond
-		   ((or (= (or (char-after val-pos) 0) ?\")
-			(= (or (char-after val-pos) 0) ?'))
-		    (buffer-substring (1+ val-pos)
-				      (condition-case ()
-					  (prog2
-					      (forward-sexp 1)
-					      (1- (point))
-					    (skip-chars-forward "\""))
-					(error
-					 (skip-chars-forward "^ \t\n")
-					 (point)))))
-		   (t
-		    (buffer-substring val-pos
-				      (progn
-					(if w3-style-ie-compatibility
-					    (skip-chars-forward "^;")
-					  (skip-chars-forward "^,;"))
-					(skip-chars-backward " \t")
-					(point)))))))
-	  (setq results (cons (cons name value) results))
-	  (skip-chars-forward ";, \n\t"))
-	results))))
-
-(defvar w3-style-css-define-table nil)
-
-(defun w3-style-css-handle-define ()
-  (let ((name nil)
-	(save-pos (point))
-	(retval nil))
-    (skip-chars-forward "^ \t\r\n") ; Past the name token
-    (downcase-region save-pos (point))
-    (setq name (buffer-substring save-pos (point)))
-    (skip-chars-forward "= \t\r")
-    (setq save-pos (point))
-    (skip-chars-forward "^;")
-    (setq retval (cons name (buffer-substring save-pos (point))))
-    (skip-chars-forward " \t\r\n")
-    retval))
-
-(defun w3-style-css-handle-import ()
-  (let ((url nil)
-	(save-pos (point)))
-    (if (looking-at "'\"")
-	(condition-case ()
-	    (forward-sexp 1)
-	  (error (skip-chars-forward "^ \t\r\n;")))
-      (skip-chars-forward "^ \t\r\n;"))
-    (setq url (url-expand-file-name (buffer-substring save-pos (point))))
-    (skip-chars-forward "\"; \t\r\n")
-    (setq save-pos (point))
-    (let ((url-working-buffer (url-generate-new-buffer-name " *styleimport*"))
-	  (url-mime-accept-string
-	   "text/css ; level=2")
-	  (sheet nil))
-      (save-excursion
-	(set-buffer (get-buffer-create url-working-buffer))
-	(setq url-be-asynchronous nil)
-	(url-retrieve url)
-	(w3-style-css-clean)
-	(setq sheet (buffer-string))
-	(set-buffer-modified-p nil)
-	(kill-buffer (current-buffer)))
-      (insert sheet)
-      (goto-char save-pos))))
-
-(defun w3-style-css-clean ()
-  ;; Nuke comments, etc.
-  (goto-char (point-min))
-  (let ((save-pos nil))
-    (while (search-forward "/*" nil t)
-      (setq save-pos (- (point) 2))
-      (delete-region save-pos
-		     (if (search-forward "*/" nil t)
-			 (point)
-		       (end-of-line)
-		       (point)))))
-  (goto-char (point-min))
-  (delete-matching-lines "^[ \t\r]*$")	; Nuke blank lines
-  (w3-replace-regexp "^[ \t\r]+" "")	; Nuke whitespace at beg. of line
-  (w3-replace-regexp "[ \t\r]+$" "")	; Nuke whitespace at end of line
-  (goto-char (point-min)))
-
-(defun w3-style-css-applies-to (st nd)
-  (let ((results nil)
-	(save-pos nil))
-    (narrow-to-region st nd)
-    (goto-char st)
-    (skip-chars-forward " \t\r\n")
-    (while (not (eobp))
-      (setq save-pos (point))
-      (skip-chars-forward "^,")
-      (skip-chars-backward " \r\t\n")
-      (setq results (cons (buffer-substring save-pos (point)) results))
-      (skip-chars-forward ", \t\r\n"))
-    (widen)
-    results))
-
-(defun w3-style-active-device-types (&optional device)
-  (let ((types (list 'normal 'default (if w3-running-xemacs 'xemacs 'emacs)))
-	(type (device-type device)))
-    (cond
-     ((featurep 'emacspeak)
-      (setq types (cons 'speech types)))
-     ((eq type 'tty)
-      (if (and (fboundp 'tty-color-list)
-	       (/= 0 (length (tty-color-list))))
-	  (setq types (cons 'ansi-tty types))
-	(setq types (cons 'tty types))))
-     ((eq 'color (device-class))
-      (if (not (device-bitplanes))
-	  (setq types (cons 'color types))
-	(setq types
-	      (append
-	       (list (intern (format "%dbit-color"
-				     (device-bitplanes)))
-		     (intern (format "%dbit"
-				     (device-bitplanes)))
-		     'color) types))
-	(if (= 24 (device-bitplanes))
-	    (setq types (cons 'truecolor types)))))
-     ((eq 'grayscale (device-class))
-      (setq types (append (list (intern (format "%dbit-grayscale"
-						(device-bitplanes)))
-				'grayscale)
-			  types)))
-     ((eq 'mono (device-class))
-      (setq types (append (list 'mono 'monochrome) types)))
-     (t
-      (setq types (cons 'unknown types))))
-    types))
-
-(defun w3-style-parse-css (fname &optional string inherit)
-  (let (
-	(url-mime-accept-string
-	 "text/css ; level=2")
-	(save-pos nil)
-	(applies-to nil)		; List of tags to apply style to
-	(attrs nil)			; List of name/value pairs
-	(tag nil)
-	(att nil)
-	(cur nil)
-	(val nil)
-	(class nil)
-	(defines nil)
-	(device-type nil)
-	(active-device-types (w3-style-active-device-types (selected-device)))
-	(sheet inherit))
-    (save-excursion
-      (set-buffer (get-buffer-create
-		   (url-generate-new-buffer-name " *style*")))
-      (set-syntax-table w3-style-css-syntax-table)
-      (erase-buffer)
-      (if fname (url-insert-file-contents fname))
-      (goto-char (point-max))
-      (if string (insert string))
-      (w3-style-css-clean)
-      (goto-char (point-min))
-      (while (not (eobp))
-	(setq save-pos (point))
-	(cond
-	 ;; *sigh* SGML comments are being used to 'hide' data inlined
-	 ;; with the <style> tag from older browsers.
-	 ((or (looking-at "<!--+")	; begin
-	      (looking-at "--+>"))	; end
-	  (goto-char (match-end 0)))
-	 ;; C++ style comments, and we are doing IE compatibility
-	 ((and (looking-at "//") w3-style-ie-compatibility)
-	  (end-of-line))
-	 ;; Pre-Processor directives
-	 ((looking-at "[ \t\r]*@\\([^ \t\r\n]\\)")
-	  (let ((directive nil))
-	    (skip-chars-forward " @\t\r") ; Past any leading whitespace
-	    (setq save-pos (point))
-	    (skip-chars-forward "^ \t\r\n") ; Past the @ directive
-	    (downcase-region save-pos (point))
-	    (setq directive (buffer-substring save-pos (point)))
-	    (skip-chars-forward " \t\r") ; Past any trailing whitespace
-	    (setq save-pos (point))
-	    (cond
-	     ((string= directive "define")
-	      (let ((retval (w3-style-css-handle-define)))
-		(and defines
-		     (setq defines (cons retval defines)))))
-	     ((string= directive "import")
-	      (w3-style-css-handle-import))
-	     (t
-	      (w3-warn 'style (format "Unknown directive: @%s" directive)
-		       'warning)))))
-	 ;; Giving us some output device information
-	 ((looking-at "[ \t\r]*:\\([^: \n]+\\):")
-	  (downcase-region (match-beginning 1) (match-end 1))
-	  (setq device-type (intern (buffer-substring (match-beginning 1)
-						      (match-end 1))))
-	  (goto-char (match-end 0))
-	  (if (not (memq device-type active-device-types))
-	      ;; Not applicable to us... skip the info
-	      (progn
-		(if (re-search-forward ":[^:{ ]*:" nil t)
-		    (goto-char (match-beginning 0))
-		  (goto-char (point-max))))))
-	 ;; Default is to treat it like a stylesheet declaration
-	 (t
-	  (skip-chars-forward "^{")
-	  ;;(downcase-region save-pos (point))
-	  (setq applies-to (w3-style-css-applies-to save-pos (point)))
-	  (skip-chars-forward "^{")
-	  (setq save-pos (point))
-	  (forward-sexp 1)
-	  (end-of-line)
-	  (skip-chars-backward "\r}")
-	  (subst-char-in-region save-pos (point) ?\n ? )
-	  (subst-char-in-region save-pos (point) ?\r ? )
-	  (setq attrs (w3-style-css-parse-args (1+ save-pos)
-					   (point) defines))
-	  (skip-chars-forward "}\r\n")
-	  (while applies-to
-	    (setq cur (car applies-to)
-		  applies-to (cdr applies-to))
-	    (cond
-	     ((string-match "\\([^.]*\\)\\.\\(.*\\)" cur) ; Normal class
-	      (setq tag (intern (downcase (match-string 1 cur)))
-		    class (match-string 2 cur)))
-	     ((string-match "\\(.*\\):\\(.*\\)" cur) ; Pseudo class
-	      (setq tag (intern (downcase (match-string 1 cur)))
-		    class (match-string 2 cur)))
-	     (t				; No class - global
-	      (setq tag (intern (downcase cur))
-		    class 'internal)))
-	    (let ((loop attrs))
-	      (while loop
-		(if (stringp (car (car loop)))
-		    (setcar (car loop) (intern (car (car loop)))))
-		(setq att (car (car loop))
-		      val (cdr (car loop))
-		      loop (cdr loop))
-		(case att
-		 ((align textalign text-align display white-space)
-		  (setq val (intern (downcase val))))
-		 ((indent left-margin right-margin top-margin bottom-margin)
-		  (setq val (string-to-int val)))
-		 (otherwise
-		  nil))
-		(let* ((node-1 (assq tag sheet))
-		       (node-2 (and node-1 (assoc class node-1)))
-		       (node-3 (and node-2 (assq att node-2))))
-		  (cond
-		   ((not node-1)	; New top-level element
-		    (setq sheet (cons (cons tag (list (cons class
-							    (list
-							     (cons att val)))))
-				      sheet)))
-		   ((and node-1 (not node-2)) ; New class for existing element
-		    (setcdr node-1 (cons (cons class (list (cons att val)))
-					 (cdr node-1))))
-		   ((and node-2 (not node-3)) ; attribute/value on old class
-		    (setcdr node-2 (cons (cons att val) (cdr node-2))))
-		   (node-3		; Replace existing attribute value
-		    (setcdr node-3 val)))))))))
-	(skip-chars-forward " \t\r\n"))
-      (set-buffer-modified-p nil)
-      (kill-buffer (current-buffer)))
-    (cons sheet defines)))
+(require 'css)
 
 
-(defvar w3-style-font-size-mappings
-  '(("xx-small" . 0)
-    ("x-small"  . 1)
-    ("small"    . 2)
-    ("medium"   . 3)
-    ("large"    . 4)
-    ("x-large"  . 5)
-    ("xx-large" . 6)
-    )
-  "A list of font size mappings")
-
-(defvar w3-style-font-weight-mappings
-  '(("-3" . :extra-light)
-    ("-2" . :light)
-    ("-1" . :demi-light)
-    ("0"  . :medium)
-    ("1"  . :normal)
-    ("2"  . :demi-bold)
-    ("3"  . :bold)
-    ("4"  . :extrabold)
-    ("bold"       . :bold)
-    ("demi-light" . :demi-light)
-    ("demi-bold"  . :demi-bold)
-    ("extra-bold" . :extra-bold)
-    ("extra-light". :extra-light)
-    )
-  "A list of font weight mappings.")
-
-(defun w3-style-font-size-for-index (index)
-  (if (stringp index)
-      (setq index (or
-		   (cdr-safe (assoc (downcase index)
-				    w3-style-font-size-mappings))
-		      3)))
-  (setq index (- index 3))
-  (let ((scaler (if (> index 0)
-		    1.44
-		  0.695))
-	(size 12))
-    (setq index (abs index))
-    (while (/= index 0)
-      (setq size (* size scaler)
-	    index (1- index)))
-    ;; This rounds to the nearest '10'
-    (format "%dpt" (* 10 (round (/ size 10))))))
-
-(defsubst w3-style-speech-normalize-number (num)
-  (if num (% (abs (read num)) 9)))
-
-(defun w3-generate-stylesheet-voices (sheet)
-  (let ((todo sheet)
-	cur cur-classes
-	node family gain
-	left right pitch
-	pitch-range stress
-	richness voice
-	)
-    (while todo
-      (setq cur (car todo)
-	    cur-classes (cdr cur)
-	    todo (cdr todo))
-      (while cur-classes
-	(setq node (cdr (car cur-classes))
-	      cur (car cur-classes)
-	      cur-classes (cdr cur-classes)
-	      family (cdr-safe (assq 'voice-family node))
-	      family (if family (intern (downcase family)))
-	      gain (w3-style-speech-normalize-number
-		    (cdr-safe (assq 'gain node)))
-	      left (w3-style-speech-normalize-number
-		    (cdr-safe (assq 'left-volume node)))
-	      right (w3-style-speech-normalize-number
-		     (cdr-safe (assq 'right-volume node)))
-	      pitch (w3-style-speech-normalize-number
-		     (cdr-safe (assq 'pitch node)))
-	      pitch-range (w3-style-speech-normalize-number
-			   (cdr-safe (assq 'pitch-range node)))
-	      stress (w3-style-speech-normalize-number
-		      (cdr-safe (assq 'stress node)))
-	      richness (w3-style-speech-normalize-number
-			(cdr-safe (assq 'richness node))))
-	(if (or family gain left right pitch pitch-range stress richness)
-	    (setq voice (dtk-personality-from-speech-style
-			 (make-dtk-speech-style :family (or family 'paul)
-						:gain (or gain 5)
-						:left-volume (or left 5)
-						:right-volume (or right 5)
-						:average-pitch (or pitch 5)
-						:pitch-range (or pitch-range 5)
-						:stress (or stress 5)
-						:richness (or richness 5))))
-	  (setq voice nil))
-	(if voice (setcdr cur (cons (cons 'voice-spec voice) (cdr cur))))
-	)
-      )
-    )
-  )
-
-(defun w3-style-post-process-stylesheet (sheet)
-  (w3-generate-stylesheet-faces sheet)
-  (if (featurep 'emacspeak)
-      (w3-generate-stylesheet-voices w3-user-stylesheet)))
-
-(defun w3-style-css-split-font-shorthand (font)
-  ;; [<font-weight> || <font-style>]? <font-size> [ / <line-height> ]? <font-family>
-  (let (weight size height family)
-    (if (not (string-match " *\\([0-9.]+[^ /]+\\)" font))
-	(error "Malformed font shorthand: %s" font))
-    (setq weight (if (/= 0 (match-beginning 0))
-		     (substring font 0 (match-beginning 0)))
-	  size (match-string 1 font)
-	  font (substring font (match-end 0) nil))
-    (if (string-match " */ *\\([^ ]+\\) *" font)
-	;; they specified a line-height as well
-	(setq height (match-string 1 font)
-	      family (substring font (match-end 0) nil))
-      (setq family (url-strip-leading-spaces font)))
-    (list weight size height family)))
-
-(defun w3-generate-stylesheet-faces (sheet)
-  (let ((todo sheet)
-	(cur nil)
-	(cur-classes nil)
-	(node nil)
-	(fore nil)
-	(back nil)
-	(pixmap nil)
-	(font nil)
-	(family nil)
-	(decoration nil)
-	(style nil)
-	(size nil)
-	(index nil)
-	(shorthand nil)
-	(weight nil)
-	(break-style nil))
-    (while todo
-      (setq cur (car todo)
-	    cur-classes (cdr cur)
-	    todo (cdr todo))
-      (while cur-classes
-	(setq node (cdr (car cur-classes))
-	      cur (car cur-classes)
-	      cur-classes (cdr cur-classes)
-	      fore (cdr-safe (assq 'color node))
-	      back (cdr-safe (assq 'background node))
-	      decoration (cdr-safe (assq 'text-decoration node))
-	      pixmap (cdr-safe (assq 'backdrop node))
-	      index (cdr-safe (assq 'font-size-index node))
-	      size (or (and index (w3-style-font-size-for-index index))
-		       (cdr-safe (assq 'font-size node)))
-	      family (cdr-safe (assq 'font-family node))
-	      weight (cdr-safe (assq 'font-weight node))
-	      weight (or (cdr-safe (assoc weight
-					 w3-style-font-weight-mappings))
-			 weight)
-	      style (cdr-safe (assq 'font-style node))
-	      shorthand (cdr-safe (assq 'font node)))
-
-	;; Make sure all 'break' items get intern'd
-	(if (or style decoration)
-	    (setq style (concat style decoration)))
-	(setq break-style (assq 'break node))
-	(if (and (cdr break-style) (stringp (cdr break-style)))
-	    (setcdr break-style (intern (cdr break-style))))
-	(if shorthand
-	    (progn
-	      (setq shorthand (w3-style-css-split-font-shorthand shorthand))
-	      (setq weight (or (nth 0 shorthand) weight)
-		    size (or (nth 1 shorthand) size)
-		    family (or (nth 3 shorthand) family)
-		    weight (or (cdr-safe
-				(assoc weight
-				       w3-style-font-weight-mappings))
-			       weight))))
-	(if style
-	    (setq style (mapcar
-			 (function
-			  (lambda (x)
-			    (while (string-match "-" x)
-			      (setq x (concat
-				       (substring x 0 (match-beginning 0))
-				       (substring x (match-end 0) nil))))
-			    (intern-soft
-			     (concat "font-set-" (downcase x) "-p"))))
-			 (delete "" (split-string style "[ \t&,]")))))
-	(if family (setq family (delete "" (split-string family ","))))
-	(if (or family weight style size)
-	    (progn
-	      (setq font (make-font :family family :weight weight :size size))
-	      (while style
-		(and (fboundp (car style))
-		     (funcall (car style) font t))
-		(setq style (cdr style))))
-	  (setq font nil))
-	(if font (setcdr cur (cons (cons 'font-spec font) (cdr cur))))
-	(if fore (setcdr cur (cons (cons 'foreground fore) (cdr cur))))
-	(if back (setcdr cur (cons (cons 'background back) (cdr cur))))
-	)
-      )
-    )
-  )
 
 (defun w3-handle-style (&optional args)
   (let ((fname (or (cdr-safe (assq 'href args))
@@ -566,22 +59,17 @@
       (erase-buffer)
       (setq url-be-asynchronous nil)
       (cond
-       ((member type '("experimental" "arena" "w3c-style" "css"))
-	(let ((data (w3-style-parse-css fname string cur-sheet)))
-	  (setq stylesheet (nth 0 data)
-		defines (nth 1 data))))
+       ((member type '("experimental" "arena" "w3c-style" "css" "text/css"))
+	(setq stylesheet (css-parse fname string cur-sheet)))
        (t
 	(w3-warn 'html "Unknown stylesheet notation: %s" type))))
     (setq w3-current-stylesheet stylesheet)
-    (w3-style-post-process-stylesheet w3-current-stylesheet)))
+    )
+  )
 
 (defun w3-display-stylesheet (&optional sheet)
   (interactive)
   (if (not sheet) (setq sheet w3-current-stylesheet))
-  (with-output-to-temp-buffer "W3 Stylesheet"
-    (set-buffer standard-output)
-    (emacs-lisp-mode)
-    (require 'pp)
-    (pp sheet (current-buffer))))
+  (css-display sheet))
 
 (provide 'w3-style)