751 lines
23 KiB

;;;; h t m l . s t k -- HTML support (no forms yet)
;;;; Copyright © 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <>
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works. Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied warranty.
;;;; Author: Erick Gallesio []
;;;; Creation date: 1-Sep-1995 09:52
;;;; Last file update: 15-Nov-1996 18:40
(if (symbol-bound? '%init-html)
;; Html module is in the core interpreter
;; Try to load hash table dynamically
(load (string-append "html." *shared-suffix*)))
;;;; Exported routines
(define html:view-URL #f)
(define html:view #f)
(define html:set-base-directory! #f)
;; Hooks (They do nothing. overload them if needed)
(define (html:hook-title title) #f) ;; called when title change
(define (html:hook-location title) #f) ;; called when location URL change
(define (html:hook-start-loading) #f) ;; called when a new page is loaded
(define (html:hook-stop-loading) #f) ;; called when a new page has been loaded
(define (html:hook-formatting) #f) ;; called often when formatting (pulse)
(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 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 "violet")
(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)
;;;; URL management
(define parse-URL
;; Syntax is scheme://host[:port]/path/filename[#anchor]
;; We can probably make better....
(let ((rgxp1 (string->regexp "^(.[a-zA-Z]*):.*"))
(rgxp2 (string->regexp "[^/]*//([^/:#]*)"))
(rgxp3 (string->regexp ".*:.*//.*:([^/#]*)"))
(rgxp4-1 (string->regexp "[^/]*([^#]+)"))
(rgxp4-2 (string->regexp "//[^/]*(/[^#]*)"))
(rgxp5 (string->regexp "[^#]*#(.*)$")))
(lambda (str)
(let ((scheme "file")
(host "localhost")
(port "80")
(file str)
(anchor ""))
;; Scheme
(let ((res (rgxp1 str)))
(when res (set! scheme (apply substring str (cadr res)))))
;; Host
(let ((res (rgxp2 str)))
(when res (set! host (apply substring str (cadr res)))))
;; Port
(let ((res (rgxp3 str)))
(when res (set! port (apply substring str (cadr res)))))
;; Filename
(let ((res (rgxp4-1 str)))
(when res
(let ((res (rgxp4-2 str)))
(when res (set! file (apply substring str (cadr res)))))))
;; Anchor
(let ((res (rgxp5 str)))
(when res (set! anchor (apply substring str (cadr res)))))
(vector scheme host port file anchor)))))
(define (URL->port url)
(let ((scheme (string-lower (vector-ref url 0)))
(host (string-lower (vector-ref url 1)))
(file (vector-ref url 3)))
((and (string=? scheme "file") (string=? host "localhost"))
;; Local file
(unless base-dir
(set! base-dir (dirname file)))
(unless (eq? (string-ref file 0) #\/)
(set! file (string-append base-dir "/" file)))
(let ((fd (open-file file "r")))
(unless fd (error "Cannot open the Html file \"~S\"." file))
((string=? scheme "http")
;; HTTP file
(open-distant-file host (vector-ref url 2) file))
(ELSE (error "Cannot (yet) get file located at ~S" url)))))
(define (open-distant-file host port file)
(error "Cannot open distant files for now"))
;;;; view-URL and view
(define (view-URL txt f)
(let ((p (URL->port (parse-URL f))))
(html:hook-location f)
(view txt p)
(close-port p)))
(define (view txt fd)
(html:hook-title "No title")
(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 "")
;; Let's go
(tk-set! txt :state "normal" :wrap "word" :tabs (quotient default-indent-step 2))
(txt 'delete 1.0 "end")
(parse-port fd txt "")
(tk-set! txt :state "disabled")
;;;; Parsing
(define (parse-port fd txt delimiter)
(let loop ((token (%html:next-token fd)))
((eof-object? token) #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 (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")))
;;;; 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)
(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 (html:dl fd txt unused)
(mark-up txt)
(output-newline 1)
(set! dlist-stack (cons (cons left weight) dlist-stack))
(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)
(mark-up txt)
(output-newline 1)
(set! left (caar dlist-stack))
(set! weight #t))
(define (html:dd fd txt unused)
(mark-up txt)
(output-newline 1)
(set! left (+ (caar dlist-stack) default-indent-step))
(set! weight (cdar dlist-stack)))
;;;; Anchors
(define html:a
(let ((enter-binding (lambda (|W|) (|W| 'configure :cursor "hand2")))
(leave-binding (lambda (|W|) (|W| 'configure :cursor "top_left_arrow"))))
(lambda (fd txt args)
(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))
(make-tag (lambda (name)
(or (hash-table-get html name #f)
(let ((res (gensym "anchor-")))
(hash-table-put! html name res)
(if (or href expr)
(fluid-let ((underline #t)
(color color-link))
(parse-port fd txt "/a"))
(parse-port fd txt "/a"))
(mark-up txt)
(txt 'tag 'add tag start "end-1c")
(txt 'tag 'bind tag "<Enter>" enter-binding)
(txt 'tag 'bind tag "<Leave>" leave-binding)
(when href
(let* ((href (cdr href))
(htag (if (eq? (string-ref href 0) #\#) href #f)))
(txt 'tag 'bind tag "<ButtonRelease>"
(if htag
(lambda () (html:name txt tag (make-tag htag)))
(lambda () (html:href txt href tag))))))
(when name
(txt 'tag 'add (make-tag (string-append "#" (cdr name)))
start "end-1c"))
(when expr
(txt 'tag 'bind tag "<ButtonRelease>"
(lambda () (html:eval txt tag args))))))))
(define (html:href txt href tag)
(txt 'tag 'configure tag :foreground color-old-link)
;; View the page at given URL
(view-URL txt href))
(define (html:name txt from-tag to-tag)
(let ((start (format #f "~A.first" to-tag)))
(unless (null? (txt 'tag 'ranges to-tag))
(txt 'see (txt 'index start))
(txt 'tag 'configure from-tag :foreground color-old-link))))
(define (html:eval txt tag str)
(let ((expr (substring str 5 (string-length str))))
;; Replace &amp &gt and &lt by & > and < (to allow those chars in scripts)
(regexp-replace-all "&gt" expr ">")
(regexp-replace-all "&lt" expr "<")
(regexp-replace-all "&amp" expr "&")
(eval-string expr (global-environment)))
(txt 'tag 'configure tag :foreground color-old-link))
;;;; Images
(define (html:insert-image txt img align)
(let ((lab (gensym (format #f "~A.lab" (widget-name txt))))
(start (txt 'index "insert")))
(label lab :image img :borderwidth 0 :highlightthickness 0)
(txt 'window 'create "end" :window lab :pady 2 :padx 2 :align align)
;; Extend last tag to the image (so it can pass through)
(txt 'tag 'add last-tag start "end")
(set! NL-count 0)
(set! ignore-spaces #f)))
(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
(let* ((src-url (parse-URL (cdr src)))
(file "")
(img #f))
(mark-up txt)
;; We manage only local images for now
(set! file (vector-ref src-url 3))
;; Look alignment
(if align
(set! align (string-lower (cdr align)))
;; I have problems with align which doesn't seem to work. Only
;; baseline seem to be correct....
((string=? align "middle") (set! align "center"))
((string=? align "bottom") (set! align "baseline")))) ; WEIRD
(set! align "baseline"))
;; Try loading image as a photo and if it fails as a bitmap
(unless (eq? (string-ref file 0) #\/)
(set! file (string-append base-dir "/" file)))
(if (catch (set! img (image 'create 'photo :file file)))
(catch (set! img (image 'create 'bitmap :file file))))
(if img
(html:insert-image txt img align)
;; Image not found insert the ALT field (if present)
(fluid-let ((color "red")
(point-size 18))
(set! buffered-text (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 (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)
(html:hook-title ""))
(define (html:/title fd txt unused)
(html: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 (cdr bgcolor)))
(when fgcolor (set! 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)
;;;; Exports symbols
(set! html:view-URL view-URL)
(set! html:view view)
(set! html:set-base-directory! (lambda (dir) (set! base-dir dir)))
(provide "html")