Posted to tcl by bairui at Thu Feb 02 03:40:49 GMT 2017view raw

  1. #!/usr/bin/env wish
  2.  
  3. package require Tk
  4. package require opt
  5. package require Img
  6. package require Tkhtml
  7.  
  8. # set app_dir [file dirname [info script]]
  9. # source [file join $app_dir czrss.tcl]
  10. # package provide czrss 0.11
  11.  
  12. package require snit
  13. package require tdom
  14. package require http
  15.  
  16. if {![catch {package require autoproxy}]} {
  17. autoproxy::init
  18. }
  19.  
  20. namespace eval ::net {
  21. proc get_url url {
  22. set token [::http::geturl $url -timeout 10000]
  23. set data [::http::data $token]
  24. ::http::cleanup $token
  25. return $data
  26. }
  27.  
  28. proc get_image uri {
  29. #if the 'url' passed is an image name
  30. if { [lsearch [image names] $uri] > -1 } {
  31. return $uri
  32. }
  33.  
  34. # if the 'url' passed is a file on disk
  35. if { [file exists $uri] } {
  36. #create image using file
  37. image create photo $uri -file $uri
  38. return $uri
  39. }
  40.  
  41. #if the 'url' is an http url.
  42. if { [string equal -length 7 $uri http://] } {
  43. image create photo $uri -data [get_url $uri]
  44. return $uri
  45. }
  46. }
  47. }
  48.  
  49. # This is the class representing an RSS document
  50. snit::type ::czrss::doc {
  51. variable xpath
  52. variable channel
  53. variable items
  54. variable url
  55.  
  56. # Konstruktor for a given URI
  57. constructor { uri } {
  58. set url $uri
  59. $self load
  60. }
  61.  
  62. method load { } {
  63. set xml ""
  64. set tries 0
  65. while {! [string match "*?xml*" $xml]} {
  66. set xml [::net::get_url $url]
  67. after 1000 incr tries
  68. if {$tries > 5} {return -code error}
  69. }
  70.  
  71. # load xml into dom from temporary file
  72. set doc [ dom parse $xml ]
  73. set _root [ $doc documentElement ]
  74.  
  75. set root [$doc documentElement]
  76. switch [getRSSVersion $doc] {
  77. 0.91 - 0.92 - 0.93 - 2.0 {
  78. set xpath(titleXpath) {/rss/channel/title/text()}
  79. set xpath(linkXpath) {/rss/channel/link/text()}
  80. set xpath(imgNodeXpath) {/rss/channel/image/title}
  81. set xpath(imgTitleXpath) {/rss/channel/image/title/text()}
  82. set xpath(imgLinkXpath) {/rss/channel/image/url/text()}
  83. set xpath(imgWidthXpath) {/rss/channel/image/width/text()}
  84. set xpath(imgHeightXpath) {/rss/channel/image/height/text()}
  85. set xpath(storiesXpath) {/rss/channel/item}
  86. set xpath(itemTitleXpath) {title/text()}
  87. set xpath(itemLinkXpath) {link/text()}
  88. set xpath(itemPubDateXpath) {pubDate/text()}
  89. set xpath(itemDescXpath) {description/text()}
  90. }
  91. 1.0 {
  92. set xpath(titleXpath) {/rdf:RDF/*[local-name()='channel']/*[local-name()='title']/text()}
  93. set xpath(linkXpath) {/rdf:RDF/*[local-name()='channel']/*[local-name()='link']/text()}
  94. set xpath(imgNodeXpath) {/rdf:RDF/*[local-name()='image']}
  95. set xpath(imgTitleXpath) {/rdf:RDF/*[local-name()='image']/*[local-name()='title']/text()}
  96. set xpath(imgLinkXpath) {/rdf:RDF/*[local-name()='image']/*[local-name()='url']/text()}
  97. set xpath(imgWidthXpath) {/rdf:RDF/*[local-name()='image']/*[local-name()='width']/text()}
  98. set xpath(imgHeightXpath) {/rdf:RDF/*[local-name()='image']/*[local-name()='height']/text()}
  99. set xpath(storiesXpath) {/rdf:RDF/*[local-name()='item']}
  100. set xpath(itemTitleXpath) {*[local-name()='title']/text()}
  101. set xpath(itemLinkXpath) {*[local-name()='link']/text()}
  102. set xpath(itemPubDateXpath) {*[local-name()='pubDate']/text()}
  103. set xpath(itemDescXpath) {*[local-name()='description']/text()}
  104. }
  105. default {
  106. error "Unssupported schema [getRSSVersion $doc]"
  107. }
  108. }
  109.  
  110. # Channel
  111. set cN [ $_root child 1 channel ]
  112. set channel [::czrss::channel create %AUTO% $self $cN]
  113.  
  114. # Items
  115. set items {}
  116. set stories [$_root selectNodes $xpath(storiesXpath) ]
  117. foreach iN $stories {
  118. lappend items [ ::czrss::item create %AUTO% $self $iN ]
  119. }
  120. }
  121.  
  122. # returns the XPath Query for a given type
  123. method xpath { key } {
  124. return $xpath($key)
  125. }
  126.  
  127. # returns the channel object
  128. method channel {} {
  129. return $channel
  130. }
  131.  
  132. # returns a list of items
  133. method items {} {
  134. return $items
  135. }
  136.  
  137. # detects the RSS version of the document
  138. proc getRSSVersion {doc} {
  139. set root [$doc documentElement]
  140. switch [$root nodeName] {
  141. rss {
  142. if {[$root hasAttribute version]} {
  143. return [$root getAttribute version]
  144. }
  145. # Best guess as most stuff is optional...
  146. return 0.92
  147. }
  148. rdf:RDF {
  149. return 1.0
  150. }
  151. default {
  152. return 0
  153. }
  154. }
  155. }
  156. }
  157.  
  158. # this class is used to contain rss items
  159. snit::type ::czrss::item {
  160. variable _node
  161. variable _doc
  162.  
  163. constructor {doc node } {
  164. variable history
  165. set _doc $doc
  166. set _node $node
  167. }
  168. # get the title
  169. method title { } {
  170. set xpath [$_doc xpath itemTitleXpath]
  171. return [ ::czrss::nodeTxt $_node $xpath]
  172. }
  173. # get the link
  174. method link {} {
  175. set xpath [$_doc xpath itemLinkXpath]
  176. return [ ::czrss::nodeUri $_node $xpath]
  177. }
  178. # get the description
  179. method description {} {
  180. set xpath [$_doc xpath itemDescXpath]
  181. return [ ::czrss::nodeTxt $_node $xpath]
  182. }
  183. # return the publication date as string
  184. method pubDate {} {
  185. set xpath [$_doc xpath itemPubDateXpath]
  186. return [ ::czrss::nodeTxt $_node $xpath]
  187. }
  188. }
  189.  
  190. # this class contains information on the channel
  191. snit::type ::czrss::channel {
  192. variable _doc
  193. variable _root
  194.  
  195. constructor { doc root} {
  196. set _doc $doc
  197. set _root $root
  198. }
  199. # get the title
  200. method title { } {
  201. set xpath [$_doc xpath titleXpath]
  202. return [ ::czrss::nodeTxt $_root $xpath]
  203. }
  204. # get the image link
  205. method imgLink {} {
  206. set xpath [$_doc xpath imgLinkXpath]
  207. return [ ::czrss::nodeUri $_root $xpath]
  208. }
  209. # get the image title
  210. method imgTitle {} {
  211. set xpath [$_doc xpath imgTitleXpath]
  212. return [ ::czrss::nodeUri $_root $xpath]
  213. }
  214.  
  215. # get the image width
  216. method imgWidth {} {
  217. set xpath [$_doc xpath imgWidthXpath]
  218. return [ ::czrss::nodeTxt $_root $xpath]
  219. }
  220. # get the image height
  221. method imgHeight {} {
  222. set xpath [$_doc xpath imgHeightXpath]
  223. return [ ::czrss::nodeTxt $_root $xpath]
  224. }
  225. }
  226.  
  227. # this namespace contains some utility methods
  228. namespace eval ::czrss {
  229.  
  230. proc encUri {uri} {
  231. set res {}
  232. foreach c [split $uri {}] {
  233. append res [
  234. if {[string match {[-A-Za-z.0-9!()'*_~:/]} $c]} {
  235. set c
  236. } else {
  237. format %%%02X [scan $c %c]
  238. }]
  239. }
  240. set res
  241. }
  242.  
  243. proc encTxt {txt} {
  244. return [string map { & &amp; < &lt; > &gt; } $txt]
  245. }
  246.  
  247. proc nodeUri {node xpath} {
  248. if {[$node selectNode $xpath] != ""} {
  249. # Only if there is a lonely &, quote it back to an entity.
  250. return [encUri [[$node selectNode $xpath] nodeValue]]
  251. } else {
  252. return ""
  253. }
  254. }
  255.  
  256. proc nodeTxt {node xpath} {
  257. if {[$node selectNode $xpath] != ""} {
  258. return [[$node selectNode $xpath] nodeValue]
  259. } else {
  260. return ""
  261. }
  262. }
  263.  
  264. }
  265.  
  266. namespace eval ::rssgui {
  267. variable counter
  268.  
  269. proc init {} {
  270. variable counter
  271. set counter 0
  272.  
  273. . configure -background white
  274. option add *background white
  275.  
  276. ttk::frame .t
  277.  
  278. text .t.text -relief flat -wrap word \
  279. -selectbackground blue \
  280. -yscrollcommand {.t.sby set} \
  281. -highlightthickness 0
  282.  
  283. scrollbar .t.sby -orient vert -command {.t.text yview} \
  284. -highlightthickness 0
  285.  
  286. # Configure text widget
  287. .t.text tag configure title -foreground steelblue -font {Helvetica 16} \
  288. -spacing1 5 -spacing3 5
  289. .t.text tag configure description -foreground black \
  290. -spacing1 10 -lmargin1 20 -lmargin2 10 -spacing3 5 -elide true
  291. .t.text tag configure even -background whitesmoke
  292. .t.text tag configure odd -background white
  293. .t.text tag configure visible -elide false
  294. .t.text configure -state disabled
  295.  
  296. html .browser -height 20 -imagecmd ::net::get_image
  297.  
  298. ttk::frame .buttons
  299. ttk::frame .buttons.padding
  300.  
  301. set off_data {
  302. R0lGODlhIAAgAOcAAP////7+/vv7++rq6uPj4/X19eXl5ZCQkHBwcMXFxfn5+f39/crKykJCQhoa
  303. GpGRkfLy8vz8/MDAwDMzMxEREYGBge/v78HBwTQ0NBISEoODg97e3s3Nzfb29sPDwzg4OBYWFoWF
  304. hfDw8PPz87+/v+Dg4NnZ2Wtra1tbW9TU1DU1NcnJyUZGRm1tbdvb2+vr63p6ehMTEyoqKrGxsYKC
  305. gvj4+J2dnXZ2dunp6bS0tCUlJQsLC19fXzIyMhAQENPT01dXVwoKCiMjI7Ozs+zs7GxsbAkJCby8
  306. vMLCwoSEhDExMdXV1To6OnJycu3t7Tc3NxQUFIaGhmlpaVFRUeLi4sbGxi4uLh0dHaioqJaWlszM
  307. zCgoKLq6urKysiEhIScnJx4eHtfX1zY2NiAgICkpKZSUlPT09Pf398/Pz+Hh4U5OTggICFlZWVpa
  308. WlJSUouLi6SkpA0NDQcHB0hISPr6+sjIyI+PjwwMDE9PT7e3t0pKShwcHJWVlXd3dy8vL3t7e7W1
  309. tampqSsrK+bm5iIiIjAwMBsbG4CAgK6url1dXS0tLRgYGDs7O6Wlpaamprm5uf//////////////
  310. ////////////////////////////////////////////////////////////////////////////
  311. ////////////////////////////////////////////////////////////////////////////
  312. ////////////////////////////////////////////////////////////////////////////
  313. ////////////////////////////////////////////////////////////////////////////
  314. ////////////////////////////////////////////////////////////////////////////
  315. /////////////////////////////////////////////////////yH+FUNyZWF0ZWQgd2l0aCBU
  316. aGUgR0lNUAAh+QQBCgD/ACwAAAAAIAAgAAAI/gABCBxIsKDBgwgTKlzIUGCAhhAFChhAoEBEhgEM
  317. HECQQMFFhQsYNHDwAMJHhAEiSJhAoYKFhycdLgiQ8gKGDBpeBhBwcsEGDh1SevgAIoQIACNIlFgQ
  318. MYCJEyhSLIhwQQVOCwtWsGjhAibDFzBiyJihgOpNGhZq2HCQ4QaOhhFy6NjBw8WCBRJ6+HC54AeQ
  319. IEKGRGBIpIiRHkd4LkCiIkaSoxGOKNkBw+TCJUx2NHEicIGHJ1CiHAXwQkqQKVQWBqhi5QoWngAW
  320. 2MxAY3SNLDEmaPF6cAGJLTq4MI39OfToBV28fCExHOWFL2C6DA8QhocYLB06dxlD5gLvgxx6t2Qo
  321. U2OgGS1HDAw/8yCDCjQM06hZwyYNQQEKvFJps8YNAYYFvOHDGHCUd9AZcHgRRxQWqaYFE3LMkQAd
  322. BtFBQgNyfFDHdwiZYYcDd+CRB1YSvZCDHkHswUeDDRHQBwhG+PEHIFrUEUgLghgBAgyDXBRAGjTo
  323. IEcchExQiCFBrPHFIWlwqJoTiCSiCBiLLEIIIy3k4ISTDdExSB05NOLIIykQMVhMBAWwgAACNIfm
  324. m3DGKeecdCoUEAA7
  325. }
  326.  
  327. image create photo off -data $off_data
  328. ttk::button .buttons.exit -command {exit 0} -image off
  329.  
  330. grid .t.text -row 0 -column 0 -sticky news
  331. grid .t.sby -row 0 -column 1 -sticky ns
  332.  
  333. grid .buttons.padding -row 0 -column 0 -sticky ew
  334. grid .buttons.exit -row 0 -column 1 -sticky e
  335.  
  336. grid .t -row 0 -column 0 -sticky news
  337. grid .browser -row 1 -column 0 -sticky news
  338. grid .buttons -row 2 -column 0 -sticky ew
  339.  
  340. grid rowconfigure . .t -weight 2
  341. grid columnconfigure . .t -weight 2
  342. grid rowconfigure . .browser -weight 1
  343. grid columnconfigure . .browser -weight 1
  344. grid rowconfigure .t .t.text -weight 1
  345. grid columnconfigure .t .t.text -weight 1
  346. grid columnconfigure .buttons .buttons.padding -weight 1
  347. }
  348.  
  349. proc setFeed { url } {
  350. set doc [::czrss::doc create %AUTO% $url ]
  351. set channel [$doc channel]
  352. wm title . [$channel title]
  353. .t.text configure -state normal
  354. .t.text delete 0.0 end
  355. foreach item [ $doc items ] {
  356. insertMessage [$item title] [$item description] [$item link]
  357. }
  358. .t.text configure -state disabled
  359. }
  360.  
  361. # insert a message into the text widget
  362. proc insertMessage { title description url } {
  363. variable counter
  364. set id [ clock clicks]
  365.  
  366. if {[expr [incr counter] % 2 ]} {
  367. set row even
  368. } else {
  369. set row odd
  370. }
  371.  
  372. .t.text insert end "$title\n" [ list $row title $id]
  373. .t.text tag bind $id <Enter> [list ::rssgui::enterTag $id]
  374. .t.text tag bind $id <Double-1> [list ::rssgui::startBrowser [string map { % %% } $url]]
  375.  
  376. incr id
  377. .t.text insert end "$description\n" [ list $row description $id]
  378. }
  379.  
  380. # called when entering a taged item with the mouse in the text widget
  381. proc enterTag { id } {
  382. set start [ lindex [.t.text tag nextrange $id 0.0 end] 0]
  383. set end [ lindex [.t.text tag nextrange [expr $id +1 ] 0.0 end] 1]
  384. set text [.t.text get $start $end]
  385. browse $text
  386. }
  387.  
  388. proc browse {text} {
  389. .browser reset
  390. .browser parse $text
  391. }
  392.  
  393. # start a HTML browser on the local machine
  394. proc startBrowser {url} {
  395. set binary [array get env BROWSER]
  396. if {$binary eq ""} {
  397. foreach browser [list google-chrome firefox mozilla galeon konqueror netscape opera] {
  398. set binary [lindex [auto_execok $browser] 0]
  399. if {[string length $binary]} {
  400. break
  401. }
  402. }
  403. } else {
  404. set binary [lindex $binary 1]
  405. }
  406. catch {exec $binary $url &}
  407. }
  408. }
  409.  
  410. proc main {{url "http://news.yahoo.com/rss/world" }} {
  411. rssgui::init
  412. rssgui::setFeed $url
  413. }
  414.  
  415. if {[catch { eval main $argv } res]} {
  416. puts stderr $res
  417. } else {
  418. puts stdout $res
  419. }
  420.