## Title.tcl v2.1 by Vertigo@RusNet ## Public version (non sockets) ## Скрипт цитирует заголовок URL-ссылки, когда ее пишут в канал. ## Включение - .chanset #chan +title ## Включение антимата - .chanset #chan +nobadtitle ## Добавлена поддержка игнорируемых юзеров. Флаг I (глобальный) ## Юзеры с таким флагом будут игнорироваться скриптом. namespace eval ::title { ############### # Настройки ############### # на фразы, начинающиеся с указанных символов не будет реакции variable denyprefixes {"!" "$" "." "^"} # на указанные домены будет осуществляться автореагирование (помимо http://) variable domains {".ru" ".com" ".org" ".su" ".info" ".net" ".de" ".au" ".ua"} # разрешить реагирование на текст, содержащий только домены (без http://) [0/1] variable nodomains 0 # максимальное число редиректов variable maxredirects 5 # таймут соединения (в секундах) variable timeout 30 # сколько байт скачивать при запросе (актуально, если сервер поддерживает Accept-Range) variable readlimit 11564 # юзер-агент variable useragent {Opera/9.52 (Windows NT 5.1; U; en)} # включить отладку? [0/1] variable debug 0 # шаблон вывода сообщения в канал variable deftemplate {\002Title\002:} # защита от флуда (в секундах) variable flood 3 # канальный флаг, разрешающий/запрещающий работу скрипта variable chflag [namespace tail [namespace current]] ################# # Конец настроек ################# package require http 2.7 if {![catch {package require tls} err]} {::http::register https 443 ::tls::socket; variable using_ssl 1} else {putlog "Package TLS not loaded. 'https://' not supported. Info: $err."; variable using_ssl 0} setudef flag $chflag setudef flag nobadtitle variable redir 0 variable template "" bind pubm - * ::title::pub bind ctcp - "ACTION" ::title::actn if {[info exists sp_version]} {set ::max_tcl_events 20; set ::select_timeout 100} proc pub {nick uhost hand chan text} { variable chflag if {![channel get $chan $chflag]} {return} ::title::main $nick $uhost $hand $chan $text return } proc actn {nick uhost hand chan key text} { variable chflag if {![channel get $chan $chflag]} {return} ::title::main $nick $uhost $hand $chan $text return } proc nodomain {text} { variable domains foreach _ $domains { if {![string match "*$_*" "$text"]} {continue} if {[string match "*$_*" "$text"]} {return 0} } return 1 } proc main {nick uhost hand chan text} { if {[matchattr $hand I]} {return} variable denyprefixes; variable using_ssl; variable debug; variable nodomains set text [split $text] regsub -all {[\[\]\{\}\(\)\"\'\>\<]} $text "" text set text [stripcodes bcruag $text] foreach _ $denyprefixes { if {[string index $text 0] eq $_} {if {$debug} {putlog "::title:: \[main\] Found denied prefix. Not responding."};return} } if {![string match "*http://*" $text] && ![string match "*https://*" $text] && ![string match "*www.*" $text] && ![string match "*wap.*" $text] && [nodomain $text]} {if {$debug} {putlog "::title:: \[main\] Links not found."}; return} variable flood if {[info exists ::title::check(lasttime,$nick)] && [expr $::title::check(lasttime,$nick) + $flood] > [clock seconds]} { putserv "NOTICE $nick :You are URL's flooder and will be ignored for 1 minute." newignore "*!*@[lindex [split $uhost @] 1]" $::botnick "URL's flooder." 1 putlog "::title:: Ignored mask: *!*@[lindex [split $uhost @] 1], nick - $nick." return } foreach _ $text { if {[regexp -nocase -- {^(http://.+?)$} $_ -> url] || [regexp -nocase -- {^(www.*?|wap.*?)$} $_ -> url]} {request $url $nick $uhost $chan} if {$using_ssl && [regexp -nocase -- {^(https://.+?)$} $_ -> url]} {request $url $nick $uhost $chan} if {![regexp -nocase -- {^(http://.+?)$} [lindex $_ 0]] && $nodomains} {if {![nodomain [lindex $_ 0]]} {request "http:\/\/[lindex $_ 0]" $nick $uhost $chan}} } } proc request {url nick uhost chan} { variable useragent; variable debug; variable timeout; variable readlimit if {[string range $url 0 7] eq "http://-"} {set url "http://[string range [string trim $url "-"] 8 end]"} if {[string range $url 0 6] ne "http://"} {set url "http://$url"} set extra [list $nick $uhost $chan $url] ::http::config -useragent $useragent if {$debug} {putlog "::title \[request\] Extra: $extra."} if {[catch {set token [::http::geturl $url -binary 1 -timeout [expr $timeout*1000] -headers [list "Range" "bytes=0-$readlimit"] -command [list [namespace current]::data $extra]]} err]} {return} set ::title::check(lasttime,$nick) [clock seconds] } proc data { extra token } { variable maxredirects; variable deftemplate; variable debug; variable redir; variable maxredirects; variable using_ssl; variable template set status [::http::status $token] set ncode [::http::ncode $token] array set meta [::http::meta $token] if {$debug} {putlog "::title:: \[data\] status: $status\; metacode: $ncode\."} if {![info exists meta(Content-Length)]} {set Size "Unknown size"} else {set Size [fsize $meta(Content-Length)]} if {[info exists meta(Content-Range)]} {set Size [fsize [lindex [regexp -inline -- {bytes.*?\/(.+?)$} $meta(Content-Range)] 1]]} if {[info exists meta(Content-Type)]} {set Type $meta(Content-Type)} else {set Type "Unknown type"} if {$Size eq "Unknown size" && $Type eq "Unknown type"} {::http::cleanup $token; return} set nick [lindex $extra 0]; set uhost [lindex $extra 1]; set chan [lindex $extra 2]; set url [lindex $extra 3] set tempurl [regsub -nocase -- "http.*://" $url ""] set query [join [lindex [split $tempurl "/"] 0] "/"] set get [join [lrange $tempurl 1 end] "/"] if {[info exists meta(Location)]} { if {$debug} {putlog "::title:: \[data\] query: $query\; get: $get"} set simb "/" if {![string match "*http://*" $meta(Location)] && [string range $meta(Location) 0 0] == "/"} { set link "http://$host$meta(Location)"} if {![string match "*http://*" $meta(Location)] && ![string match "*https://*" $meta(Location)] && [string range $meta(Location) 0 0] != "/"} { set link "http://$query$simb$meta(Location)"} if {[string match "http://*" $meta(Location)]} {set link $meta(Location)} if {![string match "*https://*" $meta(Location)] && ![info exists link] && $using_ssl == 1} {set link "https://$query$simb$meta(Location)"} if {[string match "*https://*" $meta(Location)] && $using_ssl == 1} {set link $meta(Location)} if {$meta(Location) != "" && [string match "*domain=*" [::http::meta $token]] && ![string match "http*" $meta(Location)]} {set link "http://[lindex [split http://$query "/"] 2]$simb$meta(Location)"} if {($ncode eq "301" || $ncode eq "302") && $status eq "ok"} { if {$debug} {putlog "::title:: \[data\] redirect detected."} incr redir if {$debug} {putlog "::title:: \[data\] Redirect \#$redir."} if {$redir >= $maxredirects} {if {$debug} {putlog "::title:: \[data\] Max. redirects reached. Stopping."}; set redir 0; return} set url $link ::http::cleanup $token ::title::request $url $nick $uhost $chan } } else { if {$debug} {putlog "::title:: \[data\] Data received. Processing..."} catch {array unset meta; unset -nocomplain meta} set html [::http::data $token] set meta [::http::meta $token] ::http::cleanup $token append meta $html set charset "" set charset [lindex [regexp -all -inline -nocase -- ".*?charset=(.+?)\"" $meta] 1] unset -nocomplain meta if {[string length $html] <5000 && [regexp -nocase -- "" $html -> redirr]} { regsub -all -- {\"\>} $redirr {} redirr set simb "/" if {![string match "*http://*" $redirr] && [string index $redirr 0] != "/"} {set redirr "http://$query$simb[lindex [split $get "/"] 0]$simb$redirr"} if {![string match "*http://*" $redirr] && [string index $redirr 0] == "/"} {set redirr "http://$query$redirr"} ::title::request $redirr $nick $uhost $chan if {$debug} {putlog "::title:: \[data\] meta-refresh redirect detected. URL: $redirr"} return } switch -glob -- [string range $html 0 19] { "GIF8*" {set title [gif_dimensions $html]; set sh_size 1} "\x89PNG\r\n\x1a\n*" {set title [png_dimensions $html]; set sh_size 1} "\xFF\xD8\xFF*" {set title [jpeg_dimensions $html]; set sh_size 1} "BM*" {set title [bmp_dimensions $html]; set sh_size 1} default {set title [::title::decode $html $charset]; set template $deftemplate; set sh_size 0} } if {$title ne ""} { if {[channel get $chan nobadtitle] && [DetectMat [encoding convertto cp1251 $title]]} {set title "\[censored\]"} if {$sh_size} {append title " @ $Size"} putserv "PRIVMSG $chan :[subst $template] $title" variable redir set redir 0 } else { putserv "PRIVMSG $chan :\002File\002: \037Type\037: $Type @ $Size" return } } } proc bmp_dimensions {data} { variable template set template "\002Image\002: \037Format\037: bmp ::" binary scan [string range $data 18 25] ii width height set ret [list $width $height] return "\037Dimensions\037: [join $ret x] px." } proc jpeg_dimensions {data} { variable template set template "\002Image\002: \037Format\037: jpeg ::" set ret [list] set i 2 while {[string index $data $i] eq "\xFF"} { binary scan [string range $data [incr i] [expr $i+2]] H2S type len incr i 3 # convert to unsigned set len [expr {$len & 0x0000FFFF}] # decrement len to account for marker bytes incr len -2 if {[string match {c[0-3]} $type]} { set p $i break } incr i $len } if {[info exists p]} { binary scan [string range $data $p [expr $p+4]] cSS precision height width set ret [list $width $height] } return "\037Dimensions\037: [join $ret x] px." } proc png_dimensions {data} { variable template set template "\002Image\002: \037Format\037: png ::" set ret [list] set i 0 binary scan [string range $data [incr i 8] [expr $i+7]] Ia4 len type set r [string range $data [incr i 8] [expr $i+$len]] if {$i < [string length $data] && $type eq "IHDR"} { binary scan $r II width height set ret [list $width $height] } return "\037Dimensions\037: [join $ret x] px." } proc gif_dimensions {data} { variable template set template "\002Image\002: \037Format\037: gif ::" set sig [string range $data 0 3] set ret [list] binary scan [string range $data 6 7] s wid binary scan [string range $data 8 9] s hgt set ret [list $wid $hgt] return "\037Dimensions\037: [join $ret x] px." } proc decode {data charset} { variable debug regsub -all -- {[\x5C\x27\x2F\x3E\x3C\x22\x5F\x7B\x5D\x7D\x5B]+} $charset "" charset set charset [string trim $charset] regsub -all -nocase "fc|!.*" $charset "" charset set charset [string trim [string tolower $charset] \x5D\x7D\x7B\x5B\x3C\x3E\x22\x27] set charset [lindex [split $charset] 0] if {$charset == "" || $charset == "windows-1251" || $charset == "no"} {set charset cp1251} set charset0 "" set charset [string map {"win-" "cp" "windows-" "cp" "iso-" "iso" "cp-" "cp" "utf8" "utf-8"} $charset] if {[string is space [lsearch -all [encoding names] $charset]]} {if {$debug} {putlog "::title:: \[decode\] Encoding $charset was not found! Setting to default..."}; set charset [encoding system]} set info "" set info [string trim [lindex [regexp -nocase -inline -- "(.+?)" $data] 1]] if {$info == ""} {set info [string trim [lindex [regexp -nocase -inline -- "(.+?)" $data] 1]]} if {$info == "" && [string match "*card*" $data]} {set info [lindex [regexp -nocase -all -inline -- {title=\"(.*?)\"} $data] 1]} if {$info == "" && [string match "*meta name*" $data]} {set info [lindex [regexp -nocase -all -inline -- {name=\"title\" content=\"(.*?)\"} $data] 1]} if {$debug} {putlog "::title:: \[decode\] Raw title: $info"} regsub -all "\n|\r|\t" $info " " info regsub -all { } $info { } info if {$data == {}} {if {$debug} {putlog "::title:: \[decode\] Data not present!"}; return ""} if {$charset == {}} {set charset cp1251} set info000 [encoding convertfrom [encoding system] $info] set enc_need "" if {[string match -nocase "*windows-1251*" $data] && ![regexp -nocase -- {[а-яА-ЯёЁ]} $data]} {set enc_need 1} if {![regexp -- {[а-яА-ЯёЁ]} $info]} {set enc_need auto} if {[string match "*\\\?\\\?\\\?*" $info] && ![string match "*charset=*" $data]} {set enc_need 2} if {[string match "*Рµ*" $info] || [string match "*?¶*" $info] || ([string match "*?°*" $info] && ![string match "*-°?*" $info]) || [string match -nocase "=40} {return 1} else {return 0} } proc regsub-eval {re string cmd} { return [subst [regsub -all $re [string map {\[ \\[ \] \\] \$ \\$ \\ \\\\} $string] "\[format %c \[$cmd\]\]"]] } proc fsize {bytes} { if {![string is digit $bytes]} {error "value must be a valid digit, more then zero"} if {$bytes >=0 && $bytes < 1024} {return "$bytes byte\(s\)" } elseif {$bytes >= 1024 && $bytes < 1024000} {return "[format %.2f [expr $bytes /1024.0]] KB" } elseif {$bytes >= 1024e3 && $bytes < 1024e6} {return "[format %.2f [expr $bytes/1024.0/1024.0]] MB" } elseif {$bytes >= 1024e6 && $bytes < 1024e9} {return "[format %.2f [expr $bytes/1024.0/1024.0/1024.0]] GB" } elseif {$bytes >= 1024e9 && $bytes < 1024e12} {return "[format %.2f [expr $bytes/1024.0/1024.0/1024.0/1024.0/1024.0]] TB" } elseif {$bytes >= 1024e12 && $bytes < 1024e15} {return "[format %.2f [expr $bytes/1024.0/1024.0/1024.0/1024.0/1024.0/1024.0]] PB" } elseif {$bytes >= 1024e15 && $bytes < 1024e18} {return "[format %.2f [expr $bytes/1024.0/1024.0/1024.0/1024.0/1024.0/1024.0/1024.0]] EB" } elseif {$bytes >= 1024e18 && $bytes < 1024e21} {return "[format %.2f [expr $bytes/1024.0/1024.0/1024.0/1024.0/1024.0/1024.0/1024.0/1024.0]] ZB" } else {return "[format %.2f [expr $bytes/1024.0/1024.0/1024.0/1024.0/1024.0/1024.0/1024.0/1024.0/1024.0]] IB" } } proc webstrip {t} { regsub -all -nocase -- {<.*?>(.*?)} $t {\1} t regsub -all -nocase -- {<.*?>} $t {} t set t [string map -nocase {{—} {-} {»} {»} {«} {«} {"} {"} \ {<} {<} {>} {>} { } { } {&} {&} {©} {©} {©} {©} {•} {•} {·} {-} {§} {§} {®} {®} \ ‖ || \ & & [ ( \ / ] ) { ( } ) \ £ Ј ¨ Ё © © « « ­ ­ ® ® \ ¡ Ў ¿ ї ´ ґ · · ¹ № » » \ ¼ ј ½ Ѕ ¾ ѕ À А Á Б Â В \ Ã Г Ä Д Å Е Æ Ж Ç З È И \ É Й Ê К Ë Л Ì М Í Н Î О \ Ï П Ð Р Ñ С Ò Т Ó У Ô Ф \ Õ Х Ö Ц × Ч Ø Ш Ù Щ Ú Ъ \ Û Ы Ü Ь Ý Э Þ Ю ß Я à а \ á б â в ã г ä д å е æ ж \ ç з è и é й ê к ë л ì м \ í н î о ï п ð р ñ с ò т \ ó у ô ф õ х ö ц ÷ ч ø ш \ ù щ ú ъ û ы ü ь ý э þ ю \ ° ° ‧ · ˌ . ū u ī i ˈ ' \ ɔ o ɪ i ' ' } $t] set t [string map -nocase {¡ \xA1 ¤ \xA4 ¢ \xA2 £ \xA3 ¥ \xA5 ¦ \xA6 \ § \xA7 ¨ \xA8 © \xA9 ª \xAA « \xAB ¬ \xAC \ ­ \xAD ® \xAE ¯ \xAF ° \xB0 ± \xB1 ² \xB2 \ ³ \xB3 ´ \xB4 µ \xB5 ¶ \xB6 · \xB7 ¸ \xB8 \ ¹ \xB9 º \xBA » \xBB ¼ \xBC ½ \xBD ¾ \xBE \ ¿ \xBF × \xD7 ÷ \xF7 À \xC0 Á \xC1 Â \xC2 \ Ã \xC3 Ä \xC4 Å \xC5 Æ \xC6 Ç \xC7 È \xC8 \ É \xC9 Ê \xCA Ë \xCB Ì \xCC Í \xCD Î \xCE \ Ï \xCF Ð \xD0 Ñ \xD1 Ò \xD2 Ó \xD3 Ô \xD4 \ Õ \xD5 Ö \xD6 Ø \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 ø \xF8 ù \xF9 ú \xFA \ û \xFB ü \xFC ý \xFD þ \xFE ÿ \xFF} $t] set t [::title::regsub-eval {&#([0-9]{1,5});} $t {string trimleft \1 "0"}] regsub -all {\s+} $t " " t return $t } variable BadWords { "бляд" " блят" " бля " " ьlуа " " блять " " плять " " хуй" " хиli " " hиli " " hуli " " наибал" " наебал" "нахуй" \ "нохуй" "похуй" "рохуi" "нехуй" "мудак" " муда?" "мудаё?" "мудила" " хуи " "хуител" " хуя" " хиilо" " хуilо" "нахуя" \ "нихуя" "нехуя" "дохуя" "похуя" "пахуя" "прихуя" "захуя" "отхуя" " хую" "похую" " хуе" " ахуе" " охуе" "хуев" \ " прихуе" " хер " " херню" " херни" " херне" " херня" " херов" " нахер" " похер" " нехер" " нихер" " дохер" "dоhиiа" \ "dохуiа" "дохуiа" "dоhуiа" " хера " "писд" "пизд" "рizd" " пздц " " еьапа" " еб" " еьlа" " еьlо" " епана " " епать " \ " ипать " " выепать " " ибаш" " уеб" "проеб" "праеб" "приеб" "съеб" "сьеб" "взъеб" "взьеб" "въеб" "вьеб" "выебан" \ "перееб" "недоеб" "долбоеб" "долбаеб" "dоlьоеь" "dоlьаеь" "dоjlбоеб" " ниибац" " неебац" " неебат" " ниибат" " пидар" \ " рidаr" " пидар" " пидор" "педор" "пидор" "пидарас" "пидараз" " педар" "педри" "пидри" " заеп" " заип" " заеб" "ебучий" \ "ебучка " "епучий" "епучка " " заиба" " zаеь" "заебан" "заебис" " zаеб" " выеб" "выебан" " поеб" " наеб" " наеб" "сьеб" \ "взьеб" "вьеб" " гандон" " гондон" " rанdон" " дапdоп" " fиск" " fаск " " fаскiп" " роеьоtа " " hиуп" " пеhиу" " пihиуа " \ " пihуа " "пахуи" "похуис" " манда " "мандав" " залупа" " залупог" "йух" "сука" "яебу" } proc DetectMat {text} { variable BadWords regsub -all {[\x02\x16\x1f]|\x03\d{0,2}(,\d{0,2})?} $text "" text set text [encoding convertfrom [encoding system] $text] set text [string map {A а a а B в C с c с E е e е H н K к k к M м O о o о P р p р T т U и u и X х x х Y у y у 3 з 4 ч 6 б 0 о b ь g д n п} $text] set text [string tolower $text] set text " $text " regsub -all {\.\`\~\!\@\#\$\%\^\&\*\(\)\_\-\+\=\{\}\[\]\;\:\'\"\<\>\,\.\/\?\|\\} $text " " text"; set res "" set ch "" for {set i 0} {$i < [string length $text]} {incr i} { set newch [string index $text $i] if {$ch != $newch} { append res $newch } set ch $newch } set text $res foreach i $BadWords { set mask [split [string trim $i] {}] regsub -all { } $mask {\s*} mask set mask ".*\\s+$mask\\s+.*" if {[regexp $mask $text] || [string match *$i* $text]} { return 1 } } return 0 } putlog "title loaded v2.1" }