Version 1 of A TclOO Tkhtml 3.0 megawidget - example of how to render html+css

Updated 2017-01-23 14:24:05 by JOB

JOB - 2017-01-23 14:03:47

Here is an example code which shows, how to render a html file - styled with css. Although nothing brand new, the Tkhtml3 widget works surprisingly well with html-code + e.g. bootstrap.css framework.

I find it very convenient to have a lightweight html widget available, which might be used as a docu-reader, help-viewer, etc...

Since the interface between tkhtml-2 and tkhtml-3 changed, it took me quite a while to figure out, how to render a page with Tkhtml3.

# -----------------------------------------------------------------------------
# html3widget.tcl ---
# -----------------------------------------------------------------------------
# (c) 2016, Johann Oberdorfer - Engineering Support | CAD | Software
#     johann.oberdorfer [at] gmail.com
#     www.johann-oberdorfer.eu
# -----------------------------------------------------------------------------
# This source file is distributed under the BSD license.
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#   See the BSD License for more details.
# -----------------------------------------------------------------------------
# Purpose:
#  A TclOO class implementing the html3widget megawidget.
#  Might be usefull as a starting point.
# -----------------------------------------------------------------------------
# TclOO naming conventions:
# public methods  - starts with lower case declaration names, whereas
# private methods - starts with uppercase naming, so we are going to use CamelCase ...
# -----------------------------------------------------------------------------

# for development: try to find autoscroll, etc ...
# set this_file [file normalize [file dirname [info script]]]
# where to find required packages...
# set auto_path [linsert $auto_path 0 [file join $this_file ".."]]

package provide html3widget 0.1

package require -exact Tkhtml 3.0
package require scrolledwidget

# replace http package with native Tkhtml functionality:
catch {package require http}


namespace eval html3widget {
        variable image_dir
        variable image_file
        
        set this_dir   [file dirname [info script]]
        set image_dir  [file join $this_dir "images"]
        set image_file [file join $this_dir "ImageLib.tcl"]
        
        variable cnt 0
        
        proc LoadImages {image_dir {patterns {*.gif}}} {
                foreach p $patterns {
                        foreach file [glob -nocomplain -directory $image_dir $p] {
                                set img [file tail [file rootname $file]]
                                if { ![info exists images($img)] } {
                                        set images($img) [image create photo -file $file]
                                }
                        }}
                return [array get images]
        }
        
        proc html3widget {path args} {
                #
                # this is a tk-like wrapper around my... class so that
                # object creation works like other tk widgets
                #
                variable cnt
                
                set obj [Html3WidgetClass create tmp${cnt} $path {*}$args]
                incr cnt
                
                # rename oldName newName
                rename $obj ::$path
                return $path
        }
        
