#---------------------------------------------------------------------------- # ircsearch - Поиск каналов в IRC-сетях. #---------------------------------------------------------------------------- package require Tcl 8.4 package require http 2.5 namespace eval ircsearch { foreach p [array names ircsearch *] { catch {unset ircsearch ($p) } } #---------------------------------------------------------------------------- # Первичные параметры конфигурации (Suzi / http.tcl) #---------------------------------------------------------------------------- # сведения о разработчике скрипта, версии, дате последней модификации variable author "anaesthesia" variable version "01.01" variable date "10-jul-2008" # имя нэймспэйса без ведущих двоеточий variable unamespace [namespace tail [namespace current]] # префикс для публичных команд (может быть пустой строкой) variable pubprefix {!} variable pubflag {-|-} # pubcmd:имя_обработчика "вариант1 вариант2 ..." # команда и её публичные варианты, строка в которой варианты разделены пробелом variable pub:ircsearch "$unamespace irc" # тоже что и выше, для приватных команд variable msgprefix {!} variable msgflag {-|-} # такие же команды как для публичных алиасов variable msg:ircsearch ${pub:ircsearch} # можно отключить приватные или публичные команды, указав в качестве алиасов пустую строку # или закоменнтировав объявление variable [pub|msg]:handler "string ..." # какие идентификаторы используются для различения запросов # доступны $unick, $uhost, $uchan # обычное tcl выражение, позволяющие сформировать уникальный id для # идентификации запроса. variable requserid {$uhost} # максимальное число ожидающих выполнения запросов для одного id variable maxreqperuser 1 # максимальное число ожидающих выполнения запросов variable maxrequests 5 # пауза между запросами, в течении которой сервис недоступен для использования, # секунд variable pause 15 # адрес прокси-сервера # строка вида "proxyhost.dom:proxyport" или пустая строка, если прокси-сервис # не используется variable proxy {} # поведение канального флага, если значение "" -- носит разрешающий # характер, то есть если этот флаг установлен на канале -- сервис работает # если "no" значения этой переменной указывают что флаг носит запрещающий # характер и будучи установлен на канале запрещает работу сервиса # (при этом сервис работает на ВСЕХ каналах, где не установлене этот флаг) variable flagactas "" # имя канального флага, служащего для включения/выключения сервиса на канале # по умолчанию формируется из режима работы флага и имени неймспейса # в данном случае режим работы запрещающий # при установке на канале запрещает работу variable chflag "$flagactas$unamespace" setudef flag $chflag #---------------------------------------------------------------------------- # Вторичные параметры конфигурации #---------------------------------------------------------------------------- # вести лог запросов -- пустая строка лог не ведётся # иначе форматированный вывод в лог variable logrequests {'$unick', '$uhost', '$handle', '$uchan', '$ustr'} # Команда вывода для публичного запроса, по умолчанию -- на канал # доступны $uchan & $unick variable pubsend {PRIVMSG $uchan :} # Команда вывода для приватного запроса, по умолчанию -- приватное сообщение # доступно только $unick ($uchan == $unick) variable msgsend {PRIVMSG $unick :} # команда вывода для ошибок/недоступности сервиса # доступны $unick variable errsend {NOTICE $unick :} # Максимальное число редиректов с запрошенной страницы variable maxredir 1 # Таймаут запроса в миллисекундах, то есть 30 секунд variable timeout 30000 # сообщение о принятии запроса variable err_ok {Ваш запрос принят} # сообщение о невозможности получить данные, разницы в ошибках не делается # просто сообщается о невозможности их получить variable err_fail {к сожалению Ваш запрос не выполнен. Возможно не удалось связаться с интернет-сервисом.} # сообщение о заполненности очереди запросов variable err_queue_full {в данное время очередь сервиса заполнена и не может выполнить Ваш запрос. Повторите попытку позже.} # сообщение о заполненности очереди для конкретного id variable err_queue_id {пожалуйста дождитесь обработки предыдущих запросов.} # сообщение о том что пауза между использованиями сервиса не истекла # доступна переменная $timewait -- оставшееся время, по истечении которого # сервис будет доступен variable err_queue_time {пожалуйста повторите попытку позже. Сервис будет доступен для использования через $timewait сек.} #---------------------------------------------------------------------------- # Внутренние переменные и код #---------------------------------------------------------------------------- # адрес, с которого происходит получение информации variable fetchurl "http://searchirc.com/" # количество выводимых результатов variable maxres 1 # очередь запросов variable reqqueue array unset reqqueue # последние таймстампы variable laststamp array unset laststamp variable cityid array unset cityid variable updinprogress 0 variable updatetimeout 60000 #---body--- proc tolow {strr} { return [string tolower [string map {Й й Ц ц У у К к Е е Н н Г г Ш ш Щ щ З з Х х Ъ ъ Ф ф Ы ы В в А а П п Р р О о Л л Д д Ж ж Э э Я я Ч ч С с М м И и Т т Ь ь Б б Ю ю Ё ё} $strr]] } proc sspace {strr} { return [string trim [regsub -all {[\t\s]+} $strr { }]] } proc msg:ircsearch { unick uhost handle str } { pub:ircsearch $unick $uhost $handle $unick $str return } proc pub:ircsearch { unick uhost handle uchan str } { variable requserid variable fetchurl variable chflag variable flagactas variable errsend variable mpage variable mstr variable idx variable maxres variable pubprefix variable pubsend variable msgsend variable unamespace variable stype set id [subst -nocommands $requserid] set prefix [subst -nocommands $errsend] if { $unick ne $uchan } { if { ![channel get $uchan $chflag] ^ $flagactas eq "no" } { return } } set why [queue_isfreefor $id] if { $why != "" } { lput puthelp $why $prefix return } #---параметры if {[regexp -nocase -- {^-(\d+)} $str -> mpg]} {set mpage $mpg ; regsub -- {-\d+\s+} $str "" str} {set mpage 1} set mstr [expr {($mpage / 10) + 1}] set idx [expr {($mpage % 10) > 0 ? ($mpage % 10) : 10}] set ustr $str if {$ustr == ""} { if { $uchan eq $unick } {set prefix [subst -nocommands $msgsend]} {set prefix [subst -nocommands $pubsend]} lput puthelp "\002Формат\002: $pubprefix$unamespace \[-номер результата\] \[+\]<#канал> " $prefix lput puthelp "Поиск irc-каналов. Параметр \002+\002#канал - поиск в имени канала \037и\037 топике. Если #канал не указан, выводится информация о irc-сети." $prefix return } elseif {[regexp -nocase -- {#(.*?)(?:\s|$)(.*?)$} $ustr -> schan snet]} { if {$snet == ""} {set snet "all"} if {$mstr > 0} {set p "&P=$mstr"} {set p ""} if {[regexp -- {\+} $ustr]} {set t "both"} {set t "chan"} set ustr "search.php?F=partial&I=$schan&T=$t&N=$snet&M=min&C=1&PER=10&D=plain$p&Submit=+Go+" set stype 0 } else { set ustr "network/$ustr" set stype 1 } variable logrequests if { $logrequests ne "" } { set logstr [subst -nocommands $logrequests] variable unamespace lput putlog $logstr "$unamespace: " } ::http::config -useragent "Mozilla/4.0 (compatible; MSIE 4.01; Windows CE; PPC; 240x320)" if { [queue_add "$fetchurl$ustr" $id "[namespace current]::dream:parser" [list $unick $uhost $uchan {}]] } { variable err_ok if { $err_ok ne "" } { lput puthelp "$err_ok." $prefix } } else { variable err_fail if { $err_fail ne "" } { lput puthelp $err_fail $prefix } } return } #---parser proc dream:parser { errid errstr body extra } { upvar $errid lerrid $errstr lerrstr $body lbody $extra lextra variable err_fail variable pubsend variable msgsend variable errsend variable useurl variable maxres variable mpage variable mstr variable idx variable stype foreach { unick uhost uchan ustr } $lextra { break } if { $lerrid ne {ok} } { lput putserv [subst -nocommands $err_fail] [subst -nocommands $errsend] return } if { $uchan eq $unick } { set prefix [subst -nocommands $msgsend] } else { set prefix [subst -nocommands $pubsend] } #--suzi-patch global sp_version if {[info exists sp_version]} { set str [encoding convertfrom cp1251 $lbody] } else { set str $lbody } #---------------------------------------------------------------------------- ##---parser-specific------ #---------------------------------------------------------------------------- if {$stype} { regsub -all -- "\n|\r|\t" $str {} str regsub -all -nocase -- "|" $str "\002" str if {[regexp -nocase -- {
(.*?)
} $str -> topc]} { regsub -all -nocase -- "
" $topc { - } topc regsub -all -nocase -- "<.*?>" $topc { } topc } else { set topc "N/A" } if {![regexp -nocase -- {
(.*?)
} $str -> cstat]} { set cstat "N/A" } if {[regexp -nocase -- {(.*?)} $str -> ninf]} { regsub -all -nocase -- "" $ninf { - } ninf regsub -all -nocase -- " " $ninf { } ninf regsub -all -nocase -- "<.*?>" $ninf { } ninf } else { set ninf "N/A" } lput putserv ":: [sspace $cstat] :: [sspace $ninf] :: [string trimright [sspace $topc] "-"]" $prefix } else { if {![regexp -nocase -- {
.*?\(of (.*?)\)} $str -> cnum]} { set cnum 0 } regsub -all -- "\n|\r|\t" $str {} str regsub -all -- {} $str "\n" str regsub -all -nocase -- "|" $str "\002" str set cnt 0 foreach line [split $str \n] { if {[regexp -nocase -- {
(.*?) 
.*?.*?(.*?)$} $line -> lnum lchan ltime linf]} { regsub -all -nocase -- " " $linf { } linf regsub -all -nocase -- "
" $linf { :: } linf regsub -all -nocase -- "<.*?>" $linf {} linf incr cnt } if {$cnt == $idx} { set linf [string map {"Review: There are no reviews of this channel" ""} [sconv [sspace $linf]]] if {[string match -nocase "*rusnet*" $linf]} {set linf [encoding convertfrom koi8-r [encoding convertto cp1251 $linf]]} lput putserv "\[$cnum\] :: $lnum $lchan ($ltime) [sspace $linf]" $prefix break } } if {$cnt == 0} {lput putserv "\037Ничего не найдено\037." $prefix} } ;#type 0 return } #---------------------------------------------------------------------------- ##---ok------ #---------------------------------------------------------------------------- proc sconv {text} { set escapes {   \x20 " \x22 & \x26 ' \x27 – \x2D < \x3C > \x3E ˜ \x7E € \x80 ¡ \xA1 ¢ \xA2 £ \xA3 ¤ \xA4 ¥ \xA5 ¦ \xA6 § \xA7 ¨ \xA8 © \xA9 ª \xAA « \xAB ¬ \xAC ­ \xAD ® \xAE &hibar; \xAF ° \xB0 ± \xB1 ² \xB2 ³ \xB3 ´ \xB4 µ \xB5 ¶ \xB6 · \xB7 ¸ \xB8 ¹ \xB9 º \xBA » \xBB ¼ \xBC ½ \xBD ¾ \xBE ¿ \xBF À \xC0 Á \xC1 Â \xC2 Ã \xC3 Ä \xC4 Å \xC5 Æ \xC6 Ç \xC7 È \xC8 É \xC9 Ê \xCA Ë \xCB Ì \xCC Í \xCD Î \xCE Ï \xCF Ð \xD0 Ñ \xD1 Ò \xD2 Ó \xD3 Ô \xD4 Õ \xD5 Ö \xD6 × \xD7 Ø \xD8 Ù \xD9 Ú \xDA Û \xDB Ü \xDC Ý \xDD Þ \xDE ß \xDF à \xE0 á \xE1 â \xE2 ã \xE3 ä \xE4 å \xE5 æ \xE6 ç \xE7 è \xE8 é \xE9 ê \xEA ë \xEB ì \xEC í \xED î \xEE ï \xEF ð \xF0 ñ \xF1 ò \xF2 ó \xF3 ô \xF4 õ \xF5 ö \xF6 ÷ \xF7 ø \xF8 ù \xF9 ú \xFA û \xFB ü \xFC ý \xFD þ \xFE ÿ \xFF }; set text [string map $escapes [join [lrange [split $text] 0 end]]]; regsub -all -- {\[} $text "\\\[" text regsub -all -- {\]} $text "\\\]" text regsub -all -- {\(} $text "\\\(" text regsub -all -- {\)} $text "\\\)" text regsub -all -- {&#([[:digit:]]{1,5});} $text {[format %c [string trimleft "\1" "0"]]} text regsub -all -- {&#x([[:xdigit:]]{1,4});} $text {[format %c [scan "\1" %x]]} text regsub -all -- {&#?[[:alnum:]]{2,7};} $text "" text return [subst -novariables $text] } #--вывод с проверкой длины строки и переносом по словам proc lput { cmd str { prefix {} } {maxchunk 420} } { set buf1 ""; set buf2 [list]; foreach word [split $str] { append buf1 " " $word; if {[string length $buf1]-1 >= $maxchunk} { lappend buf2 [string range $buf1 1 end]; set buf1 ""; } } if {$buf1 != ""} { lappend buf2 [string range $buf1 1 end]; } foreach line $buf2 { $cmd $prefix$line } return } #---queue proc queue_isfreefor { { id {} } } { variable reqqueue variable maxreqperuser variable maxrequests variable laststamp variable pause variable err_queue_full variable err_queue_id variable err_queue_time if { [info exists laststamp(stamp,$id)] } { set timewait [expr { $laststamp(stamp,$id) + $pause - [unixtime]}] if { $timewait > 0 } { return [subst -nocommands $err_queue_time] } } if { [llength [array names reqqueue -glob "*,$id"]] >= $maxreqperuser } { return $err_queue_id } if { [llength [array names reqqueue]] >= $maxrequests } { return $err_queue_full } return } #---add-to-queue proc queue_add { newurl id parser extra {redir 0} } { variable reqqueue variable proxy variable timeout variable laststamp ::http::config -proxyfilter "[namespace current]::queue_proxy" if { ! [catch { set token [::http::geturl $newurl -command "[namespace current]::queue_done" -binary true -timeout $timeout] } errid] } { set reqqueue($token,$id) [list $parser $extra $redir] # lput putlog "$token,$id" set laststamp(stamp,$id) [unixtime] } else { return false } return true } #---proxy proc queue_proxy { url } { variable proxy if { $proxy ne {} } { return [split $proxy {:}] } return [list] } #---callback proc queue_done { token } { upvar #0 $token state variable reqqueue variable maxredir # lput putlog "$token" set errid [::http::status $token] set errstr [::http::error $token] set id [array names reqqueue "$token,*"] foreach { parser extra redir } $reqqueue($id) { break } regsub -- "^$token," $id {} id while (1) { if { $errid == "ok" && [::http::ncode $token] == 302 } { if { $redir < $maxredir } { array set meta $state(meta) if { [info exists meta(Location)] } { variable fetchurl queue_add "$fetchurl$meta(Location)" $id $parser $extra [incr redir] break } } else { set errid "error" set errstr "Maximum redirects reached" } } if { [catch { $parser {errid} {errstr} {state(body)} {extra} } errid ] } { lput putlog $errid "[namespace current] " } break } array unset reqqueue "$token,*" ::http::cleanup $token return } #---clear proc queue_clear_stamps {} { variable laststamp variable timeout variable timerID set curr [expr { [unixtime] - 2 * $timeout / 1000 }]; # putlog "dbg: $curr" foreach { id } [array names laststamp] { if { $laststamp($id) < $curr } { array unset laststamp $id; } } # putlog "dbg: [array get laststamp]" set timerID [timer 10 "[info level 0]"] } #---command aliases & bnd proc cmdaliases { { action {bind} } } { foreach { bindtype } {pub msg dcc} { foreach { bindproc } [info vars "[namespace current]::${bindtype}:*"] { variable "${bindtype}prefix" variable "${bindtype}flag" foreach { alias } [set $bindproc] { # putlog "$action $bindtype [set ${bindtype}flag] [set ${bindtype}prefix]$alias $bindproc" catch { $action $bindtype [set ${bindtype}flag] [set ${bindtype}prefix]$alias $bindproc } } } } return } #---killtimers if {[info exists timerID]} { catch {killtimer $timerID}; catch {unset timerID} } #---rest [namespace current]::queue_clear_stamps cmdaliases global sp_version if {[info exists sp_version]} { putlog "[namespace current] v$version suzi_$sp_version \[$date\] by $author loaded." } else { putlog "[namespace current] v$version \[$date\] by $author loaded." } }