747 lines
22 KiB

;;;; w w w - h t m l . s t k -- WWW for STk (html reader)
;;;; No form support (yet)
;;;; No frame support (never)
;;;; Copyright © 1995-1999 Erick Gallesio - I3S-CNRS/ESSI <>
;;;; 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 (
;;;; Author: Erick Gallesio []
;;;; 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
(if (symbol-bound? '%init-html)
;; Html module is in the core interpreter
;; 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;"))
(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 "&"))
(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)))
((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))
(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-*-*-*-*-*-*-*"
((if weight cadr car) (car info))
((if slant cadr car) (cadr info))
(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"
(if weight "b" "")
(if slant "i" "")
(if underline "u" "")
(if strike "s" "")
(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
;;;; 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 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)
(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)
;; 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
(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))
(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
(set! align (string-lower (cdr align)))
;; I have problems with align which doesn't seem to work
((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)))
(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")