# copyright (C) 1997-2006 Jean-Luc Fontaine (mailto:jfontain@free.fr)
# this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu

# $Id: htmlview.tcl,v 2.30 2006/01/28 19:16:59 jfontain Exp $


set ::htmlLibraryAdditionalCode {

    # use bold and smaller sizes than the HTML library default ones for headers
    array set HMtag_map {
        h1 {size 22 weight bold}
        h2 {size 20 weight bold}
        h3 {size 18 weight bold}
        h4 {size 16 weight bold}
        h5 {size 14 weight bold}
        h6 {weight bold}
    }

    # make headers and preformatted text stand out better by adding new lines around them, extra new lines after lists are too much:
    array set HMinsert_map {
        h1 \n\n /h1 \n\n h2 \n\n /h2 \n\n h3 \n\n /h3 \n\n h4 \n\n /h4 \n\n h5 \n\n /h5 \n\n h6 \n\n /h6 \n\n pre \n\n /ul {} /ol {}
    }

    unset HMevents(Enter)                                                 ;# prevent links highlighting, try to behave like Netscape
    unset HMevents(Leave)
    unset HMevents(1)
    set HMevents(ButtonRelease-1) {-foreground darkblue}

    proc HMset_image {widget label source} {                                                      ;# supply image handling procedure
        if {![catch {image create photo -file $source} image]} {
            bind $label <Destroy> "image delete $image"              ;# setup binding so that image is deleted as label is destroyed
            HMgot_image $label $image                                                       ;# got the image for the specified label
            # suppress relief for better visibility and use parent text widget background for transparent areas to really look it
            $label configure -borderwidth 0 -background [[winfo parent $label] cget -background]
        }
    }

}

append ::htmlLibraryAdditionalCode "
    set HMtag_map(hmstart) {family [list $global::fontFamily]}
    lappend HMtag_map(hmstart) weight medium style r size $global::fontSize Tcenter {} Tlink {} Tnowrap {} Tunderline {} list list\
        fill 1 indent {} counter 0 adjust 0
"

proc HMlink_hit {path x y} {            ;# is invoked here at the global level by the Tk bind facility instead of in the interpreter
    $::htmlViewer::interpreterFromPath($path) eval "HMlink_hit $path $x $y"
}


class htmlViewer {

    proc htmlViewer {this parentPath args} composite {[new scroll text $parentPath] $args} {
        variable interpreterFromPath

        set path $composite::($composite::($this,base),scrolled,path)
        # borders are never shown on focus, padding so that lines do not start too close to the left border
        $path configure -highlightthickness 0 -state disabled -padx 2 -background white -cursor {}          ;# hide insertion cursor
        set interpreter [interp create]                      ;# use separate interpreter because HTML library uses global state data
        $interpreter eval "set ::auto_path [list $::auto_path]"                        ;# in case packages are needed by interpreter
        $interpreter eval $::htmlLibraryCode
        $interpreter eval $::htmlLibraryAdditionalCode
        $interpreter alias $path $path                                                    ;# make text widget visible in interpreter
        $interpreter alias formulasHelpWindow formulasHelpWindow
        $interpreter alias statisticsHelpWindow statisticsHelpWindow
        foreach command {bind bindtags image pack update winfo} {                                           ;# and a few Tk commands
            $interpreter alias $command $command
        }
        foreach command {button frame label scrollbar text} {                                         ;# along with a few Tk widgets
            $interpreter alias $command ::htmlViewer::widget $command $interpreter
        }
        $interpreter eval "HMinit_win $path"
        # make HTML text widget behave more like Netscape
        $path tag configure mark -foreground black                                                    ;# override list markers color
        $path tag configure link -borderwidth 1 -foreground blue -underline 1       ;# override hypertext links border and underline
        $interpreter eval "set ::HM${path}(S_symbols) {oooooo\xd7\xb0>:\xb7}"         ;# use simple circles for list element markers
        set ($this,interpreter) $interpreter
        set ($this,textPath) $path
        set interpreterFromPath($path) $interpreter                           ;# required for link hit procedure to find interpreter

        composite::complete $this
    }

    proc ~htmlViewer {this} {
        variable interpreterFromPath

        # stop rendering in case we were interrupted by the user destroying the window for example
        $($this,interpreter) eval "HMset_state $($this,textPath) -stop 1"
        unset interpreterFromPath($($this,textPath))
        interp delete $($this,interpreter)
    }

    proc options {this} {
        # force initialization of linkto option
        return [list\
            [list -data {} {}]\
            [list -file {} {}]\
            [list -linkto $this]\
        ]
    }

    # can be set once completed so that widget can be managed (pack, bind, ...) and be visible for updates to occur
    proc set-data {this value} {
        if {[info exists ($this,loaded)]} {
            error {data can only be loaded once}
        }
        load $this $value
    }

    proc set-file {this value} {
        if {[info exists ($this,loaded)]} {
            error {data can only be loaded once}
        }
        set file [open $value]
        load $this [read $file]
        close $file
    }

    proc set-linkto {this viewer} {            ;# allow link hits to target another text widget (used in general help from contents)
        if {$viewer == $this} {
            $($this,interpreter) eval {
                proc HMlink_callback {widget reference} {                                          ;# supply link callback procedure
                    switch -glob -- [string tolower [file tail $reference]] {
                        formulas.htm - formulas-*.htm {
                            formulasHelpWindow                             ;# formulas help can be launched from general help window
                        }
                        statistics.htm - statistics-*.htm {
                            statisticsHelpWindow                          ;# predictor help can be launched from general help window
                        }
                    }
                    if {![string match #* $reference]} return                                 ;# can only handle internal references
                    HMgoto $widget [string trimleft $reference #]                             ;# always update help data text widget
                }
            }
        } else {
            $($this,interpreter) alias HMlink_callback ::htmlViewer::linkCallbackRedirect $viewer
        }
    }

    proc load {this data} {
        set ($this,loaded) {}
        set path $($this,textPath)
        busy 1 $path                                                                      ;# show that we are busy for user feedback
        $path configure -state normal
        # the interpreter may no longer exists at this point
        # ignoring errors here is required in case we are interrupted while rendering by the user closing the window for example,
        # in which case the interpreter is destroyed causing the main interpreter to report the impossibility to evaluate the code
        catch {$($this,interpreter) eval "HMparse_html {$data} {HMrender $path}"}
        if {![winfo exists $path]} return              ;# user may have destroyed the window through the window manager, for example
        $($this,interpreter) eval "HMset_state $path -stop 1"                                ;# stop rendering previous page if busy
        $path configure -state disabled
        busy 0 $path
    }

    # create a widget of the specified type and make the resulting command available in the slave interpreter
    proc widget {type interpreter args} {
        set path [eval ::$type $args]
        $interpreter alias $path $path
        return $path
    }

    proc linkCallbackRedirect {viewer widget reference} {                  ;#  link callback procedure redirecting to another viewer
        $($viewer,interpreter) eval "HMlink_callback $($viewer,textPath) $reference"
    }

    ### public procedures below ###

    proc goTo {this url} {
        catch {$($this,interpreter) eval "HMlink_callback $($this,textPath) $url"}                     ;# ignore errors as in load{}
    }

}
