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, makin the web pages active, or ease of changing fonts, etc.
Perhaps some variant of this would be a useful proc for tklib.
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 $t
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 which 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.org