'''[JOB] - 2017-01-23'''
[WikiDBImage html3widget.png]
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 ".."]]
# COMMANDS:
# html3widget::html3widget path args
#
package provide html3widget 0.1
package require -exact Tkhtml 3.0
package require scrolledwidget
package require findwidget
# 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]
}
# ---------------------------------------------------------------
# read images from library file or alternatively one by one
# ---------------------------------------------------------------
if { [file exists $image_file] } {
source $image_file
array set appImages [array get images]
} else {
array set appImages [::html3widget::LoadImages \
[file join $image_dir] {"*.gif" "*.png"}]
}
# ---------------------------------------------------------------
# html3widget.TCheckbutton - checkbutton style declaration
ttk::style element create html3widget.Checkbutton.indicator \
image [list \
$appImages(checkbox-off) \
{disabled selected} $appImages(checkbox-off) \
{selected} $appImages(checkbox-on) \
{disabled} $appImages(checkbox-off) \
]
ttk::style layout html3widget.TCheckbutton [list \
Checkbutton.padding -sticky nswe -children [list \
html3widget.Checkbutton.indicator \
-side left -sticky {} \
Checkbutton.focus -side left -sticky w -children { \
Checkbutton.label -sticky nswe \
} \
] \
]
ttk::style map html3widget.TCheckbutton \
-background [list active \
[ttk::style lookup html3widget.TCheckbutton -background]]
proc html3widget {path args} {
#
# this is a tk-like wrapper around my... class so that
# object creation works like other tk widgets
#
variable cnt; incr cnt
set obj [Html3WidgetClass create tmp${cnt} $path {*}$args]
# rename oldName newName
rename $obj ::$path
return $path
}
oo::class create Html3WidgetClass {
constructor {path args} {
my variable hwidget
my variable widgetOptions
my variable widgetCompounds
my variable isvisible
set isvisible 0
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 {}}
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 parsefile {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
}
method showhideSearchWidget {} {
my variable widgetCompounds
my variable isvisible
set frm $widgetCompounds(searchframe)
# the -before argument is *very* important
# to keep track of the required pack order
if { $isvisible == 0 } {
set isvisible 1
pack $frm -before $widgetCompounds(scrolledw) -side top -fill x
} else {
set isvisible 0
pack forget $frm
}
}
method showSearchWidget {} {
my variable widgetCompounds
my variable isvisible
set frm $widgetCompounds(searchframe)
if { $isvisible == 1 } { return }
set isvisible 1
pack $widgetCompounds(searchframe) \
-before $widgetCompounds(scrolledw) \
-side top -fill x
}
method hideSearchWidget {} {
my variable widgetCompounds
my variable isvisible
if { $isvisible == 0 } { return }
set isvisible 0
pack forget $widgetCompounds(searchframe)
}
# --------------------
# 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 -side bottom -fill both -expand true
set fsearch [ttk::frame $f.search -height 15]
### 'll be packed later on via binding
set widgetCompounds(searchframe) $fsearch
set sc [scrolledwidget::scrolledwidget $f.sc]
pack $sc -side bottom -fill both -expand 1 -padx 2 -pady 2
# required to take care about the pack order
set widgetCompounds(scrolledw) $f.sc
# --------------------------
# 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}]"
# create the findwidget
set wfind [::findwidget::findwidget $fsearch.find]
pack $wfind -side left -fill x -expand true
# tell the search widget where to communicate to
# and which command to execute too, when the search functionality is done
$wfind register_htmlwidget $hwidget
$wfind register_closecommand "[namespace code {my hideSearchWidget}]"
# beautify at last...
set wlabel [$wfind getlabelwidget]
$wlabel configure -text "" \
-image $::html3widget::appImages(system-search)
set wbutton [$wfind getbuttonwidget]
$wbutton configure -text "" \
-image $::html3widget::appImages(dialog-close)
bind all \
"[namespace code {my showhideSearchWidget}]"
# perhaps, makes the behavor of bindings more "reactive" ?
tk_focusFollowsMouse
}
}
# ---
# EOF
# ---
======
Demo Code:
======
# 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 ".."]]
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 findwidget
package require html3widget
# to do: font re-sizing
# search functionality
#
set fnames [font names]
set fsize 10
set ffamily "Courier"
font create APP_FONT_STD_NORMAL -family $ffamily -size $fsize -weight normal
font create APP_FONT_STD_BOLD -family $ffamily -size $fsize -weight bold
font create APP_FONT_SMALL_NORMAL -family $ffamily -size [expr {$fsize - 2}] -weight normal
font create APP_FONT_BIG_BOLD -family $ffamily -size [expr {$fsize + 0}] -weight bold
font create APP_FONT_STD_NORMAL_FIXED -family "Courier" -size $fsize -weight normal
font create APP_FONT_STD_BOLD_FIXED -family "Courier" -size $fsize -weight bold
font create APP_FONT_BIG_BOLD_FIXED -family "Courier" -size [expr {$fsize + 0}] -weight bold
# --------------------
# 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 -side bottom -fill both -expand true
# -----------------------------------------------
set html_file [file join $dir "demo_doc/tkhtml_doc.html"]
set html_basedir [file dirname $html_file]
$html3 parsefile $html_file
# $html3 showSearchWidget
bind all {
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]
}
}
======
<> Category GUI | Category Object Orientation | Category Widget | Category HTML