There is also an executable available, which should bring you to the point to render your html file (hopefully without a problem). As far as I understand, the html widget was not intended to be a replacement for the text widget. /JOBHere 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 has changed, it took me quite a while to figure out, how to render a page with Tkhtml3.In the meantime, I carried over some of the functionality from the hv3 browser (selection manager, integrated search+find widget).The complete package can be downloaded from here: http://www.johann-oberdorfer.eu/blog/2017/03/01/17-03-01_html3widget/The HelpViewer - based on Tkhtml3.0 is build on top of the html3widget.APN - 2017-03-02 Looks very nice. Am going to take it for a spin to see if it can replace my Windows CHM file. Which Tkhtml3 distribution are you using? And do you happen to know the level of CSS support?JOB - 2017-03-02 As stated in the HV3 homepage [2]:- Tkhtml3 aims to support those aspects of HTML 4.01 and CSS 2.1 that apply to the parsing and visual rendering of documents.
- I personally use the kit-enabled wish executables from the kbskit project (kbs.tcl), downloaded as binaries from sourceforge. You can find binaries for windows and OSX here.
- The Tkhtml3.0 binary package I got from ActiveState - you need to use teacup as the standard installation of ActiveTcl includes only Tkhtml2.0 by default.
- Note: To avoid version conflicts package require -exact Tkhtml 3.0is required all the way long...
- When searching the web for some modifications and improvements regarding the Tkhtml3.0 library, I discovered some patches here: tkhtml3-master-github. Unfortunately I do not know right now, if these patches are already incorporated in the ActiveState distribution or not.
- In other words: would be interesting to know, if ActiveState binaries are from tk-html3_3.0-fossil20110109.orig or maybe the one from: tkhtml3-master-github?
- html3widget.tcl
# -----------------------------------------------------------------------------
# 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 ...
# COMMANDS:
# html3widget::html3widget path ?args?
#
# WIDGET-COMMANDS:
# <widget> parseurl 'url'
# <widget> parsefile html_file
# examples:
# set html3 [html3widget::html3widget .t]
# pack $html3
# $html3 parseurl "http://wiki.tcl.tk/48458"
# $html3 parsefile [file join $dir "demo_doc/tkhtml_doc.html"]
#
# for the moment, we keep required add-on packages
# down below *this* directory...
set dir [file normalize [file dirname [info script]]]
set auto_path [linsert $auto_path 0 [file join $dir "."]]
# in addition, these are the packages we essentially need:
package require Tk
package require -exact Tkhtml 3.0
package require scrolledwidget
package require selectionmanager
package require findwidget
# replace http package with native Tkhtml functionality:
catch {package require http}
package provide html3widget 0.2.1
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 html_basedir
my variable html_baseurl
my variable widgetOptions
my variable widgetCompounds
my variable isvisible
# this goes together with the -zoom 1.0 option of the html widget
my variable current_scaleidx
my variable fontscales
set html_basedir ""
set html_baseurl ""
set fontscales {0.6 0.8 0.9 1.0 1.2 1.4 2.0}
set current_scaleidx 3
set isvisible 0
array set widgetCompounds {
dummy 0
selection_mgr ""
}
# 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
}
# this is only required to play togehter with helpviewer
method setbasedir {basedir} {
my variable html_basedir
set html_basedir $basedir
}
method setsearchstring {search_str} {
my variable widgetCompounds
set wentry [$widgetCompounds(find_widget) getentrywidget]
$wentry delete 0 end
after idle "$wentry insert end $search_str"
}
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 parseurl {full_url} {
my variable hwidget
my variable html_baseurl
# extract base url from url
set b [::tkhtml::uri $full_url]
# puts "--> scheme: [$b scheme] authority: [$b authority] path: [$b path]"
# might be overwritten by the <base> handler - if there is a
# custom declaration in the html's header section
set html_baseurl "[$b scheme]://[$b authority]"
set url [$b resolve $full_url]
$b destroy
set t [http::geturl $url]
set data [http::data $t]
$hwidget reset
$hwidget parse -final $data
http::cleanup $t
}
# this procedure normally is triggered by
# a <control-f> binding declaration
method showhideSearchWidget {} {
my variable hwidget
my variable widgetCompounds
my variable isvisible
# retrieve the actual selection (if available)...
if {$widgetCompounds(selection_mgr) != ""} {
set current_sel [string trim \
[$widgetCompounds(selection_mgr) selected]]
} else {
set current_sel ""
}
# mimik the n++ behaviour:
# see, if there is a user selection available,
# if yes, trigger the search with this value...
set frm $widgetCompounds(searchframe)
set wentry [$widgetCompounds(find_widget) getentrywidget]
# 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
$wentry delete 0 end
after idle "$wentry insert end $current_sel"
} else {
# keep the search window on screen, just copy the selection
# into the etry widget and perform the search ...
if {$current_sel != "" } {
$wentry delete 0 end
after idle "$wentry insert end $current_sel"
return
}
$wentry delete 0 end
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 }
# clean search entry
set wentry [$widgetCompounds(find_widget) getentrywidget]
$wentry delete 0 end
set isvisible 0
pack forget $widgetCompounds(searchframe)
}
method fontScaleCmd {mode} {
my variable hwidget
my variable current_scaleidx
my variable fontscales
# set default value, if required
if { ![info exists current_scaleidx] } {
$hwidget configure -fontscale 1.0
set current_scaleidx [lsearch $fontscales 1.0]
}
# zoom up/down acc. taking limits into account
switch -- $mode {
"plus" {
set imax [expr { [llength $fontscales] -1 }]
if {$current_scaleidx == $imax} {
return
}
incr current_scaleidx
}
"minus" {
if {$current_scaleidx == 0} {
return
}
incr current_scaleidx -1
}
"getscale" {
# returns the actual scale
return [lindex $fontscales $current_scaleidx]
}
default {
# unknown option, do nothing...
return {}
}
}
set current_scale [lindex $fontscales $current_scaleidx]
# need some more information about this option (?):
# $hwidget configure \
# -forcefontmetrics true \
# -fonttable [list 13 14 15 16 18 20 22]
#
$hwidget configure -fontscale $current_scale
return $current_scale
}
method setscale {current_scale} {
my variable hwidget
my variable current_scaleidx
my variable fontscales
if {[set idx [lsearch $fontscales $current_scale]] != -1} {
set current_scaleidx $idx
$hwidget configure -fontscale $current_scale
}
}
# This procedure is called when the user clicks on a hyperlink.
#
method hrefBinding {x y} {
my variable hwidget
my variable html_basedir
if {$html_basedir == ""} { return }
set node_data [$hwidget node -index $x $y]
if { [llength $node_data] >= 2 } {
set node [lindex $node_data 0]
} else {
set node $node_data
}
# parent node is an <A> tag (maybe?)
if { [catch {set node [$node parent]} ] == 0 } {
if {[$node tag] == "a"} {
set href [string trim [$node attr -default "" href]]
if {$href ne "" && $href ne "#"} {
set fname [file join $html_basedir $href]
# follow the link, if the file exists
if {[file exists $fname] } {
my parsefile $fname
}
}
}
}
}
# Node handler script for <base> tags.
#
method Base_node_handler {node} {
my variable html_baseurl
# If a <base> tag is available in the main start page,
# the default html_baseurl is overwritten by this node handler.
# Might be the case for CMS generated pages.
#
set html_baseurl [$node attr -default "" href]
}
# Returns the full-uri formed by resolving $rel relative
# to $base.
#
method Resolve_uri {base rel} {
set b [::tkhtml::uri $base]
# puts "--> scheme: [$b scheme] authority: [$b authority] path: [$b path]"
set ret [$b resolve $rel]
$b destroy
set ret
}
# --------------------
# Private Functions...
# --------------------
# retrieve CSS "@import {...}" directives...
method GetCSSImportTags {content} {
set reflst {}
foreach item [split $content ";"] {
# item might look like something like:
# @import url("/_css/wikit.css")
#
if { [string first "@import" $item] != -1 } {
set uri [string trim [lindex [split $item "\""] 1]]
if { $uri != "" } {
lappend reflst $uri
}
}
}
return $reflst
}
method GetImageCmd {uri} {
# see as well:
# http://wiki.tcl.tk/15586
#
my variable hwidget
my variable html_basedir
my variable html_baseurl
if { $html_baseurl != ""} {
# convert from relative to absolute 'url'
set uri [my Resolve_uri $html_baseurl $uri]
# if the 'url' is an http url.
if { [string equal -length 7 $uri "http://"] } {
if { [lsearch [image names] $uri] == -1 } {
set token [::http::geturl $uri]
set data [::http::data $token]
::http::cleanup $token
catch { image create photo $uri -data $data }
}
return $uri
}
}
if {$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
if { [file exists $uri] && ![file isdirectory $uri] } {
# create image using file
image create photo $uri -file $uri
return $uri
}
# create image using file
set fname [file join $html_basedir $uri]
if { [file exists $fname] && ![file isdirectory $fname] } {
image create photo $uri -file $fname
}
return $uri
}
return ""
}
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 html_baseurl
my variable stylecount
if { [string first "href" [$node attr]] == -1 } { return }
set href [$node attr "href"]
global "$href"
if { ![info exists stylecount] } { set stylecount 0 }
incr ::stylecount
set id "author.[format %.4d $stylecount]"
if {$html_baseurl != ""} {
# convert from relative to absolute 'url'
set href [my Resolve_uri $html_baseurl $href]
# if the 'href' is an http url.
if { [string equal -length 7 $href http://] } {
set token [::http::geturl $href]
set href_content [::http::data $token]
::http::cleanup $token
# console show; puts $href
# handle CSS "@import {...}" directives:
# as a 1st approach we just read in 1st level of @import
foreach import_ref [my GetCSSImportTags $href_content] {
set importurl [my Resolve_uri $html_baseurl $import_ref]
set importid "${id}.[format %.4d [incr ${stylecount}]]"
set token [::http::geturl $importurl]
set css_content [::http::data $token]
::http::cleanup $token
$hwidget style -id $importid.9999 $css_content
}
$hwidget style -id $id.9999 $href_content
}
}
if {$html_basedir != ""} {
# use the full path name of the css reference
set fname [file join $html_basedir $href]
if { [file exists $fname] && ![file isdirectory $fname] } {
set fp [open $fname "r"]
set href_content [read $fp]
close $fp
$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
}
}
}
# Register for a callback when the end-user moves the pointer
# over the HTML widget using the standard Tk bind command.
#
method RegisterDynamicEffectBindings {x y} {
my variable hwidget
# Clear the "hover" flag on all nodes
# on which it is currently set.
#
foreach node [$hwidget search :hover] {
$node dynamic clear hover
}
[winfo parent $hwidget] configure -cursor {}
# Set the hover flag on all nodes that generate content
# at the specified coordinates, and all ancestors of said nodes.
#
foreach node [$hwidget node $x $y] {
for {} {$node != ""} {set node [$node parent]} {
# console show
#puts "--> $node : [$node attr]"
if { [string first "href" [$node attr]] != -1 } {
[winfo parent $hwidget] configure -cursor hand2
}
catch { $node dynamic set hover }
}
}
}
method Build {frm} {
my variable widgetCompounds
my variable hwidget
my variable current_scaleidx
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
my setscale 1.0
# register selection manager
# (as a TclOO object, we instantiate the obj with "new")
set widgetCompounds(selection_mgr) \
[selectionmanager new $hwidget]
# register style sheet handler...
# ** link base meta title style script body **
$hwidget handler "node" "base" "[namespace code {my Base_node_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}]"
# hlight + change cursor
# when hovering with the mouse over a hypertext link
bind $hwidget <Motion> \
"+[namespace code {my RegisterDynamicEffectBindings}] %x %y"
# ---------------------------
# 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) \
-compound left
set wbutton [$wfind getsearchnextwidget]
$wbutton configure \
-text "" \
-image $::html3widget::appImages(arrow-down) \
-compound left
set wbutton [$wfind getsearchprevwidget]
$wbutton configure \
-text "" \
-image $::html3widget::appImages(arrow-up) \
-compound left
bind all <F3> \
"[namespace code {my showhideSearchWidget}]"
bind all <Control-f> \
"[namespace code {my showhideSearchWidget}]"
set widgetCompounds(find_widget) $wfind
# ---------------------------
# eof findwidget declarations
# ---------------------------
bind all <Control-plus> "[namespace code {my fontScaleCmd}] plus"
bind all <Control-minus> "[namespace code {my fontScaleCmd}] minus"
# 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
# --------------------
# 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
# --------
# bindings
# --------
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]
}
}
# emulate scroll behavior when pressing the middle mouse button:
# cursor: sb_v_double_arrow / hand2
bind all <ButtonPress-2> {
if {[winfo class %W] != "Html"} { return }
set html_pointery [lindex [winfo pointerxy %W] 1]
[winfo toplevel %W] configure -cursor "hand2"
}
bind all <ButtonRelease-2> {
if {[winfo class %W] != "Html"} { return }
[winfo toplevel %W] configure -cursor ""
}
bind all <B2-Motion> {
if {[winfo class %W] != "Html"} { return }
# (%D)irection is not supported for the Html widget class
if { [lindex [winfo pointerxy %W] 1] > $html_pointery } {
set D 1
} else {
set D -1
}
# we must make sure that positive and negative movements are rounded
# equally to integers, avoiding the problem that
# (int)1/3 = 0, but (int)-1/3 = -1
if {$D >= 0} {
%W yview scroll [expr {-$D/3}] units
} else {
%W yview scroll [expr {(2-$D)/3}] units
}
set html_pointery [lindex [winfo pointerxy %W] 1]
}
JOB - 2017-01-26Extension to support find functionality in the html3widget:
# -----------------------------------------------------------------------------
# findwidget.tcl ---
# -----------------------------------------------------------------------------
# (c) 2017, Johann Oberdorfer - Engineering Support | CAD | Software
# johann.oberdorfer [at] gmail.com
# www.johann-oberdorfer.eu
# -----------------------------------------------------------------------------
# Credits:
# Code derived from:
# http://tkhtml.tcl.tk/hv3_widget.html
# danielk1977 (Dan)
#
# 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 findwidget megawidget.
# Might be usefull as a starting point.
# -----------------------------------------------------------------------------
# Widget Command:
# findwidget::findwidget path
#
#
# Widget Specific Options:
# configure interface not implemented
# Widget Sub-commands:
#
# getlabelwidget
# returns the label widget, might be used to
# configuration the label with custom image, etc...
#
# getbuttonwidget
# returns the button widget
#
# register_htmlwidget <html3 widget>
# call this function to establisch communication
# between findwidget and html3widget
#
# register_closecommand <command>
# specify a command to be executed, once the widget
# is set to no-show
#
#
package provide findwidget 0.1
namespace eval findwidget {
variable cnt 0
proc findwidget {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 [FindwidgetClass create tmp${cnt} $path {*}$args]
# rename oldName newName
rename $obj ::$path
return $path
}
oo::class create FindwidgetClass {
#
# This widget encapsulates the "Find in page..." functionality.
# Two tags may be added to the html widget(s):
# findwidget (all search hits)
# findwidgetcurrent (the current search hit)
#
constructor {path args} {
my variable hwidget
my variable win
my variable myNocaseVar
my variable myEntryVar
my variable myCaptionVar
my variable myCurrentHit
my variable myCurrentList
set myNocaseVar 1
set myEntryVar ""
set myCaptionVar ""
set myCurrentHit -1
set myCurrentList ""
# we use a frame for this specific widget class
set win [ttk::frame $path -class findwidget]
# we must rename the widget command
# since it clashes with the object being created
set widget ${path}_
rename $path $widget
ttk::entry $win.entry \
-width 30 \
-textvar "[namespace current]::myEntryVar"
ttk::label $win.label \
-text "Search"
ttk::checkbutton $win.check_nocase \
-text "Case Insensitive" \
-variable "[namespace current]::myNocaseVar"
# -style html3widget.TCheckbutton
ttk::label $win.num_results \
-textvar "[namespace current]::myCaptionVar"
ttk::button $win.close \
-text "Close" \
-style Toolbutton \
-command "[namespace code {my Escape}]"
trace add variable "[namespace current]::myEntryVar" write "[namespace code {my DynamicUpdate}]"
trace add variable "[namespace current]::myNocaseVar" write "[namespace code {my DynamicUpdate}]"
bind $win.entry <Return> "[namespace code {my Return}] 1"
bind $win.entry <Shift-Return> "[namespace code {my Return}] -1"
focus $win.entry
# Propagate events that occur in the entry widget to the
# ::html3widget::findwidget widget itself. This allows the calling script
# to bind events without knowing the internal mega-widget structure.
# For example, the html3widget app binds the <Escape> key to delete the
# findwidget widget.
#
bindtags $win.entry [concat [bindtags $win.entry] $win]
pack $win.entry $win.label -padx 4 -side left
pack $win.check_nocase -padx 4 -side left
pack $win.num_results -side left -fill x
pack $win.close -side right
}
destructor {
set w [namespace tail [self]]
catch {bind $w <Destroy> {}}
catch {destroy $w}
}
# no configuration, just member functions to get access tho the
# internal widget's (might be useful to configure imaces, etc.. later on)
method getlabelwidget {} {
my variable win
return $win.label
}
method getbuttonwidget {} {
my variable win
return $win.close
}
method register_htmlwidget {widget} {
my variable hwidget
set hwidget $widget
}
method register_closecommand {cmd} {
my variable win
$win.close configure -command \
"[namespace code {my Escape}]; $cmd"
}
method Escape {} {
my variable win
my variable myEntryVar
my variable myCaptionVar
# Delete any tags added to the html3widget widget.
# Do this inside a [catch] block, as it may be that
# the html3widget widget has itself already been destroyed.
#
foreach hwidget [my GetWidgetList] {
catch {
$hwidget tag delete findwidget
$hwidget tag delete findwidgetcurrent
}
}
trace remove variable "[namespace current]::myEntryVar" write "[namespace code {my UpdateDisplay}]"
trace remove variable "[namespace current]::myNocaseVar" write "[namespace code {my UpdateDisplay}]"
set myEntryVar ""
set myCaptionVar ""
}
method ComparePositionId {frame1 frame2} {
return [string compare [$frame1 positionid] [$frame2 positionid]]
}
method GetWidgetList {} {
my variable hwidget
return [list $hwidget]
}
method LazyMoveto {hwidget n1 i1 n2 i2} {
set nodebbox [$hwidget text bbox $n1 $i1 $n2 $i2]
set docbbox [$hwidget bbox]
set docheight "[lindex $docbbox 3].0"
set ntop [expr ([lindex $nodebbox 1].0 - 30.0) / $docheight]
set nbottom [expr ([lindex $nodebbox 3].0 + 30.0) / $docheight]
set sheight [expr [winfo height $hwidget].0 / $docheight]
set stop [lindex [$hwidget yview] 0]
set sbottom [expr $stop + $sheight]
if {$ntop < $stop} {
$hwidget yview moveto $ntop
} elseif {$nbottom > $sbottom} {
$hwidget yview moveto [expr $nbottom - $sheight]
}
}
# Dynamic update proc.
method UpdateDisplay {nMaxHighlight} {
my variable myNocaseVar
my variable myEntryVar
my variable myCaptionVar
my variable myCurrentList
set nMatch 0 ;# Total number of matches
set nHighlight 0 ;# Total number of highlighted matches
set matches [list]
# Get the list of html3widget widgets that (currently) make up this browser
# display. There is usually only 1, but may be more in the case of
# frameset documents.
#
set html3widgetlist [my GetWidgetList]
# Delete any instances of our two tags - "findwidget" and
# "findwidgetcurrent". Clear the caption.
#
foreach hwidget $html3widgetlist {
$hwidget tag delete findwidget
$hwidget tag delete findwidgetcurrent
}
set myCaptionVar ""
# Figure out what we're looking for. If there is nothing entered
# in the entry field, return early.
set searchtext $myEntryVar
if {$myNocaseVar} {
set searchtext [string tolower $searchtext]
}
if {[string length $searchtext] == 0} return
foreach hwidget $html3widgetlist {
set doctext [$hwidget text text]
if {$myNocaseVar} {
set doctext [string tolower $doctext]
}
set iFin 0
set lMatch [list]
while {[set iStart [string first $searchtext $doctext $iFin]] >= 0} {
set iFin [expr $iStart + [string length $searchtext]]
lappend lMatch $iStart $iFin
incr nMatch
if {$nMatch == $nMaxHighlight} { set nMatch "many" ; break }
}
set lMatch [lrange $lMatch 0 [expr ($nMaxHighlight - $nHighlight)*2 - 1]]
incr nHighlight [expr [llength $lMatch] / 2]
if {[llength $lMatch] > 0} {
lappend matches $hwidget [eval [concat $hwidget text index $lMatch]]
}
}
set myCaptionVar "(highlighted $nHighlight of $nMatch hits)"
foreach {hwidget matchlist} $matches {
foreach {n1 i1 n2 i2} $matchlist {
$hwidget tag add findwidget $n1 $i1 $n2 $i2
}
$hwidget tag configure findwidget -bg purple -fg white
my LazyMoveto $hwidget \
[lindex $matchlist 0] [lindex $matchlist 1] \
[lindex $matchlist 2] [lindex $matchlist 3]
}
set myCurrentList $matches
}
method DynamicUpdate {args} {
my variable myCurrentHit
set myCurrentHit -1
my UpdateDisplay 42
}
method Return {dir} {
my variable hwidget
my variable myCaptionVar
my variable myCurrentHit
my variable myCurrentList
set previousHit $myCurrentHit
if {$myCurrentHit < 0} {
my UpdateDisplay 100000
}
incr myCurrentHit $dir
set nTotalHit 0
foreach {hwidget matchlist} $myCurrentList {
incr nTotalHit [expr [llength $matchlist] / 4]
}
if {$myCurrentHit < 0 || $nTotalHit <= $myCurrentHit} {
# tk_messageBox \
# -parent $hwidget \
# -message "End of Search reached." \
# -type ok
if { $nTotalHit == 0 } {
set myCaptionVar "No search result."
} else {
set myCaptionVar \
"Hit $myCurrentHit / ${nTotalHit}, end of search reached."
}
incr myCurrentHit [expr -1 * $dir]
return
}
set myCaptionVar "Hit [expr $myCurrentHit + 1] / $nTotalHit"
set hwidget ""
foreach {hwidget n1 i1 n2 i2} [my GetHit $previousHit] { }
catch {$hwidget tag delete findwidgetcurrent}
set hwidget ""
foreach {hwidget n1 i1 n2 i2} [my GetHit $myCurrentHit] { }
my LazyMoveto $hwidget $n1 $i1 $n2 $i2
$hwidget tag add findwidgetcurrent $n1 $i1 $n2 $i2
$hwidget tag configure findwidgetcurrent -bg black -fg yellow
}
method GetHit {iIdx} {
my variable myCurrentList
set nSofar 0
foreach {hwidget matchlist} $myCurrentList {
set nThis [expr [llength $matchlist] / 4]
if {($nThis + $nSofar) > $iIdx} {
return [concat $hwidget [lrange $matchlist \
[expr ($iIdx-$nSofar)*4] [expr ($iIdx-$nSofar)*4+3]
]]
}
incr nSofar $nThis
}
return ""
}
}
}
Finally, here are the required images (ImageLib.tcl)# ImageLib.tcl ---
# Automatically created by: CreateImageLib.tcl
set images(system-search) [image create photo -data {
iVBORw0KGgoAAAANSUhEUgAAABYAAAAWCAYAAADEtGw7AAAABmJLR0QAAAAAAAD5Q7t/AAAACXBI
WXMAAA3XAAAN1wFCKJt4AAAACXZwQWcAAAAWAAAAFgDcxelYAAAEVElEQVQ4y7WT209UVxTGv3Xm
DsMwcxhgRIyDVkGMZYy1aRWiVaJtkJvpQ31pbN/atA99aI1RmxBNGPGlf0ANSU1No6maam1VRlCw
iSi1tNXCjBEGGS7OgbngzDlnzpy9++BgjC3oiyv5spK9d35r5dtrEeccryKEV0IFYPyfM2rvONJI
oPcA1HNAJGAcoFEOdnz/Vwd/ehkwPWuF3+93QdC/q6yq2rVxw0aIohtWqxWKLCMWn8WNG714MDJy
nTj7bN++Q3+9FNjv93sFA+9uam72rqhYhfN9w/HuwWn9XnjWsdYrJt+pKTXs2lzpDIcf4Oy5s5Jm
0H0HvjgQebHHBv2b1tbdXrGojLUcupC8GUrO7qqrShz9dNtY7fqV0Yu/Rx81H7yQKBQ9rKmxyW3Q
8ENbW5txIbARANqPtddVLK9oLi9fjtavL87t2fH6RP36pUVmo2DSdKa57JZM5TKX8mPfg+G9Hd1V
5w43OFavXl07HAzuAXBiwY6Js899Ph86f74TXVrqnN5U7bEDHAycA2CCQFmDAFbkzIszMjw8Fbgb
q6nxgYjvWNQKAlYaTUZ03XnE3qgskzWdZRVNl1WNxTXGEpzzpJbVZ6YTmdHSYuf4L7cnsjabDZxh
66JWcGAZYzrGpZRotZpG5EzWxMmgMQgZ4iyjM6j992O3NT2bsedbDAP3I9uzWQ2qmsl70RwrRqMJ
Ze78mVAkwVctdSSJSIaeVTKMRW8FZ/qDE6k0BIiJOWWZaDfNJpPJEjWjPlwczBGQ0/Leel+J4cLt
iEMwGXvFAlsildbGY3I2TAJ/LBBcnME6NR2r2FlTDFVVoanK2OLjJuDXoaF/8FFDjZvrWvnoRKwk
MpuaiymqDAACezLs4QnpNUHX1n/csK7kZn8/VEX9ftGOxcLiM6FQ6Lfq6pFNJ/Zvs3/o79429She
XFLkuGUvsFji8bQrKiXfthr5lhMHttuj0UkMDg5mhoaDsRdu3rFjbR5OloGW5pYyr3clzvcFZ3v+
nNbvjs441y53xbf6PKbGzZXO4eA9dHZ2Ih6PQ5KktMVkazh9+nTPgmAAOHr08DpGwrcrvBVv1tbW
weUUYbXZoMgypBkJPT3duN7bq2QzGWvVmjUoK1uCrq5AStHSTadOnrm6IHg+2juO7CZOn0BAOThK
VVVNyLIaUNT0pUuX++J2u+1cc+O7eUs8HpjMZgQCgZSsplpPnTxzZVHw00ui+Q+mnAAA1Rs2vCU6
HBd31m8p8HiWwGKxoKurKyWrqaedC8+BDERkJiIbEeUDcORUCMA5r3sDA0NTk9H3L1/peTw5NQlV
VVFXV5cvwHiciIxEREIOSERkAmAGYMnJBiAPQD6AglwBJwAXgML7Q38HxyKRDy5fuTYXHgtDkqLQ
s7rT7XbbAJjnN48vIJazQH/m3Xxm4VDoDzCh5WrPjQ6bxVwuCPhSkiQdgP4fj+mJscIzMjyXkSuo
P5fnxTnn+BdfFBTdhrqWWgAAACV0RVh0ZGF0ZTpjcmVhdGUAMjAxMC0wMS0xMVQwOToxMzowMy0w
NzowMFMfKlcAAAAldEVYdGRhdGU6bW9kaWZ5ADIwMTAtMDEtMTFUMDk6MTM6MDMtMDc6MDAiQpLr
AAAANHRFWHRMaWNlbnNlAGh0dHA6Ly9jcmVhdGl2ZWNvbW1vbnMub3JnL2xpY2Vuc2VzL0dQTC8y
LjAvbGoGqAAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoAAAATdEVYdFNvdXJj
ZQBHTk9NRS1Db2xvcnOqmUTiAAAAMXRFWHRTb3VyY2VfVVJMAGh0dHA6Ly9jb2RlLmdvb2dsZS5j
b20vcC9nbm9tZS1jb2xvcnMvUB216wAAAABJRU5ErkJggg==
}]
set images(dialog-close) [image create photo -data {
iVBORw0KGgoAAAANSUhEUgAAABQAAAAUCAYAAACNiR0NAAAABmJLR0QA/wD/AP+gvaeTAAAACXBI
WXMAABGwAAARsAHIJ/VUAAAAB3RJTUUH4QEaCTEiD+SBFQAAA0tJREFUOMu1lM9vVFUUx79vOvOm
M9MOLWJKpAmx7T+g3WioUMvYuBPSCIQ0uDASVyzY6J8gCxPiT4hglNB2OsO0aaJxeH3zyxh/YRWw
UrugKKhtdDozjzrvzbx73/26qNO0UIREPclZ3JNzPjnn3vO9Gkn8l+a7M+BJCSnFPxYppeC67v2B
nvIwOZXixGSKnvLuCczmTH5w7iylEPcGKqWQSMb5yI4d6OzsRDIZp9oEaphpCiHw5BO7cPrMu3TF
HZ2ShOPUcH7kQ37+xWdsWCZrMp4YJUk03MwaHE+M0BUuSXJ+fo7vnHqTjmOv5fgAwO9vgq4H0Xgg
IQUGnt6Lh7dtQyK12qlhprm4+CsOPH8YtlMFQWja6p2760dvkD1PYix+ntnsNEnSqTkkyWkzzZNv
vM6x8RGS5O0Vi1JKXv3+Ct96+yTrbh3rp9hwkJ7E2PgozYxBkrQdmySZy2dIktZKmcIT/OrSl3zv
7Cm6rruh/i5gwxMXxmiY6b8hFdq1KkvlIl23zkszX3Nk9Bwtq7JprW+ztRjaf0C79sMsCp/mEPD7
UbHKAIAbCzeQyRgYHHx2Jhrd8mCLDQCZrMGOju3Y/VQ/bMeGHtBRFwI7H92Jxx/rRaGQ6/U88WDA
bM7k0tIiDh48DGulgnCoBX/8vowtrVFYt0vo69sDv9+PickU7wucNtNcWvoNw8MvoGyV0KwHceXy
d5iaSqFQyCMSboW1UsLA3hj0oI7khTiVUncDhRBIpz9mvV7H/n1DWC4V0RwM4ZtvZ7Dw0wKOvvTy
Cdu2YUxfRKg5gkqlhD39/QhHwkhNJCjWqcUHAFTErV9uoaNjO5pDIUTCLZidvYq5a7OIDcQQbW17
NRYb1Ny6i1wui0ikBT7Nh57uHvw4P4c/q9VYA6g11FG1qzjz/mn27doNDUQ+n8ehQ8MI6sETtZrz
SjAYTJLo+uTiR71t7W3o6e5BMjGOY8eOP9Pe1m6uAZVSEEJAColKpcxkKg5N82Hfc0OIRqPdTU1N
C7quQ0oJIWSXY1evG2YaN2/+jCNHXsRDW7dquq4jEAhA07TVxW5AhRAolZaPlsvlLiEEpJQblSQl
hBCwLAvFYvE1ISRc14VSai1H+99/7H9rfwF2imSw0yqcowAAAABJRU5ErkJggg==
}]
JOB - 2017-02-11
- selectionmanager for the html3widget:
# -----------------------------------------------------------------------------
# selectionmanager
#
# This type encapsulates the code that manages selecting text
# in the html widget with the mouse.
#
# -----------------------------------------------------------------------------
package provide selectionmanager 0.1
oo::class create selectionmanager {
constructor {hwidget} {
my variable O
# Variable myMode may take one of the following values:
#
# "char" -> Currently text selecting by character.
# "word" -> Currently text selecting by word.
# "block" -> Currently text selecting by block.
#
set O(myState) false ;# True when left-button is held down
set O(myMode) char
set O(myHtml) $hwidget
set O(myFromNode) ""
set O(myFromIdx) ""
set O(myToNode) ""
set O(myToIdx) ""
set O(myIgnoreMotion) 0
# (?) selection handle $hwidget "[namespace code {my get_selection}]"
bind $hwidget <Motion> "+[namespace code {my MotionCmd}] {} %x %y"
bind $hwidget <ButtonPress-1> "+[namespace code {my PressCmd}] {} %x %y"
bind $hwidget <ButtonRelease-1> "+[namespace code {my ReleaseCmd}] %x %y"
bind $hwidget <Double-ButtonPress-1> "+[namespace code {my DoublepressCmd}] %x %y"
bind $hwidget <Triple-ButtonPress-1> "+[namespace code {my TriplepressCmd}] %x %y"
bind all <Control-c> "[namespace code {my CopySelection2Clipboard}]"
}
# Clear the selection.
#
method ClearSelection {} {
my variable O
set O(myFromNode) ""
set O(myToNode) ""
$O(myHtml) tag delete selection
$O(myHtml) tag configure selection -foreground white -background darkgrey
}
method PressCmd {N x y} {
my variable O
# Single click -> Select by character.
my ClearSelection
set O(myState) true
set O(myMode) char
my MotionCmd $N $x $y
}
# Given a node-handle/index pair identifying a character in the
# current document, return the index values for the start and end
# of the word containing the character.
#
method ToWord {node idx} {
set t [$node text]
set cidx [::tkhtml::charoffset $t $idx]
set cidx1 [string wordstart $t $cidx]
set cidx2 [string wordend $t $cidx]
set idx1 [::tkhtml::byteoffset $t $cidx1]
set idx2 [::tkhtml::byteoffset $t $cidx2]
return [list $idx1 $idx2]
}
# Add the widget tag "selection" to the word containing the character
# identified by the supplied node-handle/index pair.
#
method TagWord {node idx} {
my variable O
foreach {i1 i2} [my ToWord $node $idx] {}
$O(myHtml) tag add selection $node $i1 $node $i2
}
# Remove the widget tag "selection" to the word containing the character
# identified by the supplied node-handle/index pair.
#
method UntagWord {node idx} {
my variable O
foreach {i1 i2} [my ToWord $node $idx] {}
$O(myHtml) tag remove selection $node $i1 $node $i2
}
method ToBlock {node idx} {
my variable O
set t [$O(myHtml) text text]
set offset [$O(myHtml) text offset $node $idx]
set start [string last "\n" $t $offset]
if {$start < 0} {set start 0}
set end [string first "\n" $t $offset]
if {$end < 0} {set end [string length $t]}
set start_idx [$O(myHtml) text index $start]
set end_idx [$O(myHtml) text index $end]
return [concat $start_idx $end_idx]
}
# method TagBlock {node idx} {
# my variable O
#
# foreach {n1 i1 n2 i2} [my ToBlock $node $idx] {}
# $O(myHtml) tag add selection $n1 $i1 $n2 $i2
#}
#method UntagBlock {node idx} {
# my variable O
#
# foreach {n1 i1 n2 i2} [my ToBlock $node $idx] {}
# catch {$O(myHtml) tag remove selection $n1 $i1 $n2 $i2}
#}
method DoublepressCmd {x y} {
my variable O
# Double click -> Select by word.
my ClearSelection
set O(myMode) word
set O(myState) true
my MotionCmd "" $x $y
}
method TriplepressCmd {x y} {
my variable O
# Triple click -> Select by block.
my ClearSelection
set O(myMode) block
set O(myState) true
my MotionCmd "" $x $y
}
method ReleaseCmd {x y} {
my variable O
set O(myState) false
}
method MotionCmd {N x y} {
my variable O
if {!$O(myState) || $O(myIgnoreMotion)} return
set to [$O(myHtml) node -index $x $y]
foreach {toNode toIdx} $to {}
# $N containst the node-handle for the node that the cursor is
# currently hovering over (according to the mousemanager component).
# If $N is in a different stacking-context to the closest text,
# do not update the highlighted region in this event.
#
if {$N ne "" && [info exists toNode]} {
if {[$N stacking] ne [$toNode stacking]} {
set to ""
}
}
if {[llength $to] > 0} {
if {$O(myFromNode) eq ""} {
set O(myFromNode) $toNode
set O(myFromIdx) $toIdx
}
# This block is where the "selection" tag is added to the HTML
# widget (so that the selected text is highlighted). If some
# javascript has been messing with the tree, then either or
# both of $myFromNode and $myToNode may be orphaned or deleted.
# If so, catch the exception and clear the selection.
#
set rc [catch {
if {$O(myToNode) ne $toNode || $toIdx != $O(myToIdx)} {
switch -- $O(myMode) {
char {
if {$O(myToNode) ne ""} {
$O(myHtml) tag remove selection $O(myToNode) $O(myToIdx) $toNode $toIdx
}
$O(myHtml) tag add selection $O(myFromNode) $O(myFromIdx) $toNode $toIdx
if {$O(myFromNode) ne $toNode || $O(myFromIdx) != $toIdx} {
selection own $O(myHtml)
}
}
word {
if {$O(myToNode) ne ""} {
$O(myHtml) tag remove selection $O(myToNode) $O(myToIdx) $toNode $toIdx
my UntagWord $O(myToNode) $O(myToIdx)
}
$O(myHtml) tag add selection $O(myFromNode) $O(myFromIdx) $toNode $toIdx
# my TagWord $toNode $toIdx
my TagWord $O(myFromNode) $O(myFromIdx)
selection own $O(myHtml)
}
block {
set to_block2 [my ToBlock $toNode $toIdx]
set from_block [my ToBlock $O(myFromNode) $O(myFromIdx)]
if {$O(myToNode) ne ""} {
set to_block [my ToBlock $O(myToNode) $O(myToIdx)]
$O(myHtml) tag remove selection $O(myToNode) $O(myToIdx) $toNode $toIdx
eval $O(myHtml) tag remove selection $to_block
}
$O(myHtml) tag add selection $O(myFromNode) $O(myFromIdx) $toNode $toIdx
eval $O(myHtml) tag add selection $to_block2
eval $O(myHtml) tag add selection $from_block
selection own $O(myHtml)
}
}
set O(myToNode) $toNode
set O(myToIdx) $toIdx
}
} msg]
if {$rc && [regexp {[^ ]+ is an orphan} $msg]} {
my ClearSelection
}
}
set motioncmd ""
set win $O(myHtml)
if {$y > [winfo height $win]} {
set motioncmd [list yview scroll 1 units]
} elseif {$y < 0} {
set motioncmd [list yview scroll -1 units]
} elseif {$x > [winfo width $win]} {
set motioncmd [list xview scroll 1 units]
} elseif {$x < 0} {
set motioncmd [list xview scroll -1 units]
}
if {$motioncmd ne ""} {
set O(myIgnoreMotion) 1
eval $O(myHtml) $motioncmd
after 20 "[namespace code {my ContinueMotion}]"
}
}
method ContinueMotion {} {
my variable O
set win $O(myHtml)
set O(myIgnoreMotion) 0
set x [expr [winfo pointerx $win] - [winfo rootx $win]]
set y [expr [winfo pointery $win] - [winfo rooty $win]]
set N [lindex [$O(myHtml) node $x $y] 0]
my MotionCmd $N $x $y
}
method CopySelection2Clipboard {} {
clipboard clear
clipboard append [my selected]
}
# get_selection OFFSET MAXCHARS
#
# This command is invoked whenever the current selection is selected
# while it is owned by the html widget. The text of the selected
# region is returned.
#
method get_selection {offset maxChars} {
my variable O
set t [$O(myHtml) text text]
set n1 $O(myFromNode)
set i1 $O(myFromIdx)
set n2 $O(myToNode)
set i2 $O(myToIdx)
set stridx_a [$O(myHtml) text offset $O(myFromNode) $O(myFromIdx)]
set stridx_b [$O(myHtml) text offset $O(myToNode) $O(myToIdx)]
if {$stridx_a > $stridx_b} {
foreach {stridx_a stridx_b} [list $stridx_b $stridx_a] {}
}
if {$O(myMode) eq "word"} {
set stridx_a [string wordstart $t $stridx_a]
set stridx_b [string wordend $t $stridx_b]
}
if {$O(myMode) eq "block"} {
set stridx_a [string last "\n" $t $stridx_a]
if {$stridx_a < 0} {set stridx_a 0}
set stridx_b [string first "\n" $t $stridx_b]
if {$stridx_b < 0} {set stridx_b [string length $t]}
}
set T [string range $t $stridx_a [expr $stridx_b - 1]]
set T [string range $T $offset [expr $offset + $maxChars]]
return $T
}
method selected {} {
my variable O
if {$O(myFromNode) eq ""} {return ""}
return [my get_selection 0 10000000]
}
method destroy {} {
}
}
