|
|
@@ -1,1096 +0,0 @@
|
|
|
-# TCL Script to retrieve queries from Quakeservers.net (they come as rss)
|
|
|
-# Copyright (C) 2004 Paul-Dieter Klumpp
|
|
|
-#
|
|
|
-# This program is free software; you can redistribute it and/or
|
|
|
-# modify it under the terms of the GNU General Public License
|
|
|
-# as published by the Free Software Foundation; either version 2
|
|
|
-# of the License, or (at your option) any later version.
|
|
|
-#
|
|
|
-# This program is distributed in the hope that it will be useful,
|
|
|
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
-# GNU General Public License for more details.
|
|
|
-#
|
|
|
-# You should have received a copy of the GNU General Public License
|
|
|
-# along with this program; if not, write to the Free Software
|
|
|
-# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
|
|
-
|
|
|
-
|
|
|
-
|
|
|
-# have a binding to call url
|
|
|
-# if binding called,
|
|
|
-# get url
|
|
|
-# if retrieved data
|
|
|
-# parse retrieved data
|
|
|
-# output to channel where called
|
|
|
-
|
|
|
-namespace eval ::qsnet {
|
|
|
-
|
|
|
- if {[file isfile "scripts/cims/putils.tcl"] == 1} {
|
|
|
- source "scripts/cims/putils.tcl"
|
|
|
- }
|
|
|
-
|
|
|
- bind pub - !qw ::qsnet::feed_get_qw_and_display
|
|
|
-}
|
|
|
-
|
|
|
-namespace eval ::rss-synd {
|
|
|
- variable rss
|
|
|
- variable default
|
|
|
-
|
|
|
- set rss(qservers) {
|
|
|
- "url" "http://www.quakeservers.net/shambler_players.php?n="
|
|
|
- "channels" "#quad.dev"
|
|
|
- "database" "./scripts/feeds/qservers"
|
|
|
- "output" "\[\002!qw fp\002\] @@item!player@@ (@@item!description@@ - qw://@@item!ip@@:@@item!port@@)"
|
|
|
- "interval-or-forced" "forced"
|
|
|
- }
|
|
|
-
|
|
|
- set default {
|
|
|
- "announce-output" 3
|
|
|
- "trigger-output" 3
|
|
|
- "remove-empty" 1
|
|
|
- "trigger-type" 0:2
|
|
|
- "announce-type" 0
|
|
|
- "max-depth" 5
|
|
|
- "evaluate-tcl" 0
|
|
|
- "update-interval" 30
|
|
|
- "output-order" 0
|
|
|
- "timeout" 60000
|
|
|
- "channels" "#channel1"
|
|
|
- "trigger" "!rss @@feedid@@"
|
|
|
- "output" "\[\002@@channel!title@@@@title@@\002\] @@item!title@@@@entry!title@@ - @@item!link@@@@entry!link!=href@@"
|
|
|
- "user-agent" "Mozilla/5.0 (Windows; U; Windows NT 6.1; en-GB; rv:1.9.2.2) Gecko/20100316 Firefox/3.6.2"
|
|
|
- }
|
|
|
-}
|
|
|
-
|
|
|
-
|
|
|
-
|
|
|
-
|
|
|
-proc ::qsnet::feed_get_qw_and_display {nick mask hand chan text} {
|
|
|
-
|
|
|
- # ist im channel erlaubt?
|
|
|
- # ist abfrageintervall eingehalten?
|
|
|
-
|
|
|
- # lese parameter
|
|
|
- # verändere URL entsprechend..
|
|
|
- # verändere channel auf den aufrufenden..
|
|
|
- # dann start feed_get
|
|
|
- putlog "here i am: $nick $mask $hand $chan $text"
|
|
|
-
|
|
|
- #set rss(qservers) {
|
|
|
- # "url" "http://www.quakeservers.net/shambler_players.php?n=$params"
|
|
|
- # "channels" "#quad.dev"
|
|
|
- # "database" "./scripts/feeds/qservers"
|
|
|
- # "output" "\\\[\002qw fp\002\\\] @@item!player@@ (@@item!description@@ - @@item!ip@@:@@item!port@@)"
|
|
|
- # "interval-or-forced" "forced"
|
|
|
- #}
|
|
|
-
|
|
|
- set tmp_cmd [lindex ${text} 0]
|
|
|
- set tmp_value [lindex ${text} 1]
|
|
|
-
|
|
|
- set cmd [string tolower [::putils::kill_spaces ${tmp_cmd}]]
|
|
|
- set value [string tolower [::putils::kill_spaces ${tmp_value}]]
|
|
|
-
|
|
|
-
|
|
|
- if {${cmd} == "fp"} {
|
|
|
-
|
|
|
- # check $value ... if there
|
|
|
- if {${value} != ""} {
|
|
|
- if {[string length ${value}] > "1"} {
|
|
|
- set rofg [::rss-synd::feed_get $value]
|
|
|
- if {$rofg == 666} {
|
|
|
- ::putils::put_local_msg ${chan} "Mnet! Player not found on any qw server."
|
|
|
- }
|
|
|
- } else {
|
|
|
- ::putils::put_local_msg ${chan} "Mnet! Searchvalue has to be longer than 1 character."
|
|
|
- }
|
|
|
- } else {
|
|
|
- ::putils::put_local_msg ${chan} "Mnet! No searchvalue given.."
|
|
|
- }
|
|
|
- return 0
|
|
|
- }
|
|
|
-
|
|
|
- ::putils::put_local_msg ${chan} "Possible !qw commands are:"
|
|
|
- ::putils::put_local_msg ${chan} "'!qw fp xyz' to find a player named xyz"
|
|
|
-
|
|
|
-}
|
|
|
-
|
|
|
-
|
|
|
-
|
|
|
-
|
|
|
-#
|
|
|
-# Feed Retrieving Functions
|
|
|
-##
|
|
|
-
|
|
|
-proc ::rss-synd::feed_get {args} {
|
|
|
- variable rss
|
|
|
-
|
|
|
- set i 0
|
|
|
- foreach name [array names rss] {
|
|
|
- if {$i == 3} { break }
|
|
|
-
|
|
|
- array set feed $rss($name)
|
|
|
- #putlog "currently on $rss($name)"
|
|
|
-
|
|
|
- # PaulK: let it be called, even if quite up2date .. because it's forced.
|
|
|
- if {($feed(updated) <= [expr { [unixtime] - ($feed(update-interval) * 60) }]) || ( $feed(interval-or-forced) == "forced" )} {
|
|
|
-
|
|
|
- ::http::config -useragent $feed(user-agent)
|
|
|
-
|
|
|
- set feed(type) $feed(announce-type)
|
|
|
- set feed(headers) [list]
|
|
|
-
|
|
|
- if {$feed(url-auth) != ""} {
|
|
|
- lappend feed(headers) "Authorization" "Basic $feed(url-auth)"
|
|
|
- }
|
|
|
-
|
|
|
- if {([info exists feed(enable-gzip)]) && ($feed(enable-gzip) == 1)} {
|
|
|
- lappend feed(headers) "Accept-Encoding" "gzip"
|
|
|
- }
|
|
|
-
|
|
|
- set feedlist "[array get feed] depth 0"
|
|
|
-
|
|
|
- # PaulK: with $args
|
|
|
- set http_token [::http::geturl "$feed(url)$args" -timeout $feed(timeout) -headers $feed(headers)]
|
|
|
- # PaulK: finally, we can check here what errors really happened - before, with the callback, it wasn't possible HERE in this procedure. Stupid!
|
|
|
- catch {
|
|
|
- set callback [[namespace current]::feed_callback ${feedlist} ${http_token}]
|
|
|
- } return_of_callback
|
|
|
-
|
|
|
- if {$return_of_callback != ""} {
|
|
|
- putlog "roc: $return_of_callback"
|
|
|
- return $return_of_callback
|
|
|
- }
|
|
|
- ##
|
|
|
-
|
|
|
- set feed(updated) [unixtime]
|
|
|
- set rss($name) [array get feed]
|
|
|
- incr i
|
|
|
- }
|
|
|
-
|
|
|
- unset feed
|
|
|
- }
|
|
|
-}
|
|
|
-
|
|
|
-
|
|
|
-
|
|
|
-proc ::rss-synd::feed_callback {feedlist args} {
|
|
|
- set token [lindex $args end]
|
|
|
-
|
|
|
- array set feed $feedlist
|
|
|
-
|
|
|
- # PaulK: no callback anymore, so we can comment that
|
|
|
- upvar 0 $token state
|
|
|
-
|
|
|
- if {[set status $state(status)] != "ok"} {
|
|
|
- if {$status == "error"} { set status $state(error) }
|
|
|
- putlog "\002RSS HTTP Error\002: $state(url) (State: $status)"
|
|
|
- ::http::cleanup $token
|
|
|
- return 1
|
|
|
- }
|
|
|
-
|
|
|
- array set meta $state(meta)
|
|
|
-
|
|
|
- if {([::http::ncode $token] == 302) || ([::http::ncode $token] == 301)} {
|
|
|
- set feed(depth) [expr {$feed(depth) + 1 }]
|
|
|
-
|
|
|
- if {$feed(depth) < $feed(max-depth)} {
|
|
|
- catch {::http::geturl "$meta(Location)" -command "[namespace current]::feed_callback {$feedlist}" -timeout $feed(timeout) -headers $feed(headers)}
|
|
|
- } else {
|
|
|
- putlog "\002RSS HTTP Error\002: $state(url) (State: timeout, max refer limit reached)"
|
|
|
- }
|
|
|
-
|
|
|
- ::http::cleanup $token
|
|
|
- return 1
|
|
|
- } elseif {[::http::ncode $token] != 200} {
|
|
|
- putlog "\002RSS HTTP Error\002: $state(url) ($state(http))"
|
|
|
- ::http::cleanup $token
|
|
|
- return 1
|
|
|
- }
|
|
|
-
|
|
|
- set data [::http::data $token]
|
|
|
-
|
|
|
- if {[info exists feed(charset)]} {
|
|
|
- set data [encoding convertto [string tolower $feed(charset)] $data]
|
|
|
- }
|
|
|
-
|
|
|
- if {([info exists meta(Content-Encoding)]) && \
|
|
|
- ([string equal $meta(Content-Encoding) "gzip"])} {
|
|
|
- if {[catch {[namespace current]::feed_gzip $data} data] != 0} {
|
|
|
- putlog "\002RSS Error\002: Unable to decompress \"$state(url)\": $data"
|
|
|
- ::http::cleanup $token
|
|
|
- return 1
|
|
|
- }
|
|
|
- }
|
|
|
-
|
|
|
- if {[catch {[namespace current]::xml_list_create $data} data] != 0} {
|
|
|
- putlog "\002RSS Error\002: Unable to parse feed properly, parser returned error. \"$state(url)\""
|
|
|
- ::http::cleanup $token
|
|
|
- return 1
|
|
|
- }
|
|
|
-
|
|
|
- if {[string length $data] == 0} {
|
|
|
- putlog "\002RSS Error\002: Unable to parse feed properly, no data returned. \"$state(url)\""
|
|
|
- ::http::cleanup $token
|
|
|
- return 666
|
|
|
- }
|
|
|
-
|
|
|
- set odata ""
|
|
|
- if {[catch {set odata [[namespace current]::feed_read]} error] != 0} {
|
|
|
- putlog "\002RSS Warning\002: $error."
|
|
|
- }
|
|
|
-
|
|
|
- if {![[namespace current]::feed_info $data]} {
|
|
|
- putlog "\002RSS Error\002: Invalid feed format ($state(url))!"
|
|
|
- ::http::cleanup $token
|
|
|
- return 1
|
|
|
- }
|
|
|
-
|
|
|
- ::http::cleanup $token
|
|
|
-
|
|
|
- if {[catch {[namespace current]::feed_write $data} error] != 0} {
|
|
|
- putlog "\002RSS Database Error\002: $error."
|
|
|
- return 1
|
|
|
- }
|
|
|
-
|
|
|
- if {$feed(announce-output) > 0} {
|
|
|
- [namespace current]::feed_output $data
|
|
|
- }
|
|
|
-}
|
|
|
-
|
|
|
-
|
|
|
-
|
|
|
-
|
|
|
-#
|
|
|
-#
|
|
|
-##
|
|
|
-
|
|
|
-
|
|
|
-proc ::rss-synd::init {args} {
|
|
|
- variable rss
|
|
|
- variable default
|
|
|
- variable version
|
|
|
- variable packages
|
|
|
-
|
|
|
- set version(number) "0.5"
|
|
|
- set version(date) "2011-01-05"
|
|
|
-
|
|
|
- package require http
|
|
|
- set packages(base64) [catch {package require base64}]; # http auth
|
|
|
- set packages(tls) [catch {package require tls}]; # https
|
|
|
- set packages(trf) [catch {package require Trf}]; # gzip compression
|
|
|
-
|
|
|
- foreach feed [array names rss] {
|
|
|
- array set tmp $default
|
|
|
- array set tmp $rss($feed)
|
|
|
-
|
|
|
- set required [list "announce-output" "trigger-output" "max-depth" "update-interval" "timeout" "channels" "output" "user-agent" "url" "database" "trigger-type" "announce-type"]
|
|
|
- foreach {key value} [array get tmp] {
|
|
|
- if {[set ptr [lsearch -exact $required $key]] >= 0} {
|
|
|
- set required [lreplace $required $ptr $ptr]
|
|
|
- }
|
|
|
- }
|
|
|
-
|
|
|
- if {[llength $required] == 0} {
|
|
|
- regsub -nocase -all -- {@@feedid@@} $tmp(trigger) $feed tmp(trigger)
|
|
|
-
|
|
|
- set ulist [regexp -nocase -inline -- {(http(?:s?))://(?:(.[^:]+:.[^@]+)?)(?:@?)(.*)} $tmp(url)]
|
|
|
-
|
|
|
- if {[llength $ulist] == 0} {
|
|
|
- putlog "\002RSS Error\002: Unable to parse URL, Invalid format for feed \"$feed\"."
|
|
|
- unset rss($feed)
|
|
|
- continue
|
|
|
- }
|
|
|
-
|
|
|
- set tmp(url) "[lindex $ulist 1]://[lindex $ulist 3]"
|
|
|
-
|
|
|
- if {[lindex $ulist 1] == "https"} {
|
|
|
- if {$packages(tls) != 0} {
|
|
|
- putlog "\002RSS Error\002: Unable to find tls package required for https, unloaded feed \"$feed\"."
|
|
|
- unset rss($feed)
|
|
|
- continue
|
|
|
- }
|
|
|
-
|
|
|
- ::http::register https 443 ::tls::socket
|
|
|
- }
|
|
|
-
|
|
|
- if {(![info exists tmp(url-auth)]) || ($tmp(url-auth) == "")} {
|
|
|
- set tmp(url-auth) ""
|
|
|
-
|
|
|
- if {[lindex $ulist 2] != ""} {
|
|
|
- if {$packages(base64) != 0} {
|
|
|
- putlog "\002RSS Error\002: Unable to find base64 package required for http authentication, unloaded feed \"$feed\"."
|
|
|
- unset rss($feed)
|
|
|
- continue
|
|
|
- }
|
|
|
-
|
|
|
- set tmp(url-auth) [::base64::encode [lindex $ulist 2]]
|
|
|
- }
|
|
|
- }
|
|
|
-
|
|
|
- if {[regexp {^[0123]{1}:[0123]{1}$} $tmp(trigger-type)] != 1} {
|
|
|
- putlog "\002RSS Error\002: Invalid 'trigger-type' syntax for feed \"$feed\"."
|
|
|
- unset rss($feed)
|
|
|
- continue
|
|
|
- }
|
|
|
-
|
|
|
- set tmp(trigger-type) [split $tmp(trigger-type) ":"]
|
|
|
-
|
|
|
- if {([info exists tmp(charset)]) && ([lsearch -exact [encoding names] [string tolower $tmp(charset)]] < 0)} {
|
|
|
- putlog "\002RSS Error\002: Unable to load feed \"$feed\", unknown encoding \"$tmp(encoding)\"."
|
|
|
- unset rss($feed)
|
|
|
- continue
|
|
|
- }
|
|
|
-
|
|
|
- set tmp(updated) 0
|
|
|
- if {([file exists $tmp(database)]) && ([set mtime [file mtime $tmp(database)]] < [unixtime])} {
|
|
|
- set tmp(updated) [file mtime $tmp(database)]
|
|
|
- }
|
|
|
-
|
|
|
- set rss($feed) [array get tmp]
|
|
|
- } else {
|
|
|
- putlog "\002RSS Error\002: Unable to load feed \"$feed\", missing one or more required settings. \"[join $required ", "]\""
|
|
|
- unset rss($feed)
|
|
|
- }
|
|
|
-
|
|
|
- unset tmp
|
|
|
- }
|
|
|
-
|
|
|
- bind evnt -|- prerehash [namespace current]::deinit
|
|
|
- #bind time -|- {* * * * *} [namespace current]::feed_get
|
|
|
- bind pubm -|- {* *} [namespace current]::trigger
|
|
|
- bind msgm -|- {*} [namespace current]::trigger
|
|
|
-
|
|
|
- putlog "\002RSS Syndication Script v$version(number)\002 ($version(date)): Loaded."
|
|
|
-}
|
|
|
-
|
|
|
-proc ::rss-synd::deinit {args} {
|
|
|
- catch {unbind evnt -|- prerehash [namespace current]::deinit}
|
|
|
- catch {unbind time -|- {* * * * *} [namespace current]::feed_get}
|
|
|
- catch {unbind pub - !qw [namespace current]::feed_get_qw_and_display}
|
|
|
- catch {unbind pubm -|- {* *} [namespace current]::trigger}
|
|
|
- catch {unbind msgm -|- {*} [namespace current]::trigger}
|
|
|
-
|
|
|
- foreach child [namespace children] {
|
|
|
- catch {[set child]::deinit}
|
|
|
- }
|
|
|
-
|
|
|
- namespace delete [namespace current]
|
|
|
-}
|
|
|
-
|
|
|
-#
|
|
|
-# Trigger Function
|
|
|
-##
|
|
|
-
|
|
|
-proc ::rss-synd::trigger {nick user handle args} {
|
|
|
- variable rss
|
|
|
- variable default
|
|
|
-
|
|
|
- set i 0
|
|
|
- set chan ""
|
|
|
- if {[llength $args] == 2} {
|
|
|
- set chan [lindex $args 0]
|
|
|
- incr i
|
|
|
- }
|
|
|
- set text [lindex $args $i]
|
|
|
-
|
|
|
- array set tmp $default
|
|
|
-
|
|
|
- if {[info exists tmp(trigger)]} {
|
|
|
- regsub -all -- {@@(.*?)@@} $tmp(trigger) "" tmp_trigger
|
|
|
- set tmp_trigger [string trimright $tmp_trigger]
|
|
|
-
|
|
|
- if {[string equal -nocase $text $tmp_trigger]} {
|
|
|
- set list_feeds [list]
|
|
|
- }
|
|
|
- }
|
|
|
-
|
|
|
- unset -nocomplain tmp tmp_trigger
|
|
|
-
|
|
|
- foreach name [array names rss] {
|
|
|
- array set feed $rss($name)
|
|
|
-
|
|
|
- if {(![info exists list_feeds]) && \
|
|
|
- ([string equal -nocase $text $feed(trigger)])} {
|
|
|
- if {(![[namespace current]::check_channel $feed(channels) $chan]) && \
|
|
|
- ([string length $chan] != 0)} {
|
|
|
- continue
|
|
|
- }
|
|
|
-
|
|
|
- set feed(nick) $nick
|
|
|
-
|
|
|
- if {$chan != ""} {
|
|
|
- set feed(type) [lindex $feed(trigger-type) 0]
|
|
|
- set feed(channels) $chan
|
|
|
- } else {
|
|
|
- set feed(type) [lindex $feed(trigger-type) 1]
|
|
|
- set feed(channels) ""
|
|
|
- }
|
|
|
-
|
|
|
- if {[catch {set data [[namespace current]::feed_read]} error] == 0} {
|
|
|
- if {![[namespace current]::feed_info $data]} {
|
|
|
- putlog "\002RSS Error\002: Invalid feed database file format ($feed(database))!"
|
|
|
- return
|
|
|
- }
|
|
|
-
|
|
|
- if {$feed(trigger-output) > 0} {
|
|
|
- set feed(announce-output) $feed(trigger-output)
|
|
|
-
|
|
|
- [namespace current]::feed_output $data
|
|
|
- }
|
|
|
- } else {
|
|
|
- putlog "\002RSS Warning\002: $error."
|
|
|
- }
|
|
|
- } elseif {[info exists list_feeds]} {
|
|
|
- if {$chan != ""} {
|
|
|
- # triggered from a channel
|
|
|
- if {[[namespace current]::check_channel $feed(channels) $chan]} {
|
|
|
- lappend list_feeds $feed(trigger)
|
|
|
- }
|
|
|
- } else {
|
|
|
- # triggered from a privmsg
|
|
|
- foreach tmp_chan $feed(channels) {
|
|
|
- if {([catch {botonchan $tmp_chan}] == 0) && \
|
|
|
- ([onchan $nick $tmp_chan])} {
|
|
|
- lappend list_feeds $feed(trigger)
|
|
|
- continue
|
|
|
- }
|
|
|
- }
|
|
|
- }
|
|
|
- }
|
|
|
- }
|
|
|
-
|
|
|
- if {[info exists list_feeds]} {
|
|
|
- if {[llength $list_feeds] == 0} {
|
|
|
- lappend list_feeds "None"
|
|
|
- }
|
|
|
-
|
|
|
- lappend list_msgs "Available feeds: [join $list_feeds ", "]."
|
|
|
-
|
|
|
- if {$chan != ""} {
|
|
|
- set list_type [lindex $feed(trigger-type) 0]
|
|
|
- set list_targets $chan
|
|
|
- } else {
|
|
|
- set list_type [lindex $feed(trigger-type) 1]
|
|
|
- set list_targets ""
|
|
|
- }
|
|
|
-
|
|
|
- [namespace current]::feed_msg $list_type $list_msgs list_targets $nick
|
|
|
- }
|
|
|
-}
|
|
|
-
|
|
|
-
|
|
|
-proc ::rss-synd::feed_info {data {target "feed"}} {
|
|
|
- upvar 1 $target feed
|
|
|
- set length [[namespace current]::xml_get_info $data [list -1 "*"]]
|
|
|
-
|
|
|
- for {set i 0} {$i < $length} {incr i} {
|
|
|
- set type [[namespace current]::xml_get_info $data [list $i "*"] "name"]
|
|
|
-
|
|
|
- # tag-name: the name of the element that contains each article and its data
|
|
|
- # tag-list: the position in the xml structure where all 'tag-name' reside
|
|
|
- switch [string tolower $type] {
|
|
|
- rss {
|
|
|
- # RSS v0.9x & x2.0
|
|
|
- set feed(tag-list) [list 0 "channel"]
|
|
|
- set feed(tag-name) "item"
|
|
|
- break
|
|
|
- }
|
|
|
- rdf:rdf {
|
|
|
- # RSS v1.0
|
|
|
- set feed(tag-list) [list]
|
|
|
- set feed(tag-name) "item"
|
|
|
- break
|
|
|
- }
|
|
|
- feed {
|
|
|
- # ATOM
|
|
|
- set feed(tag-list) [list]
|
|
|
- set feed(tag-name) "entry"
|
|
|
- break
|
|
|
- }
|
|
|
- }
|
|
|
- }
|
|
|
-
|
|
|
- if {![info exists feed(tag-list)]} {
|
|
|
- return 0
|
|
|
- }
|
|
|
-
|
|
|
- set feed(tag-feed) [list 0 $type]
|
|
|
-
|
|
|
- return 1
|
|
|
-}
|
|
|
-
|
|
|
-# decompress gzip formatted data
|
|
|
-proc ::rss-synd::feed_gzip {cdata} {
|
|
|
- variable packages
|
|
|
-
|
|
|
- if {(![info exists packages(trf)]) || \
|
|
|
- ($packages(trf) != 0)} {
|
|
|
- error "Trf package not found."
|
|
|
- }
|
|
|
-
|
|
|
- # remove the 10 byte gzip header and 8 byte footer
|
|
|
- set cdata [string range $cdata 10 [expr { [string length $cdata] - 9 } ]]
|
|
|
-
|
|
|
- # decompress the raw data
|
|
|
- if {[catch {zip -mode decompress -nowrap 1 $cdata} data] != 0} {
|
|
|
- error $data
|
|
|
- }
|
|
|
-
|
|
|
- return $data
|
|
|
-}
|
|
|
-
|
|
|
-proc ::rss-synd::feed_read { } {
|
|
|
- upvar 1 feed feed
|
|
|
-
|
|
|
- if {[catch {open $feed(database) "r"} fp] != 0} {
|
|
|
- error $fp
|
|
|
- }
|
|
|
-
|
|
|
- set data [read -nonewline $fp]
|
|
|
-
|
|
|
- close $fp
|
|
|
-
|
|
|
- return $data
|
|
|
-}
|
|
|
-
|
|
|
-proc ::rss-synd::feed_write {data} {
|
|
|
- upvar 1 feed feed
|
|
|
-
|
|
|
- if {[catch {open $feed(database) "w+"} fp] != 0} {
|
|
|
- error $fp
|
|
|
- }
|
|
|
-
|
|
|
- set data [string map { "\n" "" "\r" "" } $data]
|
|
|
-
|
|
|
- puts -nonewline $fp $data
|
|
|
-
|
|
|
- close $fp
|
|
|
-}
|
|
|
-
|
|
|
-#
|
|
|
-# XML Functions
|
|
|
-##
|
|
|
-
|
|
|
-proc ::rss-synd::xml_list_create {xml_data} {
|
|
|
- set xml_list [list]
|
|
|
- set ns_current [namespace current]
|
|
|
-
|
|
|
- set ptr 0
|
|
|
- while {[set tag_start [${ns_current}::xml_get_position $xml_data $ptr]] != ""} {
|
|
|
- set tag_start_first [lindex $tag_start 0]
|
|
|
- set tag_start_last [lindex $tag_start 1]
|
|
|
-
|
|
|
- set tag_string [string range $xml_data $tag_start_first $tag_start_last]
|
|
|
-
|
|
|
- # move the pointer to the next character after the current tag
|
|
|
- set last_ptr $ptr
|
|
|
- set ptr [expr { $tag_start_last + 2 }]
|
|
|
-
|
|
|
- array set tag [list]
|
|
|
- # match 'special' tags that dont close
|
|
|
- if {[regexp -nocase -- {^!(\[CDATA|--|DOCTYPE)} $tag_string]} {
|
|
|
- set tag_data $tag_string
|
|
|
-
|
|
|
- regexp -nocase -- {^!\[CDATA\[(.*?)\]\]$} $tag_string -> tag_data
|
|
|
- regexp -nocase -- {^!--(.*?)--$} $tag_string -> tag_data
|
|
|
-
|
|
|
- if {[info exists tag_data]} {
|
|
|
- set tag(data) [${ns_current}::xml_escape $tag_data]
|
|
|
- }
|
|
|
- } else {
|
|
|
- # we should only ever encounter opening tags, if we hit a closing one somethings wrong
|
|
|
- if {[string match {[/]*} $tag_string]} {
|
|
|
- putlog "\002RSS Malformed Feed\002: Tag not open: \"<$tag_string>\" ($tag_start_first => $tag_start_last)"
|
|
|
- continue
|
|
|
- }
|
|
|
-
|
|
|
- # split up the tag name and attributes
|
|
|
- regexp -- {(.[^ \/\n\r]*)(?: |\n|\r\n|\r|)(.*?)$} $tag_string -> tag_name tag_args
|
|
|
- set tag(name) [${ns_current}::xml_escape $tag_name]
|
|
|
-
|
|
|
- # split up all of the tags attributes
|
|
|
- set tag(attrib) [list]
|
|
|
- if {[string length $tag_args] > 0} {
|
|
|
- set values [regexp -inline -all -- {(?:\s*|)(.[^=]*)=["'](.[^"']*)["']} $tag_args]
|
|
|
-
|
|
|
- foreach {r_match r_tag r_value} $values {
|
|
|
- lappend tag(attrib) [${ns_current}::xml_escape $r_tag] [${ns_current}::xml_escape $r_value]
|
|
|
- }
|
|
|
- }
|
|
|
-
|
|
|
- # find the end tag of non-self-closing tags
|
|
|
- if {(![regexp {(\?|!|/)(\s*)$} $tag_args]) || \
|
|
|
- (![string match "\?*" $tag_string])} {
|
|
|
- set tmp_num 1
|
|
|
- set tag_success 0
|
|
|
- set tag_end_last $ptr
|
|
|
-
|
|
|
- # find the correct closing tag if there are nested elements
|
|
|
- # with the same name
|
|
|
- while {$tmp_num > 0} {
|
|
|
- # search for a possible closing tag
|
|
|
- set tag_success [regexp -indices -start $tag_end_last -- "</$tag_name>" $xml_data tag_end]
|
|
|
-
|
|
|
- set last_tag_end_last $tag_end_last
|
|
|
-
|
|
|
- set tag_end_first [lindex $tag_end 0]
|
|
|
- set tag_end_last [lindex $tag_end 1]
|
|
|
-
|
|
|
- # check to see if there are any NEW opening tags within the
|
|
|
- # previous closing tag and the new closing one
|
|
|
- incr tmp_num [regexp -all -- "<$tag_name\(\[\\s\\t\\n\\r\]+\(\[^/>\]*\)?\)?>" [string range $xml_data $last_tag_end_last $tag_end_last]]
|
|
|
-
|
|
|
- incr tmp_num -1
|
|
|
- }
|
|
|
-
|
|
|
- if {$tag_success == 0} {
|
|
|
- putlog "\002RSS Malformed Feed\002: Tag not closed: \"<$tag_name>\""
|
|
|
- return
|
|
|
- }
|
|
|
-
|
|
|
- # set the pointer to after the last closing tag
|
|
|
- set ptr [expr { $tag_end_last + 1 }]
|
|
|
-
|
|
|
- # remember tag_start*'s character index doesnt include the tag start and end characters
|
|
|
- set xml_sub_data [string range $xml_data [expr { $tag_start_last + 2 }] [expr { $tag_end_first - 1 }]]
|
|
|
-
|
|
|
- # recurse the data within the currently open tag
|
|
|
- set result [${ns_current}::xml_list_create $xml_sub_data]
|
|
|
-
|
|
|
- # set the list data returned from the recursion we just performed
|
|
|
- if {[llength $result] > 0} {
|
|
|
- set tag(children) $result
|
|
|
-
|
|
|
- # set the current data we have because we're already at the end of a branch
|
|
|
- # (ie: the recursion didnt return any data)
|
|
|
- } else {
|
|
|
- set tag(data) [${ns_current}::xml_escape $xml_sub_data]
|
|
|
- }
|
|
|
- }
|
|
|
- }
|
|
|
-
|
|
|
- # insert any plain data that appears before the current element
|
|
|
- if {$last_ptr != [expr { $tag_start_first - 1 }]} {
|
|
|
- lappend xml_list [list "data" [${ns_current}::xml_escape [string range $xml_data $last_ptr [expr { $tag_start_first - 2 }]]]]
|
|
|
- }
|
|
|
-
|
|
|
- # inset tag data
|
|
|
- lappend xml_list [array get tag]
|
|
|
-
|
|
|
- unset tag
|
|
|
- }
|
|
|
-
|
|
|
- # if there is still plain data left add it
|
|
|
- if {$ptr < [string length $xml_data]} {
|
|
|
- lappend xml_list [list "data" [${ns_current}::xml_escape [string range $xml_data $ptr end]]]
|
|
|
- }
|
|
|
-
|
|
|
- return $xml_list
|
|
|
-}
|
|
|
-
|
|
|
-# simple escape function
|
|
|
-proc ::rss-synd::xml_escape {string} {
|
|
|
- regsub -all -- {([\{\}])} $string {\\\1} string
|
|
|
-
|
|
|
- return $string
|
|
|
-}
|
|
|
-
|
|
|
-# this function is to replace:
|
|
|
-# regexp -indices -start $ptr {<(!\[CDATA\[.+?\]\]|!--.+?--|!DOCTYPE.+?|.+?)>} $xml_data -> tag_start
|
|
|
-# which doesnt work correctly with tcl's re_syntax
|
|
|
-proc ::rss-synd::xml_get_position {xml_data ptr} {
|
|
|
- set tag_start [list -1 -1]
|
|
|
-
|
|
|
- regexp -indices -start $ptr {<(.+?)>} $xml_data -> tmp(tag)
|
|
|
- regexp -indices -start $ptr {<(!--.*?--)>} $xml_data -> tmp(comment)
|
|
|
- regexp -indices -start $ptr {<(!DOCTYPE.+?)>} $xml_data -> tmp(doctype)
|
|
|
- regexp -indices -start $ptr {<(!\[CDATA\[.+?\]\])>} $xml_data -> tmp(cdata)
|
|
|
-
|
|
|
- # 'tag' regexp should be compared last
|
|
|
- foreach name [lsort [array names tmp]] {
|
|
|
- set tmp_s [split $tmp($name)]
|
|
|
- if {( ([lindex $tmp_s 0] < [lindex $tag_start 0]) && \
|
|
|
- ([lindex $tmp_s 0] > -1) ) || \
|
|
|
- ([lindex $tag_start 0] == -1)} {
|
|
|
- set tag_start $tmp($name)
|
|
|
- }
|
|
|
- }
|
|
|
-
|
|
|
- if {([lindex $tag_start 0] == -1) || \
|
|
|
- ([lindex $tag_start 1] == -1)} {
|
|
|
- set tag_start ""
|
|
|
- }
|
|
|
-
|
|
|
- return $tag_start
|
|
|
-}
|
|
|
-
|
|
|
-# recursivly flatten all data without tags or attributes
|
|
|
-proc ::rss-synd::xml_list_flatten {xml_list {level 0}} {
|
|
|
- set xml_string ""
|
|
|
-
|
|
|
- foreach e_list $xml_list {
|
|
|
- if {[catch {array set e_array $e_list}] != 0} {
|
|
|
- return $xml_list
|
|
|
- }
|
|
|
-
|
|
|
- if {[info exists e_array(children)]} {
|
|
|
- append xml_string [[namespace current]::xml_list_flatten $e_array(children) [expr { $level + 1 }]]
|
|
|
- } elseif {[info exists e_array(data)]} {
|
|
|
- append xml_string $e_array(data)
|
|
|
- }
|
|
|
-
|
|
|
- unset e_array
|
|
|
- }
|
|
|
-
|
|
|
- return $xml_string
|
|
|
-}
|
|
|
-
|
|
|
-# returns information on a data structure when given a path.
|
|
|
-# paths can be specified using: [struct number] [struct name] <...>
|
|
|
-proc ::rss-synd::xml_get_info {xml_list path {element "data"}} {
|
|
|
- set i 0
|
|
|
-
|
|
|
- foreach {t_data} $xml_list {
|
|
|
- array set t_array $t_data
|
|
|
-
|
|
|
- # if the name doesnt exist set it so we can still reference the data
|
|
|
- # using the 'stuct name' *
|
|
|
- if {![info exists t_array(name)]} {
|
|
|
- set t_array(name) ""
|
|
|
- }
|
|
|
-
|
|
|
- if {[string match -nocase [lindex $path 1] $t_array(name)]} {
|
|
|
-
|
|
|
- if {$i == [lindex $path 0]} {
|
|
|
- set result ""
|
|
|
-
|
|
|
- if {([llength $path] == 2) && \
|
|
|
- ([info exists t_array($element)])} {
|
|
|
- set result $t_array($element)
|
|
|
- } elseif {[info exists t_array(children)]} {
|
|
|
- # shift the first path reference of the front of the path and recurse
|
|
|
- set result [[namespace current]::xml_get_info $t_array(children) [lreplace $path 0 1] $element]
|
|
|
- }
|
|
|
-
|
|
|
- return $result
|
|
|
- }
|
|
|
-
|
|
|
- incr i
|
|
|
- }
|
|
|
-
|
|
|
- unset t_array
|
|
|
- }
|
|
|
-
|
|
|
- if {[lindex $path 0] == -1} {
|
|
|
- return $i
|
|
|
- }
|
|
|
-}
|
|
|
-
|
|
|
-# converts 'args' into a list in the same order
|
|
|
-proc ::rss-synd::xml_join_tags {args} {
|
|
|
- set list [list]
|
|
|
-
|
|
|
- foreach tag $args {
|
|
|
- foreach item $tag {
|
|
|
- if {[string length $item] > 0} {
|
|
|
- lappend list $item
|
|
|
- }
|
|
|
- }
|
|
|
- }
|
|
|
-
|
|
|
- return $list
|
|
|
-}
|
|
|
-
|
|
|
-#
|
|
|
-# Output Feed Functions
|
|
|
-##
|
|
|
-
|
|
|
-proc ::rss-synd::feed_output {data {odata ""}} {
|
|
|
- upvar 1 feed feed
|
|
|
- set msgs [list]
|
|
|
-
|
|
|
- set path [[namespace current]::xml_join_tags $feed(tag-feed) $feed(tag-list) -1 $feed(tag-name)]
|
|
|
- set count [[namespace current]::xml_get_info $data $path]
|
|
|
-
|
|
|
- for {set i 0} {($i < $count) && ($i < $feed(announce-output))} {incr i} {
|
|
|
- set tmpp [[namespace current]::xml_join_tags $feed(tag-feed) $feed(tag-list) $i $feed(tag-name)]
|
|
|
- set tmpd [[namespace current]::xml_get_info $data $tmpp "children"]
|
|
|
-
|
|
|
- if {[[namespace current]::feed_compare $odata $tmpd]} {
|
|
|
- break
|
|
|
- }
|
|
|
-
|
|
|
- set tmp_msg [[namespace current]::cookie_parse $data $i]
|
|
|
- if {(![info exists feed(output-order)]) || \
|
|
|
- ($feed(output-order) == 0)} {
|
|
|
- set msgs [linsert $msgs 0 $tmp_msg]
|
|
|
- } else {
|
|
|
- lappend msgs $tmp_msg
|
|
|
- }
|
|
|
- }
|
|
|
-
|
|
|
- set nick [expr {[info exists feed(nick)] ? $feed(nick) : ""}]
|
|
|
-
|
|
|
- [namespace current]::feed_msg $feed(type) $msgs $feed(channels) $nick
|
|
|
-}
|
|
|
-
|
|
|
-proc ::rss-synd::feed_msg {type msgs targets {nick ""}} {
|
|
|
- # check if our target is a nick
|
|
|
- if {(($nick != "") && \
|
|
|
- ($targets == "")) || \
|
|
|
- ([regexp -- {[23]} $type])} {
|
|
|
- set targets $nick
|
|
|
- }
|
|
|
-
|
|
|
- foreach msg $msgs {
|
|
|
- foreach chan $targets {
|
|
|
- if {([catch {botonchan $chan}] == 0) || \
|
|
|
- ([regexp -- {^[#&]} $chan] == 0)} {
|
|
|
- foreach line [split $msg "\n"] {
|
|
|
- if {($type == 1) || ($type == 3)} {
|
|
|
- putserv "NOTICE $chan :$line"
|
|
|
- } else {
|
|
|
- putserv "PRIVMSG $chan :$line"
|
|
|
- }
|
|
|
- }
|
|
|
- }
|
|
|
- }
|
|
|
- }
|
|
|
-}
|
|
|
-
|
|
|
-proc ::rss-synd::feed_compare {odata data} {
|
|
|
- if {$odata == ""} {
|
|
|
- return 0
|
|
|
- }
|
|
|
-
|
|
|
- upvar 1 feed feed
|
|
|
- array set ofeed [list]
|
|
|
- [namespace current]::feed_info $odata "ofeed"
|
|
|
-
|
|
|
- if {[array size ofeed] == 0} {
|
|
|
- putlog "\002RSS Error\002: Invalid feed format ($feed(database))!"
|
|
|
- return 0
|
|
|
- }
|
|
|
-
|
|
|
- if {[string equal -nocase [lindex $feed(tag-feed) 1] "feed"]} {
|
|
|
- set cmp_items [list {0 "id"} "children" "" 3 {0 "link"} "attrib" "href" 2 {0 "title"} "children" "" 1]
|
|
|
- } else {
|
|
|
- set cmp_items [list {0 "guid"} "children" "" 3 {0 "link"} "children" "" 2 {0 "title"} "children" "" 1]
|
|
|
- }
|
|
|
-
|
|
|
- set path [[namespace current]::xml_join_tags $ofeed(tag-feed) $ofeed(tag-list) -1 $ofeed(tag-name)]
|
|
|
- set count [[namespace current]::xml_get_info $odata $path]
|
|
|
-
|
|
|
- for {set i 0} {$i < $count} {incr i} {
|
|
|
- # extract the current article from the database
|
|
|
- set tmpp [[namespace current]::xml_join_tags $ofeed(tag-feed) $ofeed(tag-list) $i $ofeed(tag-name)]
|
|
|
- set tmpd [[namespace current]::xml_get_info $odata $tmpp "children"]
|
|
|
-
|
|
|
- set w 0; # weight value
|
|
|
- set m 0; # item tag matches
|
|
|
- foreach {cmp_path cmp_element cmp_attrib cmp_weight} $cmp_items {
|
|
|
- # try and extract the tag info from the current article
|
|
|
- set oresult [[namespace current]::xml_get_info $tmpd $cmp_path $cmp_element]
|
|
|
- if {$cmp_element == "attrib"} {
|
|
|
- array set tmp $oresult
|
|
|
- catch {set oresult $tmp($cmp_attrib)}
|
|
|
- unset tmp
|
|
|
- }
|
|
|
-
|
|
|
- # if the tag doesnt exist in the article ignore it
|
|
|
- if {$oresult == ""} { continue }
|
|
|
-
|
|
|
- incr m
|
|
|
-
|
|
|
- # extract the tag info from the current article
|
|
|
- set result [[namespace current]::xml_get_info $data $cmp_path $cmp_element]
|
|
|
- if {$cmp_element == "attrib"} {
|
|
|
- array set tmp $result
|
|
|
- catch {set result $tmp($cmp_attrib)}
|
|
|
- unset tmp
|
|
|
- }
|
|
|
-
|
|
|
- if {[string equal -nocase $oresult $result]} {
|
|
|
- set w [expr { $w + $cmp_weight }]
|
|
|
- }
|
|
|
- }
|
|
|
-
|
|
|
- # value of 100 or more means its a match
|
|
|
- if {($m > 0) && \
|
|
|
- ([expr { round(double($w) / double($m) * 100) }] >= 100)} {
|
|
|
- return 1
|
|
|
- }
|
|
|
- }
|
|
|
-
|
|
|
- return 0
|
|
|
-}
|
|
|
-
|
|
|
-#
|
|
|
-# Cookie Parsing Functions
|
|
|
-##
|
|
|
-
|
|
|
-proc ::rss-synd::cookie_parse {data current} {
|
|
|
- upvar 1 feed feed
|
|
|
- set output $feed(output)
|
|
|
-
|
|
|
- set eval 0
|
|
|
- if {([info exists feed(evaluate-tcl)]) && ($feed(evaluate-tcl) == 1)} { set eval 1 }
|
|
|
-
|
|
|
- set matches [regexp -inline -nocase -all -- {@@(.*?)@@} $output]
|
|
|
- foreach {match tmpc} $matches {
|
|
|
- set tmpc [split $tmpc "!"]
|
|
|
- set index 0
|
|
|
-
|
|
|
- set cookie [list]
|
|
|
- foreach piece $tmpc {
|
|
|
- set tmpp [regexp -nocase -inline -all -- {^(.*?)\((.*?)\)|(.*?)$} $piece]
|
|
|
-
|
|
|
- if {[lindex $tmpp 3] == ""} {
|
|
|
- lappend cookie [lindex $tmpp 2] [lindex $tmpp 1]
|
|
|
- } else {
|
|
|
- lappend cookie 0 [lindex $tmpp 3]
|
|
|
- }
|
|
|
- }
|
|
|
-
|
|
|
- # replace tag-item's index with the current article
|
|
|
- if {[string equal -nocase $feed(tag-name) [lindex $cookie 1]]} {
|
|
|
- set cookie [[namespace current]::xml_join_tags $feed(tag-list) [lreplace $cookie $index $index $current]]
|
|
|
- }
|
|
|
-
|
|
|
- set cookie [[namespace current]::xml_join_tags $feed(tag-feed) $cookie]
|
|
|
-
|
|
|
- if {[set tmp [[namespace current]::cookie_replace $cookie $data]] != ""} {
|
|
|
- set tmp [[namespace current]::xml_list_flatten $tmp]
|
|
|
-
|
|
|
- regsub -all -- {([\"\$\[\]\{\}\(\)\\])} $match {\\\1} match
|
|
|
- regsub -- $match $output "[string map { "&" "\\\x26" } [[namespace current]::html_decode $eval $tmp]]" output
|
|
|
- }
|
|
|
- }
|
|
|
-
|
|
|
- # remove empty cookies
|
|
|
- if {(![info exists feed(remove-empty)]) || ($feed(remove-empty) == 1)} {
|
|
|
- regsub -nocase -all -- "@@.*?@@" $output "" output
|
|
|
- }
|
|
|
-
|
|
|
- # evaluate tcl code
|
|
|
- if {$eval == 1} {
|
|
|
- if {[catch {set output [subst $output]} error] != 0} {
|
|
|
- putlog "\002RSS Eval Error\002: $error"
|
|
|
- }
|
|
|
- }
|
|
|
-
|
|
|
- return $output
|
|
|
-}
|
|
|
-
|
|
|
-proc ::rss-synd::cookie_replace {cookie data} {
|
|
|
- set element "children"
|
|
|
-
|
|
|
- set tags [list]
|
|
|
- foreach {num section} $cookie {
|
|
|
- if {[string equal "=" [string range $section 0 0]]} {
|
|
|
- set attrib [string range $section 1 end]
|
|
|
- set element "attrib"
|
|
|
- break
|
|
|
- } else {
|
|
|
- lappend tags $num $section
|
|
|
- }
|
|
|
- }
|
|
|
-
|
|
|
- set return [[namespace current]::xml_get_info $data $tags $element]
|
|
|
-
|
|
|
- if {[string equal -nocase "attrib" $element]} {
|
|
|
- array set tmp $return
|
|
|
-
|
|
|
- if {[catch {set return $tmp($attrib)}] != 0} {
|
|
|
- return
|
|
|
- }
|
|
|
- }
|
|
|
-
|
|
|
- return $return
|
|
|
-}
|
|
|
-
|
|
|
-#
|
|
|
-# Misc Functions
|
|
|
-##
|
|
|
-
|
|
|
-proc ::rss-synd::html_decode {eval data {loop 0}} {
|
|
|
- array set chars {
|
|
|
- nbsp \x20 amp \x26 quot \x22 lt \x3C
|
|
|
- gt \x3E iexcl \xA1 cent \xA2 pound \xA3
|
|
|
- curren \xA4 yen \xA5 brvbar \xA6 brkbar \xA6
|
|
|
- sect \xA7 uml \xA8 die \xA8 copy \xA9
|
|
|
- ordf \xAA laquo \xAB not \xAC shy \xAD
|
|
|
- reg \xAE hibar \xAF macr \xAF deg \xB0
|
|
|
- plusmn \xB1 sup2 \xB2 sup3 \xB3 acute \xB4
|
|
|
- micro \xB5 para \xB6 middot \xB7 cedil \xB8
|
|
|
- sup1 \xB9 ordm \xBA raquo \xBB frac14 \xBC
|
|
|
- frac12 \xBD frac34 \xBE iquest \xBF Agrave \xC0
|
|
|
- Aacute \xC1 Acirc \xC2 Atilde \xC3 Auml \xC4
|
|
|
- Aring \xC5 AElig \xC6 Ccedil \xC7 Egrave \xC8
|
|
|
- Eacute \xC9 Ecirc \xCA Euml \xCB Igrave \xCC
|
|
|
- Iacute \xCD Icirc \xCE Iuml \xCF ETH \xD0
|
|
|
- Dstrok \xD0 Ntilde \xD1 Ograve \xD2 Oacute \xD3
|
|
|
- Ocirc \xD4 Otilde \xD5 Ouml \xD6 times \xD7
|
|
|
- Oslash \xD8 Ugrave \xD9 Uacute \xDA Ucirc \xDB
|
|
|
- Uuml \xDC Yacute \xDD THORN \xDE szlig \xDF
|
|
|
- agrave \xE0 aacute \xE1 acirc \xE2 atilde \xE3
|
|
|
- auml \xE4 aring \xE5 aelig \xE6 ccedil \xE7
|
|
|
- egrave \xE8 eacute \xE9 ecirc \xEA euml \xEB
|
|
|
- igrave \xEC iacute \xED icirc \xEE iuml \xEF
|
|
|
- eth \xF0 ntilde \xF1 ograve \xF2 oacute \xF3
|
|
|
- ocirc \xF4 otilde \xF5 ouml \xF6 divide \xF7
|
|
|
- oslash \xF8 ugrave \xF9 uacute \xFA ucirc \xFB
|
|
|
- uuml \xFC yacute \xFD thorn \xFE yuml \xFF
|
|
|
- ensp \x20 emsp \x20 thinsp \x20 zwnj \x20
|
|
|
- zwj \x20 lrm \x20 rlm \x20 euro \x80
|
|
|
- sbquo \x82 bdquo \x84 hellip \x85 dagger \x86
|
|
|
- Dagger \x87 circ \x88 permil \x89 Scaron \x8A
|
|
|
- lsaquo \x8B OElig \x8C oelig \x8D lsquo \x91
|
|
|
- rsquo \x92 ldquo \x93 rdquo \x94 ndash \x96
|
|
|
- mdash \x97 tilde \x98 scaron \x9A rsaquo \x9B
|
|
|
- Yuml \x9F apos \x27
|
|
|
- }
|
|
|
-
|
|
|
- regsub -all -- {<(.[^>]*)>} $data " " data
|
|
|
-
|
|
|
- if {$eval != 1} {
|
|
|
- regsub -all -- {([\$\[\]\{\}\(\)\\])} $data {\\\1} data
|
|
|
- } else {
|
|
|
- regsub -all -- {([\$\[\]\{\}\(\)\\])} $data {\\\\\\\1} data
|
|
|
- }
|
|
|
-
|
|
|
- regsub -all -- {&#(\d+);} $data {[subst -nocomm -novar [format \\\u%04x [scan \1 %d]]]} data
|
|
|
- regsub -all -- {&#x(\w+);} $data {[format %c [scan \1 %x]]} data
|
|
|
- regsub -all -- {&([0-9a-zA-Z#]*);} $data {[if {[catch {set tmp $chars(\1)} char] == 0} { set tmp }]} data
|
|
|
- regsub -all -- {&([0-9a-zA-Z#]*);} $data {[if {[catch {set tmp [string tolower $chars(\1)]} char] == 0} { set tmp }]} data
|
|
|
-
|
|
|
- regsub -nocase -all -- "\\s{2,}" $data " " data
|
|
|
-
|
|
|
- set data [subst $data]
|
|
|
- if {[incr loop] == 1} {
|
|
|
- set data [[namespace current]::html_decode 0 $data $loop]
|
|
|
- }
|
|
|
-
|
|
|
- return $data
|
|
|
-}
|
|
|
-
|
|
|
-proc ::rss-synd::check_channel {chanlist chan} {
|
|
|
- foreach match [split $chanlist] {
|
|
|
- if {[string equal -nocase $match $chan]} {
|
|
|
- return 1
|
|
|
- }
|
|
|
- }
|
|
|
-
|
|
|
- return 0
|
|
|
-}
|
|
|
-
|
|
|
-proc ::rss-synd::urldecode {str} {
|
|
|
- regsub -all -- {([\"\$\[\]\{\}\(\)\\])} $str {\\\1} str
|
|
|
-
|
|
|
- regsub -all -- {%([aAbBcCdDeEfF0-9][aAbBcCdDeEfF0-9]);?} $str {[format %c [scan \1 %x]]} str
|
|
|
-
|
|
|
- return [subst $str]
|
|
|
-}
|
|
|
-
|
|
|
-::rss-synd::init
|
