html.scm

;;;============================================================================

;;; File: "html.scm"

;;; Copyright (c) 2011 by Marc Feeley, All Rights Reserved.

;;;============================================================================

(##namespace ("html#"))

(##include "~~lib/gambit#.scm")

(##include "html#.scm")

(declare
  (standard-bindings)
  (extended-bindings)
  (block)
  (fixnum)
  (not safe)
)

;;;============================================================================

;; Escape text for inclusion in an HTML document.

(define (html-escape str)

  ;; This table has a non-#f entry for every character that is valid
  ;; in a standard HTML document.  The entry is what should be
  ;; displayed when this character occurs.

  (define character-entity-table
    '#(#\nul
       #f; #\x01
       #f; #\x02
       #f; #\x03
       #f; #\x04
       #f; #\x05
       #f; #\x06
       #f; #\alarm
       #f; #\backspace
       #\tab
       #\newline
       #f; #\vtab
       #f; #\page
       #\return
       #f; #\x0E
       #f; #\x0F
       #f; #\x10
       #f; #\x11
       #f; #\x12
       #f; #\x13
       #f; #\x14
       #f; #\x15
       #f; #\x16
       #f; #\x17
       #f; #\x18
       #f; #\x19
       #f; #\x1A
       #f; #\x1B
       #f; #\x1C
       #f; #\x1D
       #f; #\x1E
       #f; #\x1F
       #\space
       #\!
       """
       #\#
       #\$
       #\%
       "&"
       #\'
       #\(
       #\)
       #\*
       #\+
       #\,
       #\-
       #\.
       #\/
       #\0
       #\1
       #\2
       #\3
       #\4
       #\5
       #\6
       #\7
       #\8
       #\9
       #\:
       #\;
       "<"
       #\=
       ">"
       #\?
       #\@
       #\A
       #\B
       #\C
       #\D
       #\E
       #\F
       #\G
       #\H
       #\I
       #\J
       #\K
       #\L
       #\M
       #\N
       #\O
       #\P
       #\Q
       #\R
       #\S
       #\T
       #\U
       #\V
       #\W
       #\X
       #\Y
       #\Z
       #\[
       #\\
       #\]
       #\^
       #\_
       #\`
       #\a
       #\b
       #\c
       #\d
       #\e
       #\f
       #\g
       #\h
       #\i
       #\j
       #\k
       #\l
       #\m
       #\n
       #\o
       #\p
       #\q
       #\r
       #\s
       #\t
       #\u
       #\v
       #\w
       #\x
       #\y
       #\z
       #\{
       #\|
       #\}
       #\~
       #f; #\rubout
       #f; "€"
       #f; ""
       "‚"
       "ƒ"
       "„"
       "…"
       "†"
       "‡"
       "ˆ"
       "‰"
       "Š"
       "‹"
       "Œ"
       #f; ""
       "Ž"
       #f; ""
       #f; ""
       "‘"
       "’"
       "“"
       "”"
       "•"
       "–"
       "—"
       "˜"
       "™"
       "š"
       "›"
       "œ"
       #f; ""
       "ž"
       "Ÿ"
       " "
       "¡"
       "¢"
       "£"
       "¤"
       "¥"
       "¦"
       "§"
       "¨"
       "©"
       "ª"
       "«"
       "¬"
       "­"
       "®"
       "¯"
       "°"
       "±"
       "²"
       "³"
       "´"
       "µ"
       "¶"
       "·"
       "¸"
       "¹"
       "º"
       "»"
       "¼"
       "½"
       "¾"
       "¿"
       "À"
       "Á"
       "Â"
       "Ã"
       "Ä"
       "Å"
       "Æ"
       "Ç"
       "È"
       "É"
       "Ê"
       "Ë"
       "Ì"
       "Í"
       "Î"
       "Ï"
       "Ð"
       "Ñ"
       "Ò"
       "Ó"
       "Ô"
       "Õ"
       "Ö"
       "×"
       "Ø"
       "Ù"
       "Ú"
       "Û"
       "Ü"
       "Ý"
       "Þ"
       "ß"
       "à"
       "á"
       "â"
       "ã"
       "ä"
       "å"
       "æ"
       "ç"
       "è"
       "é"
       "ê"
       "ë"
       "ì"
       "í"
       "î"
       "ï"
       "ð"
       "ñ"
       "ò"
       "ó"
       "ô"
       "õ"
       "ö"
       "÷"
       "ø"
       "ù"
       "ú"
       "û"
       "ü"
       "ý"
       "þ"
       "ÿ"
       ))

(if (not (string? str))
(object->string str)
  (call-with-output-string
   ""
   (lambda (port)
     (let ((n (string-length str)))
       (let loop ((start 0) (end 0))
         (if (= end n)
             (write-substring str start end port)
             (let* ((ch (string-ref str end))
                    (index (char->integer ch)))
               (cond ((and (< index 256)
                           (vector-ref character-entity-table index))
                      =>
                      (lambda (character-value)
                        (if (char? character-value)
                            (loop start (+ end 1))
                            (begin ;; it's a string
                              (write-substring
                               str
                               start
                               end
                               port)
                              (write-substring
                               character-value
                               0
                               (string-length character-value)
                               port)
                              (loop (+ end 1) (+ end 1))))))
                     (else
                      #;
                      (display
                       (string-append
                        "Warning: Character (integer->char "
                        (number->string index)
                        ") is not a valid HTML 4.0 character entity\n")
                       (repl-output-port))
                      (loop start (+ end 1)))))))))))
)

;;;============================================================================