stk/Lib/www-html.stk

;;;;
;;;; w w w - h t m l . s t k 		--  WWW for STk (html reader)
;;;;					    No form support  (yet)
;;;;					    No frame support (never)
;;;;
;;;; Copyright <20> 1995-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions.  No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
;;;;
;;;; This version uses some of the enhancements done by Harvey J. Stein:
;;;;         Copyright (c) 1995 Harvey J. Stein (hjstein@math.huji.ac.il)
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date:  1-Sep-1995 09:52
;;;; Last file update: 16-Sep-1999 17:17 (eg)
;;;;

(require "regexp")
(require "security")

(select-module  WWW)

(export WWW:applet->html 		; for Scheme applet writers
	WWW:html->applet)

(if (symbol-bound? '%init-html)
    ;; Html module is in the core interpreter
    (%init-html)
    ;; Try to load html module dynamically
    (load (string-append "html." *shared-suffix*)))


(define (WWW:applet->html f)
  (let ((code (format #f "~S" (procedure-body f))))
    (set! code (regexp-replace-all "&" code "&amp;"))
    (set! code (regexp-replace-all ">" code "&gt;"))
    (set! code (regexp-replace-all "<" code "&lt;"))
    code))

(define (WWW:html->applet code)
  (set! code (regexp-replace-all "&gt;?"  code ">"))
  (set! code (regexp-replace-all "&lt;?"  code "<"))
  (set! code (regexp-replace-all "&amp;?" code "&"))
  code)

(let ()
  (define default-indent-step   30)		; default indentation step 
  (define default-border	8)
  (define default-font		"times")	; Font to use for display
  (define default-size		14)		; Default point size
  (define default-background	"gray")

  (define point-size 		14)		; Point size
  (define weight 		#f)
  (define slant  		#f)
  (define underline 		#f)
  (define verbatim		#f)
  (define strike		#f)
  (define current-font		"times")
  (define fixed-font		"courier")	; Fixed-width font
  (define header-font		"times")	; Font for headers
  (define left	 		default-border)	; left margin indent
  (define right 		default-border)	; right margin indent
  (define justify 		'left)
  (define text-color		"black")	; Color for displaying text
  (define color 		"black")	; Current color for text
  (define color-link 		"blue")		; Color for display hyperlinks
  (define color-old-link	"blue4")
  (define base-dir		#f)
  (define list-stack 		'())
  (define ignore-spaces 	#t)		; control multiple spaces
  (define NL-count 		2)		; control multiple \n
  (define buffered-text 	"")
  (define list-level		-1)
  (define list-stack 		'())
  (define list-color		"IndianRed1")
  (define font-info		'(("helvetica"  (medium bold)   (r o))
				  ("times"      (medium bold)   (r i))
				  ("symbol"	(medium medium) (r r))
				  ("courier"    (medium bold)   (r o))
				  ("lucida"     (medium bold)   (r i))))
  (define header-info		'(("h1"	24 bold) ("h2" 20 bold) ("h3" 18 bold)
				  ("h4"	16 bold) ("h5" 16 italic) ("h6" 0 italic)))

  (define html 			#f)
  (define base-url            	())
  (define last-end-tag 		#f)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; view
;;;;
;;;;  This procedure is called to read HTML from a port, parsing it and
;;;;  inserting it into a text widget as it is read in, tagging it and
;;;;  inserting graphics, etc, as appropriate.  Basically, it just
;;;;  sets up afew environment variables for itself & calls
;;;;  parse-port, which does the real work.  
;;;;  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (view txt fd url)
  (www:hook-title "No title")
  (set! base-url	url)
  (set! html 		(make-hash-table string=?))
  (set! current-font 	default-font)	; Initialize font
  (set! point-size 	default-size)	; Point size
  (set! verbatim 	#f)
  (set! weight 		#f)			
  (set! slant  		#f)
  (set! underline 	#f)			
  (set! strike 		#f)
  (set! left 		default-border)	; left margin indent
  (set! right 		default-border)	; right margin indent
  (set! list-level 	-1)
  (set! list-stack 	'())
  (set! justify 	'left)
  (set! color 		text-color)	; Current color for text
  (set! list-stack 	'())
  (set! ignore-spaces 	#t)		; Don't output multiple blanks in a row
  (set! NL-count 	2)		; Don't output more than two \n in a row.
  (set! buffered-text 	"")

  ;; reset background color if txt widget
  (tk-set! txt :background default-background)
  ;;
  ;; Let's go
  ;;
  (parse-port fd txt ""))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Parsing
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (parse-port fd txt delimiter)
  (let loop ((token (%html:next-token fd)))
    (www:hook-formatting)
    (cond
      ((eof-object? token) #f)
      (www:stop-loading    #f)
      ((string? token)	   ;; This is simple text
       			   (insert-simple-text txt token)
			   (loop (%html:next-token fd)))
      (ELSE		   ;; This is an HTML request
			   (let ((command (car token))
				 (args    (cdr token)))
			     (unless (string=? command delimiter)
				(html:handle-request fd txt command args)
				(loop (%html:next-token fd)))))))
  (mark-up txt))

(define (insert-simple-text txt token)
  (if verbatim 
      (set! buffered-text (string-append buffered-text token))
      (let* ((t           (%html:clean-spaces token ignore-spaces))
	     (next        (car t))
	     (only-spaces (cdr t)))
	(unless (string=? next "")
	   (let ((c (string-ref next (- (string-length next) 1))))
	     (set! ignore-spaces (char-whitespace? c))
	     (unless only-spaces (set! NL-count 0))
	     (set! buffered-text (string-append buffered-text next)))))))

(define (html:handle-request fd txt token args)
  (let ((proc (string->symbol (string-append "html:" token))))
    (if (symbol-bound? proc (the-environment) )
	((eval proc (the-environment)) fd txt args)
	;; Signal an error only if 1rst char is not a / 
	;; (to allow non paired <x> </x>)
;;	(unless (eq? (string-ref token 0) #\/)
;;	   (format (current-error-port) 
;;		   "html: `~a'request not implemented\n" token)))))
)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; 
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (create-color color)
  (if (string? color)
      (let ((val (string->number color 16)))
	(if val (string-append "#" color) color))
      color))

(define (try-eval str)
  ;; Eval str in the secure-environment
  (let* ((p     (open-input-string str))
	 (sexpr (read p)))
    (eval sexpr (secure-environment))))


(define (html:make-font-name name weight slant point-size)
  (let ((info (cdr (assoc name font-info))))
    (format #f "-*-~a-~a-~a-normal-*-~a-*-*-*-*-*-*-*"
	    name
	    ((if weight cadr car) (car  info))
	    ((if slant  cadr car) (cadr info))
	    point-size)))

(define last-tag "")

(define (mark-up txt)
  (unless (string=? buffered-text "")
    (let ((tag (format #f "Tag-~A-~A-~A-~A-~A-~A-~A-~A-~A-~A-~A" 
		       current-font
		       (if weight    "b" "")
		       (if slant     "i" "")
		       (if underline "u" "")
		       (if strike    "s" "")
		       point-size
		       left 
		       left
		       right
		       color
		       justify)))
      (set! last-tag tag)
      ;; configure it
      (let ((font (html:make-font-name current-font weight slant point-size)))
	(unless (hash-table-get html tag #f)
	   ;; New tag; configure it
	   (hash-table-put! html tag font)
	   (txt 'tag 'configure tag
		:font	     font
		:foreground  color
		:underline   underline
		:overstrike  strike
		:justify     justify
		:lmargin1    (if (> left 0) left "")
		:lmargin2    (if (> left 0) left "")
		:rmargin     (if (> right 0) right ""))))
      ;; apply formatting
      (txt 'insert "end" buffered-text tag)
      (set! buffered-text ""))))

(define (output-newline count)
  ;; Output newlines. Try and limit how many consequtive newlines get output.
  (when (< NL-count count)
     (if (> (+ count NL-count) 2)
	 (set! count (- 2 NL-count)))
     (set! buffered-text (string-append buffered-text 
					(make-string count #\newline)))
     (set! NL-count count)
     (set! ignore-spaces #t)))

;;; Split-fields is used to decompose a complex HTML command such as
;;;         ALIGN=top SRC="image_URL" alt=""
;; In this case, it returns
;;	    (("align" . "top") ("src" . "image_URL") (alt . ""))
(define html:split-fields 
  (let ((rgxp  (string->regexp  " *([^=> ]+) *= *\"?([^ >\"]+)\"?"))) ; Yeah!!
    
    (lambda (str)
      (let loop ((str str) (res '()))
	(let ((one (rgxp str)))
	  (if one
	      (let ((len   (string-length str))
		    (key   (apply substring str (cadr one)))
		    (value (apply substring str (caddr one))))
		
		(set! res (cons (cons (string-lower key) value) res))
		(if (< (cadar one) (- len 1))
		    ;; see if other matches
		    (loop (substring str (+ (cadar one) 1) len) res)
		    ;; We have finished 
		    res))
	      res))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Mark-up procedures
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; <P>
(define (html:p fd txt unused)
  (output-newline 2))


;;;; <BR>
(define (html:br fd txt unused)
  (output-newline 1))


;;;; <TT>
(define (html:teletype fd txt delimiter)
  (mark-up txt)
  ;; decrement size since fixed font are generally larger than proportionnal ones
  ;; Be careful to not decrement if already in fixed font (i.e. </tt> forgotten)
  (fluid-let ((point-size   (if (equal? current-font fixed-font) 
				point-size 
				(- point-size 2)))
	      (current-font fixed-font))
    (parse-port fd txt delimiter)))

(define (html:tt     fd txt unused)  (html:teletype fd txt "/tt"))
(define (html:code   fd txt unused)  (html:teletype fd txt "/code"))
(define (html:kbd    fd txt unused)  (html:teletype fd txt "/kbd"))
(define (html:samp   fd txt unused)  (html:teletype fd txt "/samp"))


;;;; <B>
(define (html:bold fd txt unused)
  (mark-up txt)
  (set! weight #t))

(define (html:/bold fd txt unused)
  (mark-up txt)
  (set! weight #f))

(define html:b	     html:bold)
(define html:strong  html:bold)
(define html:/b	     html:/bold)
(define html:/strong html:/bold)


;;;; <I>
(define (html:italic fd txt unused)
  (mark-up txt)
  (set! slant #t))

(define (html:/italic fd txt unused)
  (mark-up txt)
  (set! slant #f))

(define html:i     html:italic)
(define html:em    html:italic)
(define html:var   html:italic)
(define html:cite  html:italic)
(define html:dfn   html:italic)
(define html:/i    html:/italic)
(define html:/em   html:/italic)
(define html:/var  html:/italic)
(define html:/cite html:/italic)
(define html:/dfn  html:/italic)


;;;; <U>
(define (html:u  fd txt unused)
  (mark-up txt)
  (set! underline #t))

(define (html:/u fd txt unused)
  (mark-up txt)
  (set! underline #f))


;;;; <STRIKE>
(define (html:strike fd txt unused)
  (mark-up txt)
  (set! strike #t))

(define (html:/strike fd txt unused)
  (mark-up txt)
  (set! strike #f))

;;;; <CENTER>
(define (html:center fd txt unused)
  (mark-up txt)
  (fluid-let ((justify 'center))
    (parse-port fd txt "/center"))
  (mark-up txt))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Headers
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (header fd txt token pre-skip)
  (let* ((info  (cdr (assoc token header-info)))
	 (point (if (> (car info) 0)  (car info) point-size))
	 (mode  (cadr info))
	 (end	(string-append "/" token)))
    
    (output-newline pre-skip)
    (mark-up txt)

    (fluid-let ((point-size   point)
		(current-font header-font)
		(left         default-border)
		(weight	      (eq? mode 'bold))
		(slant 	      (eq? mode 'italic))
		(underline    (eq? mode 'underline)))
      (parse-port fd txt end)
      (output-newline 2))))

(define (html:h1 fd txt unused) (header fd txt "h1" 2))
(define (html:h2 fd txt unused) (header fd txt "h2" 2))
(define (html:h3 fd txt unused) (header fd txt "h3" 2))
(define (html:h4 fd txt unused) (header fd txt "h4" 2))
(define (html:h5 fd txt unused) (header fd txt "h5" 2))
(define (html:h6 fd txt unused) (header fd txt "h6" 1))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Lists
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (start-list fd txt delimiter value)
  (mark-up txt)
  (output-newline 1)

  (fluid-let ((left 	  (+ left default-indent-step))
	      (list-level (+ list-level 1))
	      (list-stack (cons value list-stack)))
    (parse-port fd txt delimiter))
  
  (output-newline 1))
  
(define (html:ul   fd txt unused) (start-list fd txt "/ul" #f))
(define (html:ol   fd txt unused) (start-list fd txt "/ol" 1))
(define (html:dir  fd txt unused) (start-list fd txt "/dir" #f))
(define (html:menu fd txt unused) (start-list fd txt "/menu" #f))


(define (html:li fd txt unused)
  (when (>= list-level 0)
     (output-newline 1)
     (mark-up txt)

     (let* ((half-dist (quotient default-indent-step 2))
	    (value     (car list-stack))
	    (mark      (if (number? value)
			   (format #f "~A." value)
			   (if (even? list-level) "*" "-"))))
       
       ;; Push new value in the stack if it is a numbered list
       (if value  (set-car! list-stack (+ value 1)))
       (set! buffered-text (string-append buffered-text mark "\t"))

       (fluid-let ((left   (- left half-dist))
		   (weight #t)
		   (color  list-color))
	 (mark-up txt)
	 (set! ignore-spaces #t)))))

;;
;; Definition Lists
;; 

(define dlist-stack '()) ; stores (left . weight) for each <dl>

(define (start-dl)
  (output-newline 1)
  (set! dlist-stack (cons (cons left weight) dlist-stack)))

(define (html:dl fd txt unused)
  (mark-up txt)
  (start-dl)

  (parse-port fd txt "/dl")
    
  (set! left        (caar dlist-stack))
  (set! weight      (cdar dlist-stack))
  (set! dlist-stack (cdr dlist-stack))
  (mark-up txt)
  (output-newline 1))

(define (html:dt fd txt unused)
  (if (null? dlist-stack) (start-dl))
  (mark-up txt)
  (output-newline 1)
  (set! left (caar dlist-stack))
  (set! weight #t))

(define (html:dd fd txt unused)
  (if (null? dlist-stack) (start-dl))
  (mark-up txt)
  (output-newline 1)
  (set! left   (+ (caar dlist-stack) default-indent-step))
  (set! weight (cdar dlist-stack)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Anchors
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (html:a fd txt args)
  ;; Local defines
  (define (enter-binding)    (txt 'configure :cursor "hand2"))
  (define (leave-binding)    (txt 'configure :cursor "top_left_arrow"))
  (define (make-tag name)    (or (hash-table-get html name #f)
				 (let ((res (gensym "anchor-")))
				   (hash-table-put! html name res)
				   res)))
  ;; html:a starts here
  (mark-up txt)
  (let* ((start    (txt 'index "end-1c"))
	 (fields   (html:split-fields args))
	 (tag      (gensym "tag-"))
	 (href     (assoc "href" fields))
	 (name     (assoc "name" fields))
	 (expr     (assoc "expr" fields)))
    
    (if (or href expr)
	(fluid-let ((underline #t)
		    (color     color-link))
	  (parse-port fd txt "/a"))
	(parse-port fd txt "/a"))

    (txt 'tag 'add  tag start "end-1c")
    (txt 'tag 'bind tag "<Enter>" enter-binding)
    (txt 'tag 'bind tag "<Leave>" leave-binding)

    (when href
      (let ((url (url:parse-url (cdr href) base-url)))
	(txt 'tag 'bind tag "<ButtonRelease>"
	     (lambda ()
	       (html:href txt url (cdr href) tag)))))

    (when name
      ;; We must set a tag whose name is "tag#xxxx" (where xxxx
      ;; is the given name)
      (txt 'tag 'add (string-append "tag#" (cdr name)) start))

    (when expr
      ;; embed a frame in the text
      (txt 'tag 'bind tag "<ButtonRelease>"
	   (lambda () (html:eval txt tag args))))))

	  
(define (html:href txt url href tag)
  (txt 'tag 'configure tag :foreground color-old-link)
  (if (and (eq? (url:service url) 'mailto)  www:hook-mailto)
      ;; This is a "mailto:" and we know how tohandle it
      (www:hook-mailto (url:filename url))
      ;; Othewise this is a document that we need to view
      (begin
	(unless (char=? (string-ref href 0) #\#)
	  ;; It's a hack: when the href is "#xxxx", the reference is in the current 
	  ;; page (and we don't need to load it). We can't use the encoded url here
	  ;; since the pathname is set to / by the url package.
	  (www:view-URL txt url))

	(let ((anchor (url:anchor url)))
	  (when anchor
	    (let ((index (txt 'index (string-append "tag#" anchor ".first"))))
	      (txt 'see index)))))))

;;;;
;;;; HTML:EVAL  a BIG BIG BIG security hole 
;;;;
(define (html:eval txt tag str)
  (let ((r  ((string->regexp "[Ee][Xx][Pp][Rr][ \t]*=(.*)") str)))
    (when r
      (catch (try-eval (apply substring str (cadr r)))
	     (txt 'tag 'configure tag :foreground color-old-link)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Applets
;;;;
;;;;	This is a quick hack (I should probably have a look at a document 
;;;;    about applet coding)
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (create-applet txt code)
  (let* ((f   (frame (gensym (format #f "~S.applet" (widget-name txt))) :bd 0))
	 (c   (WWW:html->applet code)))
    (if (catch ((try-eval c) f base-url))
	(format (current-error-port) 
		"**** WARNING: bad applet script: ~S\n" code))
    f))

(define (html:script fd txt args)
  (let* ((fields (html:split-fields args))
	 (lang   (assoc "language" fields))
	 (tmp    (text (& txt (gensym ".t")))))   ; temporary widget to collect 
    						  ; body of script
    (mark-up txt)
    (when (and lang (equal? (cdr lang) "STk"))
      ; We have a STk script to collect
      (parse-port fd tmp "/script"))

    ;; The body of the script is contained in the temp. text widget
    (let ((code (tmp 'get "0.0" 'end)))
      (destroy tmp)
      (insert-simple-text txt " ")
      (mark-up txt)
      (txt 'window 'create "end-1c" :window (create-applet txt code))
      (insert-simple-text txt " "))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Images
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (html:img fd txt args)
  (let* ((fields  (html:split-fields args))
	 (align   (assoc "align" fields))
	 (alt     (assoc "alt"   fields))
	 (src	  (assoc "src"   fields)))
    (when src
      (mark-up txt)
      (let ((img (www:insert-url txt (cdr src) base-url)))
	(unless img
	  ;; Image not found with the given url. Perhaps it's a predefined image
	  (set! img (www:insert-url txt (cdr src))))
	(if img
	    ;;;; Image inserted
	    (fluid-let ((verbatim #t))
	      (let ((index (txt 'index "end-2c"))) ;; Accessing the image 
						   ;; directly seems buggy
		(insert-simple-text txt " ")	   ;; To honour justification
		(mark-up txt)	       		   
		(if align
		    (begin
		      (set! align (string-lower (cdr align)))
		      ;; I have problems with align which doesn't seem to work
		      (cond 
		       ((string=? align "top")    'nothing)
		       ((string=? align "middle") (set! align "center"))
		       (ELSE			  (set! align "baseline"))))
		    (set! align "baseline"))
		(txt 'image 'configure index :align align)
	      
		;; Extend last tag to the image (so it can pass through)
		(txt 'tag 'add last-tag index "end"))
	      (mark-up txt))
            ;;;; Image not found
	    (fluid-let ((color      "red")
			(point-size 18))
	      (insert-simple-text txt
				  (string-append " " (if alt (cdr alt)"Image") " "))
	      (mark-up txt)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Fonts
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (html:font fd txt args)

  (define (compute-size old new)
    (let ((v (read-from-string new)))
      (if (number? v)
	  (max 4 (min 48 (+ old v)))
	  old)))

  (let* ((fields (html:split-fields args))
	 (col    (assoc "color" fields))
	 (sz     (assoc "size"  fields)))
    (mark-up txt)
    (fluid-let ((color       (if col (create-color (cdr col)) color))
		(point-size  (compute-size point-size (if sz (cdr sz) "0"))))
      (parse-port fd txt "/font"))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Misc
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; Address

(define (html:address fd txt unused)
  (mark-up txt)
  (output-newline 1)
  (fluid-let ((justify 'right)
	      (slant   #t))
    (parse-port fd txt "/address")))

;;;; Blockquote: extended quotations

(define (html:blockquote fd txt unused)
  (mark-up txt)
  (output-newline 2)
  (fluid-let ((left  (+ left default-indent-step))
	      (right (+ right default-indent-step))
	      (slant #t))
    (parse-port fd txt "/blockquote"))
  (output-newline 2))

;;;; Horizontal Rules

(define (html:hr fd txt token)
  (output-newline 2)
  (mark-up txt)
  (fluid-let ((justify 'left)
	      (underline #f)
	      (left default-border)
	      (right default-border))
    (set! buffered-text " \n\n")
    (mark-up txt)
    (let ((line (car (txt 'index "end"))))
      (txt 'tag 'add "separator" (cons (- line 3) 0) (cons (- line 2) 0))
      (txt 'tag 'configure "separator" :relief "ridge" :borderwidth 1
	   :font "-*-times-*-*-*-*-4-*-*-*-*-*-*-*" :justify "left")))
    (output-newline 1))

;;;; Preformatted Text

(define (html:pre fd txt unused)
  (mark-up txt)
  (output-newline 1)
  (fluid-let ((verbatim #t))
    (html:teletype fd txt "/pre")
    (output-newline 2)))

(define (html:title fd txt unused)
  (www:hook-title ""))

(define (html:/title fd txt unused)
  (www:hook-title buffered-text)
  (set! buffered-text ""))

;;;; <BODY> + some common extensions
(define (html:body fd txt args)
  (let* ((fields  (html:split-fields args))
	 (bgcolor (assoc "bgcolor" fields))
	 (fgcolor (assoc "text"    fields)))

    (when bgcolor (txt 'configure :background (create-color (cdr bgcolor))))
    (when fgcolor (set! color (create-color (cdr fgcolor))))))
  

;;;; Commands which do nothing in STk
(define (html:html fd txt unused)  'OK)
(define (html:head fd txt unused)  'OK)
(define (html:!--  fd txt unused)  'OK)

;;;; Add the html viewer
(www:add-viewer (string->regexp "\\.html?$")  view)
(www:add-viewer 'html	     		      view)

;;;; Set maximum security level
(set-security-level! 0)
)

(provide "www-html")