Purpose: to provide Neil Madden's five line Tkhtml based web page displayer.
This app fetches a web page, formats it, and displays it in a tk scrollable widget. It currently does not handle redirecting URLs, making the web pages active, or ease of changing fonts, etc.
Perhaps some variant of this would be a useful proc for tklib.
Also see the One-line web browser in Tcl
package require Tkhtml;package require http;pack [scrollbar .vsb -orient vertical -command {.html yview}] -side right -fill y;pack [html .html -bg white -yscrollcommand {.vsb set}] -fill both -expand 1;set t [http::geturl http://mini.net/tcl/976.html];.html parse [http::data $t];http::cleanup $tA much more readable version for those just interested in a quick look:
package require Tkhtml
package require http
pack [scrollbar .vsb -orient vertical -command {.html yview}] -side right -fill y
pack [html .html -bg white -yscrollcommand {.vsb set}] -fill both -expand 1
set t [http::geturl http://mini.net/tcl/976.html]
.html parse [http::data $t]
http::cleanup $tLatest and greatest (thanks to DKF and others for comments). No -bg white, but fits in 4 lines/80 chars and adds hyperlinks and error handling (ignoring)!:
package r Tkhtml;package r http;pack [scrollbar .v -o v -co {.h yv}] -s right -f y;pack [html .h -ys {.v set}] -f both -e 1;bind .h.x <1> {eval g [.h href %x %y]};proc g u {set t [http::geturl $u];.h cl;.h p [http::data $t];http::cleanup $t;.h co -base $u};g http://mini.net/tcl/976.html;proc bgerror args {};# NEM :-)NEM - Redirecting URLs aren't too hard. Perhaps there should be an option in the http package though? http::config -followredirects 1. The HTTP codes that indicate a redirect are 301 and 302, so the following should do:
proc geturl_followredirects {url} {
set t [http::geturl $url]
while {([http::ncode $t] == 301) || ([http::ncode $t] == 302)} {
upvar #0 $t state
array set meta $state(meta)
http::cleanup $t
set t [http::geturl $meta(Location)]
}
return $t
}Next, we probably want images too, so the following can be useful:
image create photo default -data {
R0lGODdhJAAkAPEAAACQkADQ0PgAAAAAACwAAAAAJAAkAAACmISPqcsQD6OcdJqKM71PeK15
AsSJH0iZY1CqqKSurfsGsex08XuTuU7L9HywHWZILAaVJssvgoREk5PolFo1XrHZ29IZ8oo0
HKEYVDYbyc/jFhz2otvdcyZdF68qeKh2DZd3AtS0QWcDSDgWKJXY+MXS9qY4+JA2+Vho+YPp
FzSjiTIEWslDQ1rDhPOY2sXVOgeb2kBbu1AAADv/
}This creates a nice default image for us (a red cross if I remember correctly). Then we need a proc for fetching the images:
proc FetchImage {src w h args} {
# Fetch the image
if {[catch {
http::geturl $src -timeout 10000
} token]} {
return default
}
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 default
}
return $name
}You could add caching to this, but I leave that as an exercise. So, we can put this all together:
.html configure -imagecommand FetchImage -hyperlinkcommand geturl
Although, the -hyperlink command doesn't seem to work for me, so try:
proc HrefBinding {x y} {
set new [.html href $x $y]
set new [string trim $new {{}}]
if {[string length $new]} {
geturl $new
}
}
bind .html <Button-1> [list HrefBinding %x %y]Add a wrapper for the hyperlinks:
proc geturl {url} {
.html configure -cursor watch
set t [geturl_followredirects $url]
.html clear
set data [http::data $t]
# Get the url, incase we followed redirects
upvar #0 $t state
set url $state(url)
http::cleanup $t
# Get the bgcolor and stuff.
if {[regexp -nocase {<title>(.*)</title>} $data -> title]} {
wm title . $title
}
if {[regexp -nocase {<body[^>]+bgcolor=([^>]+)>} $data -> bgcolor]} {
set bgcolor [string trim [lindex $bgcolor 0] \"]
catch {.html configure -bg $bgcolor}
}
.html configure -base $url
.html parse $data
.html configure -cursor xterm
}Missing items -
package require Img
goes a long way in helping images work.
bind .html.x <Motion> {
set url [string trim [.html href %x %y] {{}}]
if {[string length $url]} {
.html configure -cursor hand2
} else {
.html configure -cursor xterm
}
}So, the final stage:
proc script {args} {}
.html configure -scriptcommand script
geturl http://www.slashdot.orgOK - I've created a package that wraps up this and some more functionality. The package now has a sourceforge page: http://sourceforge.net/projects/tkbrowser
The basic usage of the package is:
package require browser
pack [scrollbar .vsb -orient vertical -command {.html yview}] -side right -fill y
pack [browser::browser .html -bg white -yscrollcommand {.vsb set}] -side top -fill both -expand 1
pack [label .l -bg gray -textvariable ::browser::browser(.html,status)] -side bottom -fill x
proc updateTitle {var1 var2 op} {
wm title . $::browser::browser($var2)
}
trace variable ::browser::browser(.html,title) w updateTitle
browser::geturl .html http://slashdot.org(NOTE - This syntax is quite different to this now. The internal details of browser arrays are hidden, as is having to set up variable traces. You can just configure -statusvariable, -linkvariable and -titlevariable options to do this).
This deals with getting the page and all images (including a rudimentary cache), and handling links etc. It even will handle forms, but this doesn't seem to be working correctly in my Tkhtml build. License is normal BSD/Tcl license. I'll contribute it to tklib once I've polished it up a bit. Requires Tkhtml and http, with the optional addition of Img (recommended). I need to sort out the URL handling as well - may change to the uri package from tcllib, which handles various URLs better. You can add https support if you have TLS, too (see the http package docs).
For details, or if the above URLs still aren't working, send me an email: mailto:[email protected]
escargo 5 Mar 2003 - I think the choice of the package name browser is a bad one because it's too generic. There are web browser and file browsers. There are also likely to be multiple implementations of each kind, and just grabbing the generic browser package name seems a bit hasty.
NEM 5 Mar 2003 - Well yes. It is a fairly generic name, but I needed a name which summed up the package, and that's what I came up with. It could theoretically act as both a web browser and a file browser quite easily (it has support for file URLs, and it would be easy to add in directory listings). There could well be multiple implementations, but I've not heard from anyone with a similarly named package. I'm open to suggestions however, if you can come up with a better name. It'd take 2 seconds to change the pkgIndex.tcl and alter the namespace. For the moment, as no-one else has contested or had problems from my use of "browser", I'm gonna stick with it.
More important (now that I come to look at this page again) is that I finally finish off the features I was planning to get done (complete form support, moving over fully to Snit for modularity, ftp support). As I've not heard from anyone using it for a good long time, and because VFS is slowing making this all much easier (although, I'm not sure how well VFS copes with redirects and proxy support issues), this is a low-priority job for me, and unlikely to be done for a while. Of course, anyone who has the time and wants to work on a nice little Tcl/Tk package can contact me and get CVS write access. It'd make a good project for a beginner, as it covers quite a bit of common Tcl usage. The above email address still works for anyone interested.
DDG 13 Nov 2003 This is slightly longer as a oneliner but it is inspired by code on this page (thx). A snit wrapper widget created as a one afternoon hack. May be it is long but as a result the widget is fully reuseable. So easy is Snit's Not Incr Tcl ....:
# DESCRIPTION A simple htmlwidget providing the methods
# Load: popups a dialog for local file selection
# LoadFile: 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 LoadFile "http://mini.net/tcl/2993"
# # LOCALFILES
# .browser Load
# # installing the popup
# .browser Popup .popup
# History V0.1 11/13/03: First Release a three hours hack
# Created By: Dr. Detlef Groth nospamdgroth(at)molgen.mpg.de
# delete nospam to answer
package provide snitBrowser 0.1
package require Tk
package require snit 0.9
package require http
lappend auto_path [file dirname [info script]]
package require Tkhtml
snit::widget snitBrowser {
# a one afternoon tkhtml wrap for a
# snit widget which behaves like a htmlwidget
# public methods to use
# Load: popups a dialog for local file selection
# LoadFile: 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
#
# methods with underlines are private and should not be used
variable htmlwidget
variable lastDir
variable Images
variable OldImages
variable hotkey
variable LastFile
variable PrevFiles
variable NextFiles
variable Priv
variable showImages
variable popup
delegate option * to htmlwidget
delegate method * to htmlwidget
constructor {args} {
set lastDir [pwd]
set LastFile {}
set PrevFiles {}
set NextFiles {}
set showImages 1
pack [frame $win.f] -side top -fill both -expand yes
html $win.f.html \
-yscrollcommand "$win.f.vsb set" \
-xscrollcommand "$win.hsb set" \
-padx 5 \
-pady 9 \
-underlinehyperlinks 0 \
-imagecommand [list $self _ImageCmd] \
-unvisitedcolor blue \
-bg beige -tablerelief raised
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 LoadFile [lindex $PrevFiles 0]
}
method Back {} {
$self LoadFile [lindex $PrevFiles end]
}
method Forward {} {
$self LoadFile [lindex $NextFiles end]
}
method Popup {path} {
global popupvar
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> {
if {[winfo exists $popupvar] } {
set x [winfo pointerx .]
set y [winfo pointery .]
tk_popup $popupvar $x $y
}
}
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
}
method _ImageCmd {args} {
if {!$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 LoadFile $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 LoadFile $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 LoadFile {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 $htmlwidget 0 200]]} {
set htmltxt "<pre>$htmltxt</pre>\n"
}
# jcw: end of changed code
$htmlwidget parse $htmltxt
$self _ClearOldImages
# dgroth 13/11/2003 add jumping 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 LoadFile $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 nspamdetlef(at)dgroth.de" -type ok}
$mnu(file) add command -label Exit -underline 1 -command {exit 0}
pack [snitBrowser .browser] -side left -fill both -expand yes
#.browser LoadFile d:/docs/tcl7.6/contents.html ;# local file
.browser LoadFile "http://mini.net/tcl/2993"
# installing the popup
.browser Popup .popup
}
lets_test_itregards, Detlef