        oo::class create Html3WidgetClass {
                
                constructor {path args} {
                        
                        my variable hwidget
                        my variable widgetOptions
                        my variable widgetCompounds
                        
                        set image_file $::html3widget::image_file
                        set image_dir $::html3widget::image_dir
                        
                        # ---------------------------------------------------------------
                        # read images from library file or alternatively one by one
                        # ---------------------------------------------------------------
                        if { [file exists $image_file] } {
                                source $image_file
                                array set widgetCompounds [array get images]
                        } else {
                                array set widgetCompounds [::html3widget::LoadImages \
                                                [file join $image_dir] {"*.gif" "*.png"}]
                        }
                        # ---------------------------------------------------------------
                        
                        array set widgetCompounds {
                                dummy 0
                        }

                        # declaration of all additional widget options
                        array set widgetOptions {
                                -dummy  {}
                        }
                        
                        # incorporate arguments to local widget options
                        array set widgetOptions $args
                        
                        # we use a frame for this specific widget class
                        set f [ttk::frame $path -class html3widget]
                        
                        # we must rename the widget command
                        # since it clashes with the object being created
                        set widget ${path}_
                        my Build $f
                        rename $path $widget
                        
                        my configure {*}$args
                }
                
                destructor {
                        # adds a destructor to clean up the widget
                        set w [namespace tail [self]]
                        catch {bind $w <Destroy> {}}
                        catch {destroy $w}
                }
                
                method cget { {opt "" }  } {
                        my variable hwidget
                        my variable widgetOptions
                        
                        if { [string length $opt] == 0 } {
                                return [array get widgetOptions]
                        }
                        if { [info exists widgetOptions($opt) ] } {
                                return $widgetOptions($opt)
                        }
                        return [$hwidget cget $opt]
                }
                
                method configure { args } {
                        my variable hwidget
                        my variable widgetOptions
                        
                        if {[llength $args] == 0}  {
                                
                                # return all tablelist options
                                set opt_list [$hwidget configure]
                                
                                # as well as all custom options
                                foreach xopt [array get widgetOptions] {
                                        lappend opt_list $xopt
                                }
                                return $opt_list
                                
                        } elseif {[llength $args] == 1}  {
                                
                                # return configuration value for this option
                                set opt $args
                                if { [info exists widgetOptions($opt) ] } {
                                        return $widgetOptions($opt)
                                }
                                return [$hwidget cget $opt]
                        }
                        
                        # error checking
                        if {[expr {[llength $args]%2}] == 1}  {
                                return -code error "value for \"[lindex $args end]\" missing"
                        }
                        
                        # process the new configuration options...
                        array set opts $args
                        
                        foreach opt_name [array names opts] {
                                set opt_value $opts($opt_name)
                                
                                # overwrite with new value
                                if { [info exists widgetOptions($opt_name)] } {
                                        set widgetOptions($opt_name) $opt_value
                                }
                                
                                # some options need action from the widgets side
                                switch -- $opt_name {
                                        -dummy {}
                                        default {
                                                
                                                # -------------------------------------------------------
                                                # if the configure option wasn't one of our special one's,
                                                # pass control over to the original tablelist widget
                                                # -------------------------------------------------------
                                                
                                                if {[catch {$hwidget configure $opt_name $opt_value} result]} {
                                                        return -code error $result
                                                }
                                        }
                                }
                        }
                }
                
                method unknown {method args} {
                        #
                        # if the command wasn't one of our special one's,
                        # pass control over to the original tablelist widget
                        #
                        my variable hwidget
                        
                        if {[catch {$hwidget $method {*}$args} result]} {
                                return -code error $result
                        }
                        return $result
                }
        }
}

