The first file, rss.tcl, is a very minimal package to read rss feeds. Yes, I know such a package already exists, but it helped me get into the xml package.
I don't think any of the RSS packages have made it into tcllib or the other major distributed extensions, have they? Perhaps one of these could be considered for tcllib?
schlenk The basic problem with XML stuff for the tcllib is, that there isn't any pure Tcl xml package inside tcllib ( a great lacking IMHO).
#!/usr/local/bin/tclsh
package require Tcl 8.4
package require struct 2.0
package require xml 2.6
package require snit 0.9
package provide rss 1.0
namespace eval ::rss {
variable parser
variable parserStack
variable channelObject
variable currentCmds
array set currentCmds \
[list \
elementStart [list [namespace current]::XML.StartRSS] \
elementEnd [list [namespace current]::XML.EndRSS] \
characterData {} \
]
}
proc ::rss::Parser.NewState {elementStart elementEnd characterData} {
variable parser
variable parserStack
variable currentCmds
variable channel
$parserStack push \
[list \
$currentCmds(elementStart) \
$currentCmds(elementEnd) \
$currentCmds(characterData) \
]
set currentCmds(elementStart) $elementStart
set currentCmds(elementEnd) $elementEnd
set currentCmds(characterData) $characterData
return
}
proc ::rss::Parser.PreviousState {} {
variable parser
variable parserStack
variable currentCmds
foreach {currentCmds(elementStart) currentCmds(elementEnd) currentCmds(characterData)} [$parserStack pop] {break}
return
}
proc ::rss::Wrapper.ElementStart {name attlist args} {
variable currentCmds
if {$currentCmds(elementStart)!={}} {
set code [catch {uplevel \#0 $currentCmds(elementStart) [list $name $attlist] $args} result]
return -code $code -errorinfo $::errorInfo -errorcode $::errorCode $result
}
}
proc ::rss::Wrapper.ElementEnd {name args} {
variable currentCmds
if {$currentCmds(elementEnd)!={}} {
set code [catch {uplevel \#0 $currentCmds(elementEnd) [list $name] $args} result]
return -code $code -errorinfo $::errorInfo -errorcode $::errorCode $result
}
}
proc ::rss::Wrapper.CharacterData {data} {
variable currentCmds
if {$currentCmds(characterData)!={}} {
set code [catch {uplevel \#0 $currentCmds(characterData) [list $data]} result]
return -code $code -errorinfo $::errorInfo -errorcode $::errorCode $result
}
}
proc ::rss::parse {data} {
variable parser
variable parserStack
variable channel
variable currentCmds
set parser [::xml::parser ]
set parserStack [::struct::stack]
set channel [Channel %AUTO%]
$parser configure \
-elementstartcommand [namespace current]::Wrapper.ElementStart \
-elementendcommand [namespace current]::Wrapper.ElementEnd \
-characterdatacommand [namespace current]::Wrapper.CharacterData
if {[catch {$parser parse $data} errorMsg]} {
# Caught an error, destroy the channel
$channel destroy
set channel {}
# Reset the stack
while {[$parserStack size] != 0} {
Parser.PreviousState
}
$parser free
$parserStack destroy
if {$channel == {}} {
return -code error $errorMsg
} else {
return $channel
}
}
proc ::rss::XML.StartRSS {name attlist args} {
variable channel
switch -- $name {
channel {
Parser.NewState \
[list [namespace current]::XML.Channel $channel] \
[list [namespace current]::XML.ElementEnd] \
{}
}
item {
set obj [Item %AUTO%]
$channel AddItem $obj
Parser.NewState \
[list [namespace current]::XML.Item $obj] \
[list [namespace current]::XML.ElementEnd] \
{}
}
}
return
}
proc ::rss::XML.EndRSS {name args} {
return
}
proc ::rss::XML.Channel {obj name attlist args} {
switch -- $name {
title {
Parser.NewState \
[list [namespace current]::XML.ElementStart] \
[list [namespace current]::XML.ElementEnd] \
[list [namespace current]::XML.CharacterData [$obj GetVariable title]]
}
link {
Parser.NewState \
[list [namespace current]::XML.ElementStart] \
[list [namespace current]::XML.ElementEnd] \
[list [namespace current]::XML.CharacterData [$obj GetVariable link]]
}
description {
Parser.NewState \
[list [namespace current]::XML.ElementStart] \
[list [namespace current]::XML.ElementEnd] \
[list [namespace current]::XML.CharacterData [$obj GetVariable description]]
}
item {
set item [Item %AUTO%]
$obj AddItem $item
Parser.NewState \
[list [namespace current]::XML.Item $item] \
[list [namespace current]::XML.ElementEnd] \
{}
}
default {
Parser.NewState \
[list [namespace current]::XML.ElementStart] \
[list [namespace current]::XML.ElementEnd] \
{}
}
}
return
}
proc ::rss::XML.Item {obj name attlist args} {
switch -- $name {
title {
Parser.NewState \
[list [namespace current]::XML.ElementStart] \
[list [namespace current]::XML.ElementEnd] \
[list [namespace current]::XML.CharacterData [$obj GetVariable title]]
}
link {
Parser.NewState \
[list [namespace current]::XML.ElementStart] \
[list [namespace current]::XML.ElementEnd] \
[list [namespace current]::XML.CharacterData [$obj GetVariable link]]
}
description {
Parser.NewState \
[list [namespace current]::XML.ElementStart] \
[list [namespace current]::XML.ElementEnd] \
[list [namespace current]::XML.CharacterData [$obj GetVariable description]]
}
default {
Parser.NewState \
[list [namespace current]::XML.ElementStart] \
[list [namespace current]::XML.ElementEnd] \
{}
}
}
return
}
proc ::rss::XML.ElementStart {name attlist args} {
Parser.NewState \
[list [namespace current]::XML.ElementStart] \
[list [namespace current]::XML.ElementEnd] \
{}
return
}
proc ::rss::XML.ElementEnd {name args} {
Parser.PreviousState
return
}
proc ::rss::XML.CharacterData {var data} {
upvar \#0 $var myVar
append myVar $data
return
}
::snit::type ::rss::Channel {
variable title {}
variable link {}
variable description {}
variable items {}
destructor {
foreach item $items {
$item destroy
}
return
}
method title {} {
return $title
}
method link {} {
return $link
}
method description {} {
return $description
}
method items {} {
return $items
}
method GetVariable {var} {
return [varname $var]
}
method AddItem {item} {
lappend items $item
}
}
::snit::type ::rss::Item {
variable title {}
variable link {}
variable pubDate {}
variable description {}
method title {} {
return $title
}
method link {} {
return $link
}
method pubDate {} {
return $pubDate
}
method description {} {
return $description
}
method GetVariable {var} {
return [varname $var]
}
}This is the main body of the program, rss_monitor.tcl
#!/usr/local/bin/tclsh
lappend auto_path .
package require Tcl 8.4
package require http 2.4
package require mime 1.3
package require smtp 1.3
package require md5 1.4
package require rss 1.0
#Reads the options file.
proc loadOptions {file} {
#Initialize the interpreter which executes the contents
#of the options file.
set interp [interp create -safe]
$interp eval [list namespace delete ::]
$interp alias email loadOptions.email
#Read the options file.
set inFile [open $file r]
$interp eval [read $inFile]
close $inFile
interp delete $interp
return
}
proc loadOptions.email {email data} {
#Initialize the interpeter which executes the contents of the
#data variable.
set interp [interp create -safe]
$interp eval [list namespace delete ::]
$interp alias rss loadOptions.rss $email
$interp eval $data
interp delete $interp
return
}
proc loadOptions.rss {email url} {
#Store the url in the global options array.
if {![info exists ::options(email,$url)]} {
lappend ::options(url) $url
}
lappend ::options(email,$url) $email
return
}
#Loads the MD5 hash records.
proc loadHashes {file} {
#Create the interpeter.
set interp [interp create -safe]
$interp eval [list namespace delete ::]
$interp alias hash loadHashes.hash
#Open the file and read in the data.
set inFile [open $file r]
$interp eval [read $inFile]
close $inFile
interp delete $interp
return
}
proc loadHashes.hash {url hash} {
#Store the hash in the global options array.
set ::options(hash,$url) $hash
return
}
#Saves the hashes for all of the url's.
proc saveHashes {file} {
set outFile [open $file w]
foreach url $::options(url) {
if {[info exists ::options(hash,$url)]} {
puts $outFile [list hash $url $::options(hash,$url)]
}
}
close $outFile
}
#Do the work of parsing RSS feeds, generating and comparing hashes, sending messages.
proc generateMessages {} {
foreach url $::options(url) {
#Retrieve the current hash for the URL.
if {[info exists ::options(hash,$url)]} {
set hash $::options(hash,$url)
} else {
set hash {}
}
#Retrieve the URL.
set token [::http::geturl $url -timeout 2000]
if {[::http::status $token] != "ok"} {
puts "Could not retrieve data for $url"
::http::cleanup $token
continue
}
set data [::http::data $token]
::http::cleanup $token
#Parse the RSS feed.
set channel [::rss::parse $data]
set msgBody {}
#Generate the msg body.
append msgBody "[$channel title] ([$channel link])\n"
append msgBody "[$channel description]\n\n"
foreach item [$channel items] {
append msgBody "----------------------------------------------------------------\n"
append msgBody "[$item title] ([$item link])\n"
append msgBody "\n"
append msgBody "[$item description]\n"
append msgBody "----------------------------------------------------------------\n"
append msgBody "\n"
}
#Generate the new hash.
#I thought it would be more efficient to generate the hash prior to parsing and
#creating the message, but some sites change the comments within their XML data
#to reflect when the feed was generated, like sourforge.net for example,
#so this is a quick and simple fix.
set newHash [::md5::md5 $msgBody]
#If the hashes do not match, then the site has changed,
#so send out the messages.
if {$newHash != $hash} {
#Create the MIME message.
set mime [::mime::initialize -canonical text/plan -string $msgBody]
::mime::setheader $mime Subject "[$channel title] has been updated"
foreach email $::options(email,$url) {
::smtp::sendmessage $mime \
-recipients $email \
-originator "bdkitchen@smcm.edu"
}
#Destroy (deallocate) the MIME message.
::mime::finalize $mime
#Destroy (deallocate) parsed data.
$channel destroy
}
#Store the new hash in the options array.
set ::options(hash,$url) $newHash
}
}
#The main program.
#Locations of the configuration files.
set configFile "rss_config"
set hashFile "rss_hashes"
loadOptions $configFile
if {[file exists $hashFile]} {
loadHashes $hashFile
}
generateMessages
saveHashes $hashFileAnd finally, and example configuration file, rss_config
email noone@nowhere.com {
#Tcl'ers Wiki
rss http://wiki.tcl.tk/rss.xml
#Slashdot
rss http://slashdot.org/index.rss
#Sourceforge
rss http://sourceforge.net/export/rss2_sfnews.php?feed
}
email noone@somewhereelse.com {
#Sourceforge
rss http://sourceforge.net/export/rss2_sfnews.php?feed
}