606 lines
16 KiB
Tcl
606 lines
16 KiB
Tcl
# ----------------------------------------------------------------------------
|
||
# "THE BEER-WARE LICENSE" (Revision 42) (by Poul-Henning Kamp):
|
||
# Joerg Wunsch <j.gnu@uriah.heep.sax.de> wrote this file. As long as you
|
||
# retain this notice you can do whatever you want with this stuff. If we meet
|
||
# some day, and you think this stuff is worth it, you can buy me a beer
|
||
# in return.
|
||
# ----------------------------------------------------------------------------
|
||
#
|
||
# $Id: htmlview.tcl,v 1.7 2004/07/15 20:50:48 j Exp $
|
||
#
|
||
# This implements a simple HTML viewer that is just suitable to browse through
|
||
# a document generated by latex2html
|
||
#
|
||
|
||
proc htmlview {file} {
|
||
global htmlposx htmlposy
|
||
global tcl_platform
|
||
global helpicon
|
||
global tcl_platform
|
||
global bgcolor
|
||
|
||
if {$file == ""} {
|
||
return
|
||
}
|
||
|
||
set subtag ""
|
||
# determine requested subtag (if any)
|
||
if {[regexp "^(\[^\#\]*)\#(.*)" $file dummy match subtag]} {
|
||
set file $match
|
||
}
|
||
|
||
set f ""
|
||
catch {set f [open $file]}
|
||
if {$f == ""} {
|
||
return
|
||
}
|
||
|
||
set dirname [file dirname $file]
|
||
|
||
set ok 0
|
||
while {!$ok} {
|
||
set w ".htmlview[expr {int(rand()*30000)}]"
|
||
if {![winfo exists $w]} {
|
||
set ok 1
|
||
}
|
||
}
|
||
toplevel $w
|
||
if {[info exists htmlposx]} {
|
||
set htmlposx [expr $htmlposx + 10]
|
||
set htmlposy [expr $htmlposy + 10]
|
||
} else {
|
||
set htmlposx [expr [winfo x .] + 80]
|
||
set htmlposy [expr [winfo y .] + 50]
|
||
}
|
||
wm geometry $w "+$htmlposx+$htmlposy"
|
||
wm positionfrom $w user
|
||
|
||
frame $w.f0
|
||
text $w.f0.t1 -wrap word -yscrollcommand "$w.f0.sb1 set" \
|
||
-font {Helvetica -12} -cursor {top_left_arrow}
|
||
scrollbar $w.f0.sb1 -command "$w.f0.t1 yview"
|
||
frame $w.f1
|
||
button $w.f1.bok -text {Close} -command "destroy $w"
|
||
#button $w.f1.closeall -text {Hilfe beenden} -command {destroyhtmlwins}
|
||
pack $w.f0.t1 -side left -expand 1 -fill both
|
||
pack $w.f0.sb1 -side right -expand 0 -fill y
|
||
pack $w.f0 -side top -expand 1 -fill both
|
||
pack $w.f1.bok -side left
|
||
#pack $w.f1.closeall -side right
|
||
pack $w.f1 -side top
|
||
|
||
update
|
||
set x [winfo width $w]
|
||
set y [winfo height $w]
|
||
wm minsize $w $x $y
|
||
|
||
bind $w <Key-Prior> "$w.f0.t1 yview scroll -10 units"
|
||
bind $w <Key-Next> "$w.f0.t1 yview scroll 10 units"
|
||
bind $w <Key-space> "$w.f0.t1 yview scroll 10 units"
|
||
focus $w
|
||
|
||
set bgcolor [$w.f0.t1 cget -background]
|
||
|
||
if {$tcl_platform(platform) == "unix" && [file exists $helpicon]} {
|
||
wm iconbitmap $w @$helpicon
|
||
}
|
||
|
||
set buf ""; set head ""; set tail ""
|
||
set title ""
|
||
set list ""; set lcount {1}; set ullevel 0
|
||
set bold 0; set italic 0; set titlemode 0
|
||
set tagno 0; set attribs {}; set attrib ""; set justify "left"
|
||
set paraopen 0
|
||
set lmargin 0; set rmargin 0
|
||
set hrno 0; set bulletno 0; set imgno 0
|
||
set newlineput 0; set anchorhasmodifiedfont 0; set inheadline 0
|
||
|
||
while {1} {
|
||
# if $buf starts with a "<", it means we've got an unfinished yet
|
||
# tag in there, so we need to read more until the tag is finished
|
||
# and can be handled in full
|
||
if {$buf == "" || [string index $buf 0] == "<"} {
|
||
if {[gets $f lbuf] == -1} {
|
||
break
|
||
}
|
||
if {$lbuf == "" && !$inheadline} {
|
||
# single newline only, marks a paragraph break
|
||
set lbuf "<p>"
|
||
}
|
||
regsub -all {[\t ]+} $lbuf { } lbuf
|
||
if {[string index $lbuf end] != " "} {
|
||
set lbuf "$lbuf "
|
||
}
|
||
set buf "$buf$lbuf"
|
||
}
|
||
if {[set idx [string first "<" $buf]] != -1} {
|
||
set head [string range $buf 0 [expr $idx - 1]]
|
||
set tail [string range $buf $idx end]
|
||
} else {
|
||
set head $buf
|
||
set tail ""
|
||
}
|
||
if {[string length $head]} {
|
||
set head [untangletext $head]
|
||
if {$titlemode} {
|
||
set title "$title$head"
|
||
} else {
|
||
if {$attrib != ""} {
|
||
$w.f0.t1 insert end $head $attrib
|
||
} else {
|
||
$w.f0.t1 insert end $head
|
||
}
|
||
}
|
||
set head ""
|
||
}
|
||
if {[string length $tail]} {
|
||
if {[set idx [string first ">" $tail]] != -1} {
|
||
set tag [string range $tail 0 $idx]
|
||
set buf [string range $tail [expr $idx + 1] end]
|
||
set tag [string range $tag 1 end-1]
|
||
set tagname $tag
|
||
set remainder ""
|
||
regexp {^(/?[A-Za-z0-9]+) *(.*)} $tag dummy tagname remainder
|
||
set tagname [string tolower $tagname]
|
||
switch $tagname {
|
||
"br" {
|
||
$w.f0.t1 insert end "\n"
|
||
}
|
||
"p" {
|
||
if {$paraopen && $attrib != ""} {
|
||
set attrib [lindex $attribs end]
|
||
set attribs [lrange $attribs 0 end-1]
|
||
$w.f0.t1 tag add $attrib end
|
||
}
|
||
set align ""
|
||
while {1} {
|
||
set x [parsetag $remainder]
|
||
set name [string tolower [lindex $x 0]]
|
||
set val [lindex $x 1]
|
||
set remainder [lindex $x 2]
|
||
|
||
if {$name == ""} {
|
||
break
|
||
}
|
||
if {$name == "align"} {
|
||
set align [string tolower $val]
|
||
}
|
||
}
|
||
if {$align != ""} {
|
||
set justify "left"
|
||
switch $align {
|
||
"center" { set justify "center" }
|
||
"right" { set justify "right" }
|
||
}
|
||
incr tagno
|
||
lappend attribs $attrib
|
||
set attrib "attrib$tagno"
|
||
$w.f0.t1 tag add $attrib end
|
||
$w.f0.t1 tag configure $attrib -font {Helvetica -12 bold}
|
||
$w.f0.t1 tag configure $attrib -lmargin1 $lmargin -lmargin2 $lmargin \
|
||
-rmargin $rmargin -justify $justify
|
||
}
|
||
$w.f0.t1 insert end "\n"
|
||
set paraopen 1
|
||
}
|
||
"/p" {
|
||
set paraopen 0
|
||
if {$attrib != ""} {
|
||
set attrib [lindex $attribs end]
|
||
set attribs [lrange $attribs 0 end-1]
|
||
$w.f0.t1 tag add $attrib end
|
||
}
|
||
}
|
||
"title" {
|
||
set titlemode 1
|
||
set title ""
|
||
}
|
||
"/title" {
|
||
set titlemode 0
|
||
wm title $w $title
|
||
}
|
||
"b" {
|
||
incr tagno
|
||
lappend attribs $attrib
|
||
set attrib "attrib$tagno"
|
||
$w.f0.t1 tag add $attrib end
|
||
$w.f0.t1 tag configure $attrib -font {Helvetica -12 bold}
|
||
$w.f0.t1 tag configure $attrib -lmargin1 $lmargin -lmargin2 $lmargin \
|
||
-rmargin $rmargin -justify $justify
|
||
}
|
||
"/b" {
|
||
set attrib [lindex $attribs end]
|
||
set attribs [lrange $attribs 0 end-1]
|
||
$w.f0.t1 tag add $attrib end
|
||
}
|
||
"strong" {
|
||
incr tagno
|
||
lappend attribs $attrib
|
||
set attrib "attrib$tagno"
|
||
$w.f0.t1 tag add $attrib end
|
||
$w.f0.t1 tag configure $attrib -font {Helvetica -12 bold}
|
||
$w.f0.t1 tag configure $attrib -lmargin1 $lmargin -lmargin2 $lmargin \
|
||
-rmargin $rmargin -justify $justify
|
||
}
|
||
"/strong" {
|
||
set attrib [lindex $attribs end]
|
||
set attribs [lrange $attribs 0 end-1]
|
||
$w.f0.t1 tag add $attrib end
|
||
}
|
||
"i" {
|
||
incr tagno
|
||
lappend attribs $attrib
|
||
set attrib "attrib$tagno"
|
||
$w.f0.t1 tag add $attrib end
|
||
$w.f0.t1 tag configure $attrib -font {Helvetica -12 italic}
|
||
$w.f0.t1 tag configure $attrib -lmargin1 $lmargin -lmargin2 $lmargin \
|
||
-rmargin $rmargin -justify $justify
|
||
}
|
||
"/i" {
|
||
set attrib [lindex $attribs end]
|
||
set attribs [lrange $attribs 0 end-1]
|
||
$w.f0.t1 tag add $attrib end
|
||
}
|
||
"em" {
|
||
incr tagno
|
||
lappend attribs $attrib
|
||
set attrib "attrib$tagno"
|
||
$w.f0.t1 tag add $attrib end
|
||
$w.f0.t1 tag configure $attrib -font {Helvetica -12 italic}
|
||
$w.f0.t1 tag configure $attrib -lmargin1 $lmargin -lmargin2 $lmargin \
|
||
-rmargin $rmargin -justify $justify
|
||
}
|
||
"/em" {
|
||
set attrib [lindex $attribs end]
|
||
set attribs [lrange $attribs 0 end-1]
|
||
$w.f0.t1 tag add $attrib end
|
||
}
|
||
"tt" {
|
||
incr tagno
|
||
lappend attribs $attrib
|
||
set attrib "attrib$tagno"
|
||
$w.f0.t1 tag add $attrib end
|
||
$w.f0.t1 tag configure $attrib -font {Courier -12}
|
||
$w.f0.t1 tag configure $attrib -lmargin1 $lmargin -lmargin2 $lmargin \
|
||
-rmargin $rmargin -justify $justify
|
||
}
|
||
"/tt" {
|
||
set attrib [lindex $attribs end]
|
||
set attribs [lrange $attribs 0 end-1]
|
||
$w.f0.t1 tag add $attrib end
|
||
}
|
||
"h1" {
|
||
incr inheadline
|
||
incr tagno
|
||
lappend attribs $attrib
|
||
set attrib "attrib$tagno"
|
||
$w.f0.t1 tag add $attrib end
|
||
$w.f0.t1 tag configure $attrib -font {Times -18 bold}
|
||
$w.f0.t1 tag configure $attrib -lmargin1 $lmargin -lmargin2 $lmargin \
|
||
-rmargin $rmargin -justify $justify
|
||
}
|
||
"/h1" {
|
||
set inheadline [expr $inheadline - 1]
|
||
set attrib [lindex $attribs end]
|
||
set attribs [lrange $attribs 0 end-1]
|
||
$w.f0.t1 tag add $attrib end
|
||
$w.f0.t1 insert end "\n\n"
|
||
}
|
||
"h2" {
|
||
incr inheadline
|
||
incr tagno
|
||
lappend attribs $attrib
|
||
set attrib "attrib$tagno"
|
||
$w.f0.t1 tag add $attrib end
|
||
$w.f0.t1 tag configure $attrib -font {Times -16 bold}
|
||
$w.f0.t1 tag configure $attrib -lmargin1 $lmargin -lmargin2 $lmargin \
|
||
-rmargin $rmargin -justify $justify
|
||
}
|
||
"/h2" {
|
||
set inheadline [expr $inheadline - 1]
|
||
set attrib [lindex $attribs end]
|
||
set attribs [lrange $attribs 0 end-1]
|
||
$w.f0.t1 tag add $attrib end
|
||
$w.f0.t1 insert end "\n\n"
|
||
}
|
||
"h3" {
|
||
incr inheadline
|
||
incr tagno
|
||
lappend attribs $attrib
|
||
set attrib "attrib$tagno"
|
||
$w.f0.t1 tag add $attrib end
|
||
$w.f0.t1 tag configure $attrib -font {Times -14 bold}
|
||
$w.f0.t1 tag configure $attrib -lmargin1 $lmargin -lmargin2 $lmargin \
|
||
-rmargin $rmargin -justify $justify
|
||
}
|
||
"/h3" {
|
||
set inheadline [expr $inheadline - 1]
|
||
set attrib [lindex $attribs end]
|
||
set attribs [lrange $attribs 0 end-1]
|
||
$w.f0.t1 tag add $attrib end
|
||
$w.f0.t1 insert end "\n\n"
|
||
}
|
||
"h4" {
|
||
incr inheadline
|
||
incr tagno
|
||
lappend attribs $attrib
|
||
set attrib "attrib$tagno"
|
||
$w.f0.t1 tag add $attrib end
|
||
$w.f0.t1 tag configure $attrib -font {Times -12 bold}
|
||
$w.f0.t1 tag configure $attrib -lmargin1 $lmargin -lmargin2 $lmargin \
|
||
-rmargin $rmargin -justify $justify
|
||
}
|
||
"/h4" {
|
||
set inheadline [expr $inheadline - 1]
|
||
set attrib [lindex $attribs end]
|
||
set attribs [lrange $attribs 0 end-1]
|
||
$w.f0.t1 tag add $attrib end
|
||
$w.f0.t1 insert end "\n\n"
|
||
}
|
||
"a" {
|
||
set target ""
|
||
while {1} {
|
||
set x [parsetag $remainder]
|
||
set name [string tolower [lindex $x 0]]
|
||
set val [lindex $x 1]
|
||
set remainder [lindex $x 2]
|
||
|
||
if {$name == ""} {
|
||
break
|
||
}
|
||
if {$name == "href"} {
|
||
set target $val
|
||
}
|
||
if {$name == "name" && $subtag == $val} {
|
||
# subtag was requested, notice it
|
||
set see [$w.f0.t1 index end]
|
||
}
|
||
}
|
||
if {$target != "" && ![regexp {^(http:|ftp:)} $target]} {
|
||
switch $tcl_platform(platform) {
|
||
"windows" {
|
||
if {![regexp {^([A-Za-z]:)?[\\/]} $target]} {
|
||
# relative pathname
|
||
set target "$dirname/$target"
|
||
}
|
||
}
|
||
"unix" {
|
||
if {![regexp {^/} $val]} {
|
||
# relative unix pathname
|
||
set target "$dirname/$target"
|
||
}
|
||
}
|
||
}
|
||
set anchorhasmodifiedfont 1
|
||
incr tagno
|
||
lappend attribs $attrib
|
||
set attrib "attrib$tagno"
|
||
$w.f0.t1 tag add $attrib end
|
||
$w.f0.t1 tag configure $attrib -foreground {blue}
|
||
$w.f0.t1 tag configure $attrib -font {Helvetica -12 bold}
|
||
$w.f0.t1 tag configure $attrib -lmargin1 $lmargin -lmargin2 $lmargin \
|
||
-rmargin $rmargin -justify $justify
|
||
$w.f0.t1 tag bind $attrib <ButtonPress> "htmlview $target"
|
||
}
|
||
}
|
||
"/a" {
|
||
if {$anchorhasmodifiedfont} {
|
||
set anchorhasmodifiedfont 0
|
||
set attrib [lindex $attribs end]
|
||
set attribs [lrange $attribs 0 end-1]
|
||
$w.f0.t1 tag add $attrib end
|
||
}
|
||
}
|
||
"ul" {
|
||
set list "ul"
|
||
incr ullevel
|
||
incr tagno
|
||
lappend attribs $attrib
|
||
set attrib "attrib$tagno"
|
||
set lmargin [expr 40 * $ullevel - 10]
|
||
set rmargin [expr 40 * $ullevel]
|
||
$w.f0.t1 tag add $attrib end
|
||
$w.f0.t1 tag configure $attrib -font {Helvetica -12}
|
||
$w.f0.t1 tag configure $attrib -lmargin1 $lmargin -lmargin2 $lmargin \
|
||
-rmargin $rmargin -justify $justify
|
||
}
|
||
"/ul" {
|
||
set ullevel [expr $ullevel - 1]
|
||
if {$ullevel == 0} {
|
||
set list ""
|
||
set lmargin 0
|
||
set rmargin 0
|
||
} else {
|
||
set lmargin [expr 40 * $ullevel - 10]
|
||
set rmargin [expr 40 * $ullevel]
|
||
}
|
||
set attrib [lindex $attribs end]
|
||
set attribs [lrange $attribs 0 end-1]
|
||
$w.f0.t1 tag add $attrib end
|
||
$w.f0.t1 tag configure $attrib -font {Helvetica -12}
|
||
$w.f0.t1 tag configure $attrib -lmargin1 $lmargin -lmargin2 $lmargin \
|
||
-rmargin $rmargin -justify $justify
|
||
$w.f0.t1 insert end "\n"
|
||
}
|
||
"li" {
|
||
switch $list {
|
||
"ul" {
|
||
incr bulletno
|
||
canvas $w.bullet$bulletno \
|
||
-width [expr 40 * $ullevel - 15] -height 6 \
|
||
-background $bgcolor -highlightthickness 0 \
|
||
-border 0
|
||
if {$ullevel == 1} {
|
||
$w.bullet$bulletno create oval 11 1 14 4
|
||
} else {
|
||
$w.bullet$bulletno create rectangle \
|
||
[expr 40 * $ullevel - 29] 1 [expr 40 * $ullevel - 26] 4
|
||
}
|
||
$w.f0.t1 insert end "\n" $attrib
|
||
$w.f0.t1 window create end -align baseline \
|
||
-window $w.bullet$bulletno
|
||
}
|
||
}
|
||
}
|
||
"address" {
|
||
set attrib ""
|
||
set attribs {}
|
||
$w.f0.t1 insert end "\n"
|
||
}
|
||
"hr" {
|
||
update
|
||
incr hrno
|
||
makehr $w.hr$hrno [expr [winfo width $w.f0.t1] - 10]
|
||
$w.f0.t1 insert end "\n" $attrib
|
||
$w.f0.t1 window create end -window $w.hr$hrno
|
||
}
|
||
"img" {
|
||
set iwidth 0
|
||
set iheight 0
|
||
set ialign "bottom"
|
||
set isrc ""
|
||
while {1} {
|
||
set x [parsetag $remainder]
|
||
set name [string tolower [lindex $x 0]]
|
||
set val [lindex $x 1]
|
||
set remainder [lindex $x 2]
|
||
|
||
if {$name == ""} {
|
||
break
|
||
}
|
||
switch $name {
|
||
"width" { set iwidth $val }
|
||
"height" { set iheight $val }
|
||
"src" {
|
||
switch $tcl_platform(platform) {
|
||
"windows" {
|
||
if {[regexp {^([A-Za-z]:)?[\\/]} $val]} {
|
||
# absolute pathname
|
||
set isrc $val
|
||
} else {
|
||
set isrc "$dirname/$val"
|
||
}
|
||
}
|
||
"unix" {
|
||
if {[regexp {^/} $val]} {
|
||
# absolute unix pathname
|
||
set isrc $val
|
||
} else {
|
||
set isrc "$dirname/$val"
|
||
}
|
||
}
|
||
}
|
||
}
|
||
"align" { set ialign [string tolower $val] }
|
||
}
|
||
}
|
||
if {$isrc != "" && [file exists $isrc]} {
|
||
incr imgno
|
||
image create photo htmlview$imgno \
|
||
-width $iwidth -height $iheight \
|
||
-file $isrc
|
||
set imgidx [$w.f0.t1 image create end -image htmlview$imgno]
|
||
$w.f0.t1 tag add $attrib $imgidx
|
||
$w.f0.t1 tag add $attrib end
|
||
}
|
||
}
|
||
}
|
||
} else {
|
||
# unfinished tag, return to $buf
|
||
set buf $tail
|
||
}
|
||
} else {
|
||
set buf ""
|
||
}
|
||
}
|
||
close $f
|
||
# prevent users from editing the text widget's contents
|
||
$w.f0.t1 configure -state disabled
|
||
if {[info exists see]} {
|
||
# we have a subtag to display
|
||
$w.f0.t1 see $see
|
||
}
|
||
}
|
||
|
||
# parse $str, obtain first name=value pair, return remainder as well
|
||
proc parsetag {str} {
|
||
# first check for quoted value
|
||
if {[regexp {^([A-Za-z0-9_]+) *= *"([^\"]+)" *(.*)} $str dummy name val rem]} {
|
||
return [list $name $val $rem]
|
||
}
|
||
# else check for argument that must not contain a space
|
||
if {[regexp {^([A-Za-z0-9_]+) *= *([^ ]+) *(.*)} $str dummy name val rem]} {
|
||
return [list $name $val $rem]
|
||
}
|
||
# else we fail
|
||
return [list "" "" ""]
|
||
}
|
||
|
||
# proc destroyhtmlwins {} {
|
||
# global htmlposx htmlposy
|
||
|
||
# foreach win [winfo children .] {
|
||
# if {[string match {.htmlview[0-9]*} $win]} {
|
||
# destroy $win
|
||
# }
|
||
# }
|
||
|
||
# foreach img [image names] {
|
||
# if {[string match {htmlview[0-9]+} $img]} {
|
||
# image delete $img
|
||
# }
|
||
# }
|
||
|
||
# set htmlposx [expr [winfo x .] + 80]
|
||
# set htmlposy [expr [winfo y .] + 50]
|
||
# }
|
||
|
||
proc makehr {c w} {
|
||
global bgcolor
|
||
|
||
canvas $c -width $w -height 6 -background $bgcolor \
|
||
-highlightthickness 0
|
||
$c create line 2 2 [expr $w - 2] 2 -width 1 -fill "\#202020"
|
||
$c create line 2 2 2 4 -width 1 -fill "\#202020"
|
||
$c create line 3 4 [expr $w - 1] 4 -width 1 -fill "\#ffffff"
|
||
$c create line [expr $w - 2] 4 [expr $w - 2] 2 -width 1 -fill "\#ffffff"
|
||
}
|
||
|
||
proc untangletext {t} {
|
||
|
||
set result ""
|
||
set ok 1
|
||
|
||
while {$ok} {
|
||
if {[regexp {^([^&]*)&([^;]+);(.*)} $t dummy left marked right]} {
|
||
set result "$result$left"
|
||
set t $right
|
||
switch -glob $marked {
|
||
"Auml" { set result "${result}<EFBFBD>" }
|
||
"Ouml" { set result "${result}<EFBFBD>" }
|
||
"Uuml" { set result "${result}<EFBFBD>" }
|
||
"auml" { set result "${result}<EFBFBD>" }
|
||
"ouml" { set result "${result}<EFBFBD>" }
|
||
"uuml" { set result "${result}<EFBFBD>" }
|
||
"szlig" { set result "${result}<EFBFBD>" }
|
||
"nbsp" { set result "${result} " }
|
||
"amp" { set result "${result}&" }
|
||
"lt" { set result "${result}<" }
|
||
"gt" { set result "${result}>" }
|
||
"\#[0-9]*" {
|
||
regexp {^.(.*)} $marked dummy c
|
||
set c [subst "\\[format {%o} $c]"]
|
||
set result ${result}$c
|
||
}
|
||
"*" {
|
||
# puts stderr "Warning: unknown html mark $marked"
|
||
}
|
||
}
|
||
} else {
|
||
set result "$result$t"
|
||
set ok 0
|
||
}
|
||
}
|
||
|
||
return $result
|
||
}
|