# --------------------------------------------------------
# Public Functions / implementation of our new subcommands
# --------------------------------------------------------
oo::define ::html3widget::Html3WidgetClass {
        
        method get_htmlwidget {} {
                my variable hwidget
                return $hwidget
        }
        
        method getfile {html_file} {
                my variable hwidget
                my variable html_basedir

        
                if { ![file exists $html_file] || ![file readable $html_file]} {
                        return
                }
                set html_basedir [file dirname $html_file]
                
                set fp [open $html_file "r"]
                set data [read $fp]
                close $fp

                $hwidget reset
                $hwidget parse -final $data
        }
        
        # --------------------
        # Private Functions...
        # --------------------
        
        method GetImageCmd {uri} {
                # see as well:
                #   http://wiki.tcl.tk/15586
                #
                my variable html_basedir
                
                # if the 'url' passed is an image name
                if { [lsearch [image names]  $uri] > -1 } {
                        return $uri
                }
                
                # if the 'url' passed is a file on disk
                set fname [file join $html_basedir $uri]
                
                if { [file exists $fname] } {
                        #create image using file
                        image create photo  $uri -file $fname
                        return $uri
                }
                
                # if the 'url' is an http url.
                if { [string equal -length 7 $uri http://] } {
                        
                        set token [::http::geturl $url]
                        set data [::http::data $token]
                        ::http::cleanup $token
                        
                        image create photo $uri -data $data
                        return $uri
                }
        }
        
        method StyleSheetHandler {node} {
                #
                # implementations of application callbacks to load
                # stylesheets from the various sources enumerated above.
                #
                my variable hwidget
                my variable html_basedir
                my variable stylecount
                
                set href [$node attr "href"]
                global "$href"
                
                # the variable contains the content of the css
                set fp [open [file join $html_basedir $href] "r"]
                set href_content [read $fp]
                close $fp
                
                if { ![info exists stylecount] } { set stylecount 0        }
                incr ::stylecount
                set id "author.[format %.4d $::stylecount]"
                
                $hwidget style -id $id.9999 $href_content
        }
        
        method ImageTagHandler {node} {
                # puts [$node attr "src"]
                my GetImageCmd [$node attr "src"]
                
        }
        
        method ScriptHandler {node} {
                my variable hwidget
                # not implemented
        }

        method ATagHandler {node} {
                my variable hwidget

                if {[$node tag] == "a"} {
                        set href [string trim [$node attr -default "" href]]
                
                        if {[string first "#" $href] == -1 &&
                                [string trim [lindex [$node attr] 0]] != "name"        } {

                                # console show
                                # puts "href: $href"
                                # puts "attr: [lindex [$node attr] 0]"

                                $node dynamic set link
                        }
                }
        }
        
        method Build {frm} {
                my variable widgetCompounds
                my variable hwidget
                
                set f [ttk::frame $frm.wmain]
                pack $f -fill both -expand true -side bottom
                
                set sc [scrolledwidget::scrolledwidget $f.sc]
                pack $sc -side top -fill both -expand 1 -padx 2 -pady 2
                
                # --------------------------
                # html 3 widget goes here...
                # --------------------------
                
                html $f.html \
                                -mode quirks \
                                -parsemode "xhtml" \
                                -zoom 1.0 \
                                -imagecmd "[namespace code {my GetImageCmd}]"

                pack $f.html -side left -fill both -expand true
                        
                set hwidget $f.html
                $sc associate $hwidget
                
                # register style sheet handler...
                $hwidget handler "node" "link" "[namespace code {my StyleSheetHandler}]"
                $hwidget handler "node" "img"  "[namespace code {my ImageTagHandler}]"
                $hwidget handler "node" "a"    "[namespace code {my ATagHandler}]"
                $hwidget handler "script" "script" "[namespace code {my ScriptHandler}]"
        }
}


# ---
# EOF
# ---
# for development: try to find autoscroll, etc ...
set dir [file normalize [file dirname [info script]]]

# where to find required packages...
set auto_path [linsert $auto_path 0 [file join $dir ".."]]
set auto_path [linsert $auto_path 0 [file join $dir "../../00-lib"]]

package require Tk
package require TclOO
package require -exact Tkhtml 3.0


# html3widget dependencies:
# replace http package with native Tkhtml functionality:
catch {package require http}
package require scrolledwidget
package require html3widget


# --------------------
# demo starts here ...
# --------------------
# catch {console show}


set w [toplevel .test]
wm withdraw .
wm title    $w "Test"
wm geometry $w "800x600"
wm minsize  $w 400 200
wm protocol $w WM_DELETE_WINDOW "exit 0"


set ft [ttk::frame $w.top]
pack $ft -padx 4 -pady 4 -side top -fill x

ttk::label $ft.lbl -text "Tkhtml-3.0 widget test!"
pack $ft.lbl -anchor center


set fb [ttk::labelframe $w.bottom -text "Browser:"]
pack $fb -padx 4 -pady 4 -side bottom -fill both -expand true


set html3 [html3widget::html3widget $fb.html3]
pack $html3 -fill both -expand true


set html_file    [file join $dir "demo_doc/index.html"]
set html_basedir [file dirname $html_file]


$html3 getfile $html_file


bind all <MouseWheel> {
        set w %W
        while { $w != [winfo toplevel $w] } {
                catch {
                        set ycomm [$w cget -yscrollcommand]
                        if { $ycomm != "" } {
                                $w yview scroll [expr int(-1*%D/36)] units
                                break
                        }
                }
                set w [winfo parent $w]
        }
}