Posted to tcl by bairui at Thu Feb 02 03:40:49 GMT 2017view pretty
#!/usr/bin/env wish
package require Tk
package require opt
package require Img
package require Tkhtml
# set app_dir [file dirname [info script]]
# source [file join $app_dir czrss.tcl]
# package provide czrss 0.11
package require snit
package require tdom
package require http
if {![catch {package require autoproxy}]} {
autoproxy::init
}
namespace eval ::net {
proc get_url url {
set token [::http::geturl $url -timeout 10000]
set data [::http::data $token]
::http::cleanup $token
return $data
}
proc get_image uri {
#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] } {
#create image using file
image create photo $uri -file $uri
return $uri
}
#if the 'url' is an http url.
if { [string equal -length 7 $uri http://] } {
image create photo $uri -data [get_url $uri]
return $uri
}
}
}
# This is the class representing an RSS document
snit::type ::czrss::doc {
variable xpath
variable channel
variable items
variable url
# Konstruktor for a given URI
constructor { uri } {
set url $uri
$self load
}
method load { } {
set xml ""
set tries 0
while {! [string match "*?xml*" $xml]} {
set xml [::net::get_url $url]
after 1000 incr tries
if {$tries > 5} {return -code error}
}
# load xml into dom from temporary file
set doc [ dom parse $xml ]
set _root [ $doc documentElement ]
set root [$doc documentElement]
switch [getRSSVersion $doc] {
0.91 - 0.92 - 0.93 - 2.0 {
set xpath(titleXpath) {/rss/channel/title/text()}
set xpath(linkXpath) {/rss/channel/link/text()}
set xpath(imgNodeXpath) {/rss/channel/image/title}
set xpath(imgTitleXpath) {/rss/channel/image/title/text()}
set xpath(imgLinkXpath) {/rss/channel/image/url/text()}
set xpath(imgWidthXpath) {/rss/channel/image/width/text()}
set xpath(imgHeightXpath) {/rss/channel/image/height/text()}
set xpath(storiesXpath) {/rss/channel/item}
set xpath(itemTitleXpath) {title/text()}
set xpath(itemLinkXpath) {link/text()}
set xpath(itemPubDateXpath) {pubDate/text()}
set xpath(itemDescXpath) {description/text()}
}
1.0 {
set xpath(titleXpath) {/rdf:RDF/*[local-name()='channel']/*[local-name()='title']/text()}
set xpath(linkXpath) {/rdf:RDF/*[local-name()='channel']/*[local-name()='link']/text()}
set xpath(imgNodeXpath) {/rdf:RDF/*[local-name()='image']}
set xpath(imgTitleXpath) {/rdf:RDF/*[local-name()='image']/*[local-name()='title']/text()}
set xpath(imgLinkXpath) {/rdf:RDF/*[local-name()='image']/*[local-name()='url']/text()}
set xpath(imgWidthXpath) {/rdf:RDF/*[local-name()='image']/*[local-name()='width']/text()}
set xpath(imgHeightXpath) {/rdf:RDF/*[local-name()='image']/*[local-name()='height']/text()}
set xpath(storiesXpath) {/rdf:RDF/*[local-name()='item']}
set xpath(itemTitleXpath) {*[local-name()='title']/text()}
set xpath(itemLinkXpath) {*[local-name()='link']/text()}
set xpath(itemPubDateXpath) {*[local-name()='pubDate']/text()}
set xpath(itemDescXpath) {*[local-name()='description']/text()}
}
default {
error "Unssupported schema [getRSSVersion $doc]"
}
}
# Channel
set cN [ $_root child 1 channel ]
set channel [::czrss::channel create %AUTO% $self $cN]
# Items
set items {}
set stories [$_root selectNodes $xpath(storiesXpath) ]
foreach iN $stories {
lappend items [ ::czrss::item create %AUTO% $self $iN ]
}
}
# returns the XPath Query for a given type
method xpath { key } {
return $xpath($key)
}
# returns the channel object
method channel {} {
return $channel
}
# returns a list of items
method items {} {
return $items
}
# detects the RSS version of the document
proc getRSSVersion {doc} {
set root [$doc documentElement]
switch [$root nodeName] {
rss {
if {[$root hasAttribute version]} {
return [$root getAttribute version]
}
# Best guess as most stuff is optional...
return 0.92
}
rdf:RDF {
return 1.0
}
default {
return 0
}
}
}
}
# this class is used to contain rss items
snit::type ::czrss::item {
variable _node
variable _doc
constructor {doc node } {
variable history
set _doc $doc
set _node $node
}
# get the title
method title { } {
set xpath [$_doc xpath itemTitleXpath]
return [ ::czrss::nodeTxt $_node $xpath]
}
# get the link
method link {} {
set xpath [$_doc xpath itemLinkXpath]
return [ ::czrss::nodeUri $_node $xpath]
}
# get the description
method description {} {
set xpath [$_doc xpath itemDescXpath]
return [ ::czrss::nodeTxt $_node $xpath]
}
# return the publication date as string
method pubDate {} {
set xpath [$_doc xpath itemPubDateXpath]
return [ ::czrss::nodeTxt $_node $xpath]
}
}
# this class contains information on the channel
snit::type ::czrss::channel {
variable _doc
variable _root
constructor { doc root} {
set _doc $doc
set _root $root
}
# get the title
method title { } {
set xpath [$_doc xpath titleXpath]
return [ ::czrss::nodeTxt $_root $xpath]
}
# get the image link
method imgLink {} {
set xpath [$_doc xpath imgLinkXpath]
return [ ::czrss::nodeUri $_root $xpath]
}
# get the image title
method imgTitle {} {
set xpath [$_doc xpath imgTitleXpath]
return [ ::czrss::nodeUri $_root $xpath]
}
# get the image width
method imgWidth {} {
set xpath [$_doc xpath imgWidthXpath]
return [ ::czrss::nodeTxt $_root $xpath]
}
# get the image height
method imgHeight {} {
set xpath [$_doc xpath imgHeightXpath]
return [ ::czrss::nodeTxt $_root $xpath]
}
}
# this namespace contains some utility methods
namespace eval ::czrss {
proc encUri {uri} {
set res {}
foreach c [split $uri {}] {
append res [
if {[string match {[-A-Za-z.0-9!()'*_~:/]} $c]} {
set c
} else {
format %%%02X [scan $c %c]
}]
}
set res
}
proc encTxt {txt} {
return [string map { & & < < > > } $txt]
}
proc nodeUri {node xpath} {
if {[$node selectNode $xpath] != ""} {
# Only if there is a lonely &, quote it back to an entity.
return [encUri [[$node selectNode $xpath] nodeValue]]
} else {
return ""
}
}
proc nodeTxt {node xpath} {
if {[$node selectNode $xpath] != ""} {
return [[$node selectNode $xpath] nodeValue]
} else {
return ""
}
}
}
namespace eval ::rssgui {
variable counter
proc init {} {
variable counter
set counter 0
. configure -background white
option add *background white
ttk::frame .t
text .t.text -relief flat -wrap word \
-selectbackground blue \
-yscrollcommand {.t.sby set} \
-highlightthickness 0
scrollbar .t.sby -orient vert -command {.t.text yview} \
-highlightthickness 0
# Configure text widget
.t.text tag configure title -foreground steelblue -font {Helvetica 16} \
-spacing1 5 -spacing3 5
.t.text tag configure description -foreground black \
-spacing1 10 -lmargin1 20 -lmargin2 10 -spacing3 5 -elide true
.t.text tag configure even -background whitesmoke
.t.text tag configure odd -background white
.t.text tag configure visible -elide false
.t.text configure -state disabled
html .browser -height 20 -imagecmd ::net::get_image
ttk::frame .buttons
ttk::frame .buttons.padding
set off_data {
R0lGODlhIAAgAOcAAP////7+/vv7++rq6uPj4/X19eXl5ZCQkHBwcMXFxfn5+f39/crKykJCQhoa
GpGRkfLy8vz8/MDAwDMzMxEREYGBge/v78HBwTQ0NBISEoODg97e3s3Nzfb29sPDwzg4OBYWFoWF
hfDw8PPz87+/v+Dg4NnZ2Wtra1tbW9TU1DU1NcnJyUZGRm1tbdvb2+vr63p6ehMTEyoqKrGxsYKC
gvj4+J2dnXZ2dunp6bS0tCUlJQsLC19fXzIyMhAQENPT01dXVwoKCiMjI7Ozs+zs7GxsbAkJCby8
vMLCwoSEhDExMdXV1To6OnJycu3t7Tc3NxQUFIaGhmlpaVFRUeLi4sbGxi4uLh0dHaioqJaWlszM
zCgoKLq6urKysiEhIScnJx4eHtfX1zY2NiAgICkpKZSUlPT09Pf398/Pz+Hh4U5OTggICFlZWVpa
WlJSUouLi6SkpA0NDQcHB0hISPr6+sjIyI+PjwwMDE9PT7e3t0pKShwcHJWVlXd3dy8vL3t7e7W1
tampqSsrK+bm5iIiIjAwMBsbG4CAgK6url1dXS0tLRgYGDs7O6Wlpaamprm5uf//////////////
////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////yH+FUNyZWF0ZWQgd2l0aCBU
aGUgR0lNUAAh+QQBCgD/ACwAAAAAIAAgAAAI/gABCBxIsKDBgwgTKlzIUGCAhhAFChhAoEBEhgEM
HECQQMFFhQsYNHDwAMJHhAEiSJhAoYKFhycdLgiQ8gKGDBpeBhBwcsEGDh1SevgAIoQIACNIlFgQ
MYCJEyhSLIhwQQVOCwtWsGjhAibDFzBiyJihgOpNGhZq2HCQ4QaOhhFy6NjBw8WCBRJ6+HC54AeQ
IEKGRGBIpIiRHkd4LkCiIkaSoxGOKNkBw+TCJUx2NHEicIGHJ1CiHAXwQkqQKVQWBqhi5QoWngAW
2MxAY3SNLDEmaPF6cAGJLTq4MI39OfToBV28fCExHOWFL2C6DA8QhocYLB06dxlD5gLvgxx6t2Qo
U2OgGS1HDAw/8yCDCjQM06hZwyYNQQEKvFJps8YNAYYFvOHDGHCUd9AZcHgRRxQWqaYFE3LMkQAd
BtFBQgNyfFDHdwiZYYcDd+CRB1YSvZCDHkHswUeDDRHQBwhG+PEHIFrUEUgLghgBAgyDXBRAGjTo
IEcchExQiCFBrPHFIWlwqJoTiCSiCBiLLEIIIy3k4ISTDdExSB05NOLIIykQMVhMBAWwgAACNIfm
m3DGKeecdCoUEAA7
}
image create photo off -data $off_data
ttk::button .buttons.exit -command {exit 0} -image off
grid .t.text -row 0 -column 0 -sticky news
grid .t.sby -row 0 -column 1 -sticky ns
grid .buttons.padding -row 0 -column 0 -sticky ew
grid .buttons.exit -row 0 -column 1 -sticky e
grid .t -row 0 -column 0 -sticky news
grid .browser -row 1 -column 0 -sticky news
grid .buttons -row 2 -column 0 -sticky ew
grid rowconfigure . .t -weight 2
grid columnconfigure . .t -weight 2
grid rowconfigure . .browser -weight 1
grid columnconfigure . .browser -weight 1
grid rowconfigure .t .t.text -weight 1
grid columnconfigure .t .t.text -weight 1
grid columnconfigure .buttons .buttons.padding -weight 1
}
proc setFeed { url } {
set doc [::czrss::doc create %AUTO% $url ]
set channel [$doc channel]
wm title . [$channel title]
.t.text configure -state normal
.t.text delete 0.0 end
foreach item [ $doc items ] {
insertMessage [$item title] [$item description] [$item link]
}
.t.text configure -state disabled
}
# insert a message into the text widget
proc insertMessage { title description url } {
variable counter
set id [ clock clicks]
if {[expr [incr counter] % 2 ]} {
set row even
} else {
set row odd
}
.t.text insert end "$title\n" [ list $row title $id]
.t.text tag bind $id <Enter> [list ::rssgui::enterTag $id]
.t.text tag bind $id <Double-1> [list ::rssgui::startBrowser [string map { % %% } $url]]
incr id
.t.text insert end "$description\n" [ list $row description $id]
}
# called when entering a taged item with the mouse in the text widget
proc enterTag { id } {
set start [ lindex [.t.text tag nextrange $id 0.0 end] 0]
set end [ lindex [.t.text tag nextrange [expr $id +1 ] 0.0 end] 1]
set text [.t.text get $start $end]
browse $text
}
proc browse {text} {
.browser reset
.browser parse $text
}
# start a HTML browser on the local machine
proc startBrowser {url} {
set binary [array get env BROWSER]
if {$binary eq ""} {
foreach browser [list google-chrome firefox mozilla galeon konqueror netscape opera] {
set binary [lindex [auto_execok $browser] 0]
if {[string length $binary]} {
break
}
}
} else {
set binary [lindex $binary 1]
}
catch {exec $binary $url &}
}
}
proc main {{url "http://news.yahoo.com/rss/world" }} {
rssgui::init
rssgui::setFeed $url
}
if {[catch { eval main $argv } res]} {
puts stderr $res
} else {
puts stdout $res
}