'''A [Snit] based wrapper for the [tkhtml] library'''
''[DDG] 13 Nov 2003''
This is slightly longer as a oneliner but it is inspired by code on [Simple Tkhtml web page displayer] (thx). A [Snit] wrapper widget created as a one afternoon hack. It's named snitBrowser because the TclPlugin contains already a package named browser! May be it is long but as a result the widget is fully reuseable. So easy is [Snit's Not Incr Tcl] ....:
#!/usr/bin/tclsh
##############################################################################
#
# Copyright 2003 MPIMG Berlin, Germany.
# All Rights Reserved
# Created By : Dr. Detlef Groth nocatdgroth@molgen.mpg.de, nocatdetlef@dgroth.de
# delete nocat to answer
# Created : Mon Mar 10 16:41:10 2003
# Last Modified : <031114.0949>
#
# Description A simple htmlwidget providing the methods
# load: popups a dialog for local file selection
# browse: loads either a local file or a webpage
# back, forward, home, Refresh: just like a normal browser behaves
# popup : installs a popup with access to back, forward, home, refresh
# SYNOPSIS
# pack [snitbrowser .browser] -side left -fill both -expand yes
# # WEB
# .browser browse "http://mini.net/tcl/2993"
# # LOCALFILES
# .browser load
# # installing the popup
# .browser popup .popup
# Notes
#
# History: V0.1 13/11/03: First Release a three hours hack
# V0.2 14/11/03: Code Refactoring:
# - Following William H. Duquette suggestions naming public methods
# lowercase
# - implementing public variables as options, like -showimages
# - resorting loading of packages
# - renaming LoadFile to the more appropiate `browse������´ method
# - removing lonly global var popupvar
# Bugs: - I would like to change some coderefs from self to mymethod as
# suggested by William but this fails (try inside method home)
# $Log: 10368,v $
# Revision 1.18 2005-06-22 06:00:25 jcw
# 10368-1119377833-129.22.152.117
#
# Revision 1.16 2005/01/23 07:00:45 jcw
# 10368-1106460530-lwv,134.243.6.109
#
#
##############################################################################
# License:
# Copyright (c) Dr. Detlef Groth, 2003 MPIMG Berlin, Germany.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose,
# provided that existing copyright notices are retained in all copies and
# that this notice is included verbatim in any distributions. No written
# agreement, license, or royalty fee is required for any of the
# authorized uses. Modifications to this software may be copyrighted by
# their authors and need not follow the licensing terms described here,
# provided that the new terms are clearly indicated on the first page of
# each file where they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
# GOVERNMENT USE: If you are acquiring this software on behalf of the
# U.S. government, the Government shall have only "Restricted Rights"
# in the software and related documentation as defined in the Federal
# Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
# are acquiring the software on behalf of the Department of Defense, the
# software shall be classified as "Commercial Computer Software" and the
# Government shall have only "Restricted Rights" as defined in Clause
# 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
# authors grant the U.S. Government and others acting in its behalf
# permission to use and distribute the software in accordance with the
# terms specified in this license.
################################################################################
package provide snitbrowser 0.2
package require Tk
package require http
lappend auto_path [file dirname [info script]]
package require snit 0.9
package require Tkhtml
snit::widget snitbrowser {
# methods starting with underlines/Uppercases are private
# and should not be used externally
variable htmlwidget
variable lastDir
variable Images
variable OldImages
variable hotkey
variable LastFile
variable PrevFiles
variable NextFiles
variable Priv
variable Popupvar
variable popup
option -showimages 1
option -padx 5
option -pady 5
option -underlinehyperlinks 0
option -bg beige
option -tablerelief raised
delegate option * to htmlwidget
delegate method * to htmlwidget
constructor {args} {
set lastDir [pwd]
set LastFile {}
set PrevFiles {}
set NextFiles {}
pack [frame $win.f] -side top -fill both -expand yes
html $win.f.html \
-yscrollcommand "$win.f.vsb set" \
-xscrollcommand "$win.hsb set" \
-imagecommand [mymethod _ImageCmd] \
-formcommand [mymethod _FormCmd] \
-unvisitedcolor blue \
-bg $options(-bg) \
-underlinehyperlinks $options(-underlinehyperlinks) \
-pady $options(-pady) -padx $options(-padx) \
-tablerelief $options(-tablerelief)
pack $win.f.html -side left -fill both -expand 1
scrollbar $win.f.vsb -orient vertical -command "$win.f.html yview"
pack $win.f.vsb -side right -fill y
bind $win.f.html.x <1> [mymethod _HrefBinding %x %y]
bind $win.f.html.x [mymethod _SelectionBinding %W %x %y]
scrollbar $win.hsb -orient horizontal -command "$win.f.html xview"
pack $win.hsb -side bottom -fill x
set htmlwidget $win.f.html
image create photo smgray -data {
R0lGODdhOAAYAPAAALi4uAAAACwAAAAAOAAYAAACI4SPqcvtD6OctNqLs968+w+G4kiW5omm
6sq27gvH8kzX9m0VADv/
}
bind HtmlClip {
set parent [winfo parent %W]
set url [$parent href %x %y]
if {[string length $url] > 0} {
$parent configure -cursor hand2
} else {
$parent configure -cursor {}
}
}
$self configurelist $args
}
method home {} {
$self browse [lindex $PrevFiles 0]
}
method back {} {
$self browse [lindex $PrevFiles end]
}
method forward {} {
$self browse [lindex $NextFiles end]
}
method _Popup {} {
if {[winfo exists $Popupvar] } {
set x [winfo pointerx .]
set y [winfo pointery .]
tk_popup $Popupvar $x $y
}
}
method popup {path} {
set Popupvar $path
menu $Popupvar -tearoff 0
$Popupvar add command -label Refresh -underline 0 -accelerator Ctrl-r -command [mymethod refresh]
$Popupvar add separator
$Popupvar add command -label Home -accelerator Alt+Home -underline 1 -command [mymethod home]
$Popupvar add command -label Back -accelerator Alt+Left -underline 1 -command [mymethod back]
$Popupvar add command -label Forward -accelerator Alt+Right -underline 1 -command [mymethod forward]
bind $htmlwidget.x [mymethod _Popup]
bind all [ mymethod back ]
bind all [ mymethod forward ]
bind all [mymethod home]
}
method _FetchImage {src w h args} {
# Fetch the image
if {[catch {
http::geturl $src -timeout 10000
} token]} {
return smgray
}
set data [http::data $token]
http::cleanup $token
# Hack needed to make sure the data is binary:
binary scan $data {}
set name [image create photo]
if {[catch {$name put $data} ret]} {
return smgray
}
return $name
}
# anyone interested in implementing the _FormCmd ?
method _FormCmd {args} {
puts $args
}
method _ImageCmd {args} {
if {!$options(-showimages)} {
return smgray
}
set fn [lindex $args 0]
if {[string match {http:*} $fn]} {
set dat [$self _FetchImage $fn 1 1]
return $dat
}
if {[info exists OldImages($fn)]} {
set Images($fn) $OldImages($fn)
unset OldImages($fn)
return $Images($fn)
}
if {[catch {image create photo -file $fn} img]} {
return $img(smgray)
}
if {[image width $img]*[image height $img]>20000} {
set b [image create photo -width [image width $img] \
-height [image height $img]]
set BigImages($b) $img
set img $b
after idle "MoveBigImage $b"
}
set Images($fn) $img
return $img
}
method refresh {args} {
if {![info exists LastFile]} return
$self browse $LastFile
}
method _SelectionBinding {w x y} {
$htmlwidget selection set @$Priv(mark) @$x,$y
clipboard clear
# avoid tkhtml0.0 errors
# anyone can fix this for tkhtml0.0
catch {
clipboard append [selection get]
}
}
method _HrefBinding {x y} {
set Priv(mark) $x,$y
set list [$htmlwidget href $x $y]
if {![llength $list]} {return}
foreach {new target} $list break
if {$new!=""} {
set pattern $LastFile#
set len [string length $pattern]
incr len -1
if {[string range $new 0 $len]==$pattern} {
incr len
$htmlwidget yview [string range $new $len end]
} else {
$self browse $new
}
}
}
method _Clear {} {
$htmlwidget clear
catch {unset hotkey}
$self _ClearBigImages
$self _ClearOldImages
foreach fn [array names Images] {
set OldImages($fn) $Images($fn)
}
catch {unset Images}
}
method _ClearOldImages {} {
foreach fn [array names OldImages] {
image delete $OldImages($fn)
}
catch {unset OldImages}
}
method _ClearBigImages {} {
foreach b [array names BigImages] {
image delete $BigImages($b)
}
catch {unset BigImages}
}
method browse {name} {
# dgroth fix
if {$name eq ""} { return }
# jcw 06/10/2000 - drop "#tag", if present
set basename [lindex [split $name #] 0]
set htmltxt [$self _ReadFile $basename]
if {$htmltxt==""} return
$self _Clear
if {$name != $LastFile && $LastFile != ""} {
if {$name == [lindex $PrevFiles end]} {
set NextFiles [linsert $NextFiles 0 $LastFile]
set PrevFiles [lreplace $PrevFiles end end]
} else {
lappend PrevFiles $LastFile
if {$name == [lindex $NextFiles 0]} {
set NextFiles [lrange $NextFiles 1 end]
} else {
set NextFiles {}
}
}
}
set LastFile $name
$htmlwidget config -base $name
# jcw 06/10/2000 - deal with text files (as suggested by Uwe Koloska)
if {![regexp -nocase {|$htmltxt\n"
}
# jcw: end of changed code
$htmlwidget parse $htmltxt
$self _ClearOldImages
# dgroth 13/11/2003 add jimping to internal name
if {[regexp {(.+)#(.+)} $LastFile match file anchor]} {
#tk_messageBox -title "Info!" -icon info -message "message jumping to $anchor" -type ok
$htmlwidget yview $anchor
}
}
method _ReadFile {name} {
# dgroth fix for files containing anchors
regexp {(.+)#} $name match name
# fix for enabling web browsing
if {[string match {http:*} $name]} {
set t [http::geturl $name];
set r [http::data $t]
http::cleanup $t;
return $r
}
if {[catch {open $name r} fp]} {
tk_messageBox -icon error -message $fp -type ok
return {}
} else {
fconfigure $fp -translation binary
set r [read $fp [file size $name]]
close $fp
return $r
}
}
method load {} {
set filetypes {
{{Html Files} {.html .htm}}
{{All Files} *}
}
set f [tk_getOpenFile -initialdir $lastDir -filetypes $filetypes]
if {$f!=""} {
$self browse $f
set lastDir [file dirname $f]
}
}
}
proc lets_test_it {} {
wm title . "Sample Snitbrowser by Dr. Detlef Groth, 2003"
menu .menubar
. config -menu .menubar
set mnu(file) [menu .menubar.file -tearoff 0]
.menubar add cascade -label File -underline 0 -menu $mnu(file)
set mnu(help) [menu .menubar.help -tearoff 0]
.menubar add cascade -label Help -underline 0 -menu $mnu(help)
$mnu(help) add command -label "About ... " -underline 0 -command \
{ tk_messageBox -title "About!" -icon info \
-message "Sample Snitbrowser by Dr. Detlef Groth\n\n 2003\n\n nocatdetlef@dgroth.de\n Delete nocat to answer!" -type ok}
$mnu(file) add command -label Exit -underline 1 -command {exit 0}
pack [snitbrowser .browser] -side left -fill both -expand yes
#.browser browse d:/docs/tcl7.6/contents.html
.browser browse "http://mini.net/tcl/snitbrowser"
# installing the popup
.browser popup .popup
}
lets_test_it
----
Where is MoveBigImage?
----
[male] - 2003-11-18:
I've tried the source with ActiveTcl v8.4.4 on MS Windows 2000. If I click on a link, wish will crash with a read failure on address xyz.
Did somebody make the same experience?
Martin
----
Once the above code is verified as working, this seems like something that
could be added to [tklib]. Of course, the extension won't do much without Tkhtml, right?
----
[DDG] I observe the same crash with ActiveTcl, however if using the correct cvs sources it works ok. So it seems to be a bug introduced by the ActiveTcl-version of tkhtml. Because this widget depends on tkhtml a c-library. It can't be included into [tklib] which hosts just tcl-only extensions.
----
'''2005-01-21''' I've used the snitbrowser as a starting point for my browser-widget. It's written in [[Incr]]Tcl and can be downloaded at [http://edugate.fss.uu.nl/~broeken/downloads/browser.itcl].
----
[[ [Category Application] | [Category Internet] | [Category Snit Widgets] | [Tkhtml] | [Snit] ]]