747 lines
22 KiB
Plaintext
747 lines
22 KiB
Plaintext
;;;;
|
|
;;;; 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 <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 "&"))
|
|
(set! code (regexp-replace-all ">" code ">"))
|
|
(set! code (regexp-replace-all "<" code "<"))
|
|
code))
|
|
|
|
(define (WWW:html->applet code)
|
|
(set! code (regexp-replace-all ">?" code ">"))
|
|
(set! code (regexp-replace-all "<?" code "<"))
|
|
(set! code (regexp-replace-all "&?" 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")
|