/aigen.tcl
TCL | 513 lines | 322 code | 105 blank | 86 comment | 61 complexity | 58f88693dbebb14d1307ea4cc7902e0e MD5 | raw file
- #----------------------------------------------------------------------------
- # aigen - ??????????? ???? (???????? ;)
- #----------------------------------------------------------------------------
- # ????????? ???????: .chanset #chan +aigen
- # ???????: !?????? <???>
- # !???? <???>
- # ?????: !???? <?????>
- # ???????: ???? ???? ?????? ?????? ??-??????! ;)
- package require Tcl 8.4
- package require http 2.5
- namespace eval aigen {
- foreach p [array names aigen *] { catch {unset aigen ($p) } }
- #----------------------------------------------------------------------------
- # ????????? ????????? ???????????? (Suzi / http.tcl)
- #----------------------------------------------------------------------------
- # ???????? ? ???????????? ???????, ??????, ???? ????????? ???????????
- variable author "anaesthesia"
- variable version "01.01"
- variable date "01-jun-2008"
- # ??? ?????????? ??? ??????? ?????????
- variable unamespace [namespace tail [namespace current]]
- # ??????? ??? ????????? ?????? (????? ???? ?????? ???????)
- variable pubprefix {!}
- variable pubflag {-|-}
- # pubcmd:???_??????????? "???????1 ???????2 ..."
- # ??????? ? ?? ????????? ????????, ?????? ? ??????? ???????? ????????? ????????
- variable pub:aigen "$unamespace monster ?????? dwarf ???? ????"
- # ???? ??? ? ????, ??? ????????? ??????
- variable msgprefix {!}
- variable msgflag {-|-}
- # ????? ?? ??????? ??? ??? ????????? ???????
- variable msg:aigen ${pub:aigen}
- # ????? ????????? ????????? ??? ????????? ???????, ?????? ? ???????? ??????? ?????? ??????
- # ??? ??????????????? ?????????? variable [pub|msg]:handler "string ..."
- # ????? ?????????????? ???????????? ??? ?????????? ????????
- # ???????? $unick, $uhost, $uchan
- # ??????? tcl ?????????, ??????????? ???????????? ?????????? id ???
- # ????????????? ???????.
- variable requserid {$uhost}
-
- # ???????????? ????? ????????? ?????????? ???????? ??? ?????? id
- variable maxreqperuser 1
- # ???????????? ????? ????????? ?????????? ????????
- variable maxrequests 5
- # ????? ????? ?????????, ? ??????? ??????? ?????? ?????????? ??? ?????????????,
- # ??????
- variable pause 30
-
- # ????? ??????-???????
- # ?????? ???? "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://aigenerators.net/"
- # ?????????? ????????? ???????????
- variable maxres 1
- # ??????? ????????
- variable reqqueue
- array unset reqqueue
- # ????????? ??????????
- variable laststamp
- array unset laststamp
- 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:aigen { unick uhost handle str } {
- pub:aigen $unick $uhost $handle $unick $str
- return
- }
- proc chkrusl {strr} {
- if {[lsearch -exact {? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ?} $strr] > -1} {return 1} {return 0}
- }
- proc chkrus {strr} {
- set len [string length $strr]
- set cnt 0
- while {$cnt < $len} {
- if {[chkrusl [string index $strr $cnt]]} { return 1 }
- incr cnt
- }
- return 0
- }
- proc uenc {strr} {
- set str ""
- foreach byte [split [encoding convertto [encoding system] $strr] ""] {
- scan $byte %c i
- if {[string match {[%<>"]} $byte] || $i < 65 || $i > 122} {
- append str [format %%%02X $i]
- } else {
- append str $byte
- }
- }
- return [string map {%3A : %2D - %2E . %30 0 %31 1 %32 2 %33 3 %34 4 %35 5 %36 6 %37 7 %38 8 %39 9 \[ %5B \\ %5C \] %5D \^ %5E \_ %5F \` %60} $str]
- }
- proc pub:aigen { unick uhost handle uchan str } {
- variable requserid
- variable fetchurl
- variable mtype
- variable chflag
- variable flagactas
- variable errsend
- variable maxres
- variable pubprefix
- variable pubsend
- variable msgsend
- variable unamespace
- 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
- }
- #---?????????
- set ustr [tolow $str]
- if {$ustr == ""} {
- if {$uchan eq $unick} {set prefix [subst -nocommands $msgsend]} {set prefix [subst -nocommands $pubsend]}
- lput puthelp "??????????? ????. \002??????\002: $pubprefix\?????? <???> \037???\037 $pubprefix\???? <???>" $prefix
- return
- } elseif {(![chkrus $ustr] || [string length $ustr] > 11) && ![string match "*????*" $::lastbind]} {
- lput puthelp "\037??? ?????? ???? ???????? ?????????? ? ???? ?? ??????? 11-? ????????\037." $prefix
- return
- } else {
- if {[string match "*????*" $::lastbind] || [string match "*dwarf*" $::lastbind]} {
- set ustr "dec_dwarf_pic.php?monster=[uenc $ustr]"
- set mtype 1
- } elseif {[string match "*????*" $::lastbind]} {
- set ustr "bayan.php?creo_text=[uenc $ustr]"
- set mtype 2
- } else {
- set ustr "dec_monster_pic1.php?monster=[uenc $ustr]"
- set mtype 0
- }
- }
- 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)"
- variable fetchurl
- 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 mtype
- 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 [encoding system] $lbody]
- } else {
- set str $lbody
- }
- #----------------------------------------------------------------------------
- ##---parser-specific------
- #----------------------------------------------------------------------------
- regsub -all "\n|\r|\t" $str {} str
- if {$mtype == 2} {
- if {[regexp {<table align=center><tr><th>(.*?)<br>} $str -> mhead]} {
- regsub -all -nocase -- "<b>|</b>" $mhead "\002" mhead
- regsub -all -- "<.*?>" $mhead {} mhead
- lput putserv "[sspace $mhead]" $prefix
- return
- } else {
- lput putserv "\037???????????? ????037." $prefix
- return
- }
- }
- if {[regexp {<tr><th>(.*?)</th></tr>.*?</td></tr><tr><td align=center>(.*?)<p><br><br></p>} $str -> mhead mdata]} {
- regsub -all -nocase -- "<b>|</b>" $mhead "\002" mhead
- regsub -all -nocase -- "<b>|</b>" $mdata "\002" mdata
- regsub -all -- "<.*?>" $mdata {} mdata
- if {$mtype} {
- lput putserv "[sspace $mhead]" $prefix
- } else {
- lput putserv "[sspace $mhead] :: [sspace $mdata]" $prefix
- }
- } else {
- lput putserv "\037????????? ?? ???????037." $prefix
- return
- }
- return
- }
- #----------------------------------------------------------------------------
- ##---ok------
- #----------------------------------------------------------------------------
- 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]
- 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
-
- 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 }];
- foreach { id } [array names laststamp] {
- if { $laststamp($id) < $curr } {
- array unset laststamp $id;
- }
- }
- 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] {
- 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."
- }
- }