#!/usr/bin/tclsh
##############################################################################
#
#
# Created By : Dr. Detlef Groth nocatdetlef@dgroth.de
# delete nocat to answer
# Created : Mon Mar 10 16:41:10 2003
# Last Modified : <120220.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://wiki.tcl.tk/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
# V0.3 02/20/12: Bugfixes and png image support:
# - snit package load without version
# - try to load png package (starkit at: https://bitbucket.org/mittelmark/tcl-code/downloads )
# - variable BigImages and method_MoveBigImages introduced
# - wiki example link fixed
#
# 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.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.3
package require Tk
package require http
lappend auto_path [file dirname [info script]]
package require snit
package require Tkhtml
catch {
# should check for Tcl8.6
package require tkpng
}
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
variable BigImages
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 <B1-Motion> [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 <Motion> {
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 <ButtonPress-3> [mymethod _Popup]
bind all <Alt-Left> [ mymethod back ]
bind all <Alt-Right> [ mymethod forward ]
bind all <Alt-Home> [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 "[mymethod _MoveBigImage $b]"
}
set Images($fn) $img
return $img
}
method refresh {args} {
if {![info exists LastFile]} return
$self browse $LastFile
}
method _MoveBigImage b {
if {![info exists BigImages($b)]} return
$b copy $BigImages($b)
image delete $BigImages($b)
unset BigImages($b)
update
}
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 {<html>|<!doctype|<body} [string range $htmltxt 0 200]]} {
set htmltxt "<pre>$htmltxt</pre>\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://wiki.tcl.tk/10368"
# installing the popup
.browser popup .popup
}
lets_test_itWhere is MoveBigImage?DDG: Was lost somewhere, have added it again and bumbed version to 0.3
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 [1]. MJL Thanks. This looks interesting. How do I use it?
RFox - 2010-11-15 12:56:06The download link for the incrtcl version of the browser appears to be broken.
See also:
