#!/usr/local/bin/tclsh
#
# Copyright (c): Uwe Schmidt, FH Wedel
#
# You may study, modify and distribute this source code
# FOR NON-COMMERCIAL PURPOSES ONLY.
# This copyright message has to remain unchanged.
#
# Note that this document is provided 'as is',
# WITHOUT WARRANTY of any kind either expressed or implied.
#!/bin/sh
# the next line restarts using tclsh (anywhere in search path) \
exec tclsh "$0" "$@"
#--------------------------------------------------------------------------------
# $Id: htmlparse.cgi,v 1.8 2006-12-30 15:49:55 uwe Exp $
# parseHTML macht aus einem HTML text ein Tcl-Skript
proc parseHTML text {
puts stderr "\nparseHTML: Original Text\n$text"
# Tcl Sonderzeichen {, }, [, ], und \ mit
# \ vor Interpretation schuetzen
regsub -all {[][{}\\]} $text {\\&} text
# Aufbau der Grammatik (regulaeren Ausdruecke fuer HTML tags)
set whiteSpace "\[ \n\t\r\]"
set whiteSpaces "${whiteSpace}*"
set whiteSpaces1 "${whiteSpace}+"
set name {[a-zA-Z][-_:a-zA-Z0-9]*}
set tagName "/?$name"
set attrName $name
set value1 '\[^'\]*'
set value2 \"\[^\"\]*\"
set value3 "\[^ \n\r\t>\]*"
set value "($value1|$value2|$value3)"
set attrValue "${whiteSpaces1}${attrName}=${value}"
set attrList "($attrValue)*"
set htmlTag "<($tagName)($attrList)${whiteSpaces}>"
puts stderr "\nparseHTML: der regulaere Ausdruck fuer tags\n$htmlTag"
set subst "\}\ntransHTMLtag {\\1} {\\2} \{"
puts stderr "\nparseHTML: der Ersetzungstext fuer die tags\n$subst"
regsub -all $htmlTag $text $subst text
puts stderr "\nparseHTML: der editierte text\n$text"
set text "transHTMLtag {} {} \{$text\}"
puts stderr "\nparseHTML: das Resultat\n$text"
return $text
}
#--------------------------------------------------------------------------------
# die Verteilerfunktion
proc transHTMLtag {tag attr text} {
global result
# Gross- und Kleinbuchstaben nicht signifikant
set tag [string tolower $tag]
# zusaetzlich eingefuegte \ aus text und attr loeschen
set attr [subst -novariables -nocommands $attr]
set text [subst -novariables -nocommands $text]
set prcname transTag_$tag
if {"[info procs $prcname]" == "$prcname"} {
# es gibt eine Uebersetzungsfunktion fuer den tag
append result [$prcname $attr]
} else {
# keine eigene Funktion, also nur kopieren
append result "<${tag}${attr}>"
}
# den auf den tag folgenden Text kopieren
append result $text
}
#--------------------------------------------------------------------------------
# die Hauptfunktion
proc transHTMLtext text {
global result
set result ""
eval [parseHTML $text]
return $result
}
#--------------------------------------------------------------------------------
proc transTag_body attr {
# immer schwarzer Hintergrund
return {}
}
#--------------------------------------------------------------------------------
# ein eigener tag fuer rote Schrift
proc transTag_red attr {
return {}
}
proc transTag_/red attr {
return {
}
}
#--------------------------------------------------------------------------------
# der start tag
proc transTag_ attr {
return {}
}
#--------------------------------------------------------------------------------
# ein kleiner Test
proc testTransHTML {} {
set text {
ein Test
ein Test
eine ganz wichtige Seite
[theo]
}
transHTMLtext $text
}
#--------------------------------------------------------------------------------
# eine Aufruf
puts "Content-Type: text/html
[testTransHTML]"