Posted to tcl by bairui at Thu Feb 02 03:40:49 GMT 2017view raw
- #!/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
- }