## 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 -- "