751 lines
23 KiB
Plaintext
751 lines
23 KiB
Plaintext
;;;;
|
|
;;;; OBSOLETE CODE. IT WILL DISAPPEAR SOON
|
|
;;;; DONT USE IT
|
|
;;;;
|
|
;;;; h t m l . s t k -- HTML support (no forms yet)
|
|
;;;;
|
|
;;;;
|
|
;;;; Copyright © 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; 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 [eg@unice.fr]
|
|
;;;; 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
|
|
(%init-html)
|
|
;; 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)))
|
|
(cond
|
|
((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))
|
|
fd))
|
|
((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")
|
|
(html:hook-start-loading)
|
|
(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")
|
|
(html:hook-stop-loading))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; Parsing
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (parse-port fd txt delimiter)
|
|
(let loop ((token (%html:next-token fd)))
|
|
(html:hook-formatting)
|
|
(cond
|
|
((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-*-*-*-*-*-*-*"
|
|
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")))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; 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)
|
|
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 & > and < by & > and < (to allow those chars in scripts)
|
|
(regexp-replace-all ">" expr ">")
|
|
(regexp-replace-all "<" expr "<")
|
|
(regexp-replace-all "&" 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
|
|
(begin
|
|
(set! align (string-lower (cdr align)))
|
|
;; I have problems with align which doesn't seem to work. Only
|
|
;; baseline seem to be correct....
|
|
(cond
|
|
((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)))
|
|
old)))
|
|
|
|
(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")
|