aigen.tcl | searchcode

/aigen.tcl

http://egghelp.googlecode.com/
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."
	}
}