[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Tcldrop/CVS] tcldrop/modules core.tcl dcc.tcl users/users.tc...
|
From: |
Philip Moore |
|
Subject: |
[Tcldrop/CVS] tcldrop/modules core.tcl dcc.tcl users/users.tc... |
|
Date: |
Fri, 21 Nov 2003 17:29:15 -0500 |
CVSROOT: /cvsroot/tcldrop
Module name: tcldrop
Branch:
Changes by: Philip Moore <address@hidden> 03/11/21 17:28:28
Modified files:
modules : core.tcl dcc.tcl
modules/users : users.tcl users_arraydb.tcl
modules/irc : irc.tcl
Log message:
Support for counting how many times each bind has been triggered was
added.
CVSWeb URLs:
http://savannah.gnu.org/cgi-bin/viewcvs/tcldrop/tcldrop/modules/core.tcl.diff?tr1=1.18&tr2=1.19&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/tcldrop/tcldrop/modules/dcc.tcl.diff?tr1=1.24&tr2=1.25&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/tcldrop/tcldrop/modules/users/users.tcl.diff?tr1=1.13&tr2=1.14&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/tcldrop/tcldrop/modules/users/users_arraydb.tcl.diff?tr1=1.9&tr2=1.10&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/tcldrop/tcldrop/modules/irc/irc.tcl.diff?tr1=1.21&tr2=1.22&r1=text&r2=text
Patches:
Index: tcldrop/modules/core.tcl
diff -u tcldrop/modules/core.tcl:1.18 tcldrop/modules/core.tcl:1.19
--- tcldrop/modules/core.tcl:1.18 Tue Nov 18 20:27:49 2003
+++ tcldrop/modules/core.tcl Fri Nov 21 17:26:34 2003
@@ -1,6 +1,6 @@
# core.tcl --
#
-# $Id: core.tcl,v 1.18 2003/11/19 01:27:49 fireegl Exp $
+# $Id: core.tcl,v 1.19 2003/11/21 22:26:34 fireegl Exp $
#
# Copyright (C) 2003 FireEgl (Philip Moore) <address@hidden>
#
@@ -47,7 +47,7 @@
# Provide the users module:
variable version {0.3}
package provide tcldrop::core $version
- variable rcsid {$Id: core.tcl,v 1.18 2003/11/19 01:27:49 fireegl Exp $}
+ variable rcsid {$Id: core.tcl,v 1.19 2003/11/21 22:26:34 fireegl Exp $}
# Initialize variables:
variable Binds
variable Timers
@@ -205,6 +205,7 @@
foreach b [binds log] {
foreach {type flags mask count proc} $b {}
if {[::tcldrop::CheckFlags $flags $levels] && [string match
-nocase $mask $channel]} {
+ ::tcldrop::countbind $type $mask $proc
if {[catch { $proc $levels $channel $text } err]} {
putlog "Error in $proc: $err"
puterrlog "$::errorInfo"
@@ -281,7 +282,7 @@
{-} - {+} - {*} - {-|-} - {*|*} { set flags {+|+} }
{default} { if {![string match {*|*} $flags]} { set flags
"$flags|-" } }
}
- set Binds($type,$priority,$proc,$mask) [list type $type flags $flags
mask $mask proc $proc]
+ set Binds($type,$priority,$proc,$mask) [list type $type flags $flags
mask $mask proc $proc priority $priority count 0]
set mask
}
@@ -300,20 +301,31 @@
# Search by type:
foreach b [lsort -dictionary [array names Binds $typemask,*]] {
array set bind $Binds($b)
- lappend matchbinds [list $bind(type) $bind(flags) $bind(mask) 0
$bind(proc)]
+ lappend matchbinds [list $bind(type) $bind(flags) $bind(mask)
$bind(count) $bind(proc)]
}
if {[llength $matchbinds] == 0} {
# If none were found by type, we search by mask:
foreach b [lsort -dictionary [array names Binds]] {
array set bind $Binds($b)
if {[string equal -nocase $typemask $bind(mask)]} {
- lappend matchbinds [list $bind(type)
$bind(flags) $bind(mask) 0 $bind(proc)]
+ lappend matchbinds [list $bind(type)
$bind(flags) $bind(mask) $bind(count) $bind(proc)]
}
}
}
if {[info exists matchbinds]} { return $matchbinds } else { list }
}
+# Counts how many times a bind has been triggered:
+proc ::tcldrop::countbind {type mask proc {priority {*}}} {
+ variable Binds
+ foreach name [array names Binds $type,$priority,$proc,$mask] {
+ array set bind $Binds($name)
+ incr bind(count)
+ set Binds($name) [array get bind]
+ return $bind(count)
+ }
+ return 0
+}
# These are needed in order to treat strings as lists.. (ignoring superfluous
spaces)
#proc ::tcldrop::slindex {string index} { lindex [string2list $string] $index }
#proc ::tcldrop::slrange {string start end} { lrange [string2list $string]
$start $end }
@@ -429,6 +441,7 @@
foreach b [binds time] { update
foreach {type flags mask count proc} $b {}
if {[string match $mask $current]} {
+ countbind $type $mask $proc
if {[catch { $proc $minute $hour $day $month $year }
err]} {
putlog "Error in $proc: $err"
puterrlog "$::errorInfo"
@@ -529,6 +542,7 @@
foreach b [binds evnt] {
foreach {type flags mask count proc} $b {}
if {[string equal -nocase $event $mask]} {
+ ::tcldrop::countbind $type $mask $proc
if {[catch { $proc $event } err]} {
putlog "error running $proc
$event:\n$::errorInfo"
}
@@ -616,9 +630,11 @@
bind evnt - init ::tcldrop::MakePIDFile
proc ::tcldrop::MakePIDFile {event} { global pidfile botnet-nick
if {![info exists pidfile] || $pidfile == {}} { set pidfile
"pid.${botnet-nick}" }
- set fid [open $pidfile w]
- puts $fid [pid]
- close $fid
+ catch {
+ set fid [open $pidfile w]
+ puts $fid [pid]
+ close $fid
+ }
}
bind evnt - die ::tcldrop::DeletePIDFile
Index: tcldrop/modules/dcc.tcl
diff -u tcldrop/modules/dcc.tcl:1.24 tcldrop/modules/dcc.tcl:1.25
--- tcldrop/modules/dcc.tcl:1.24 Wed Nov 19 17:52:22 2003
+++ tcldrop/modules/dcc.tcl Fri Nov 21 17:26:52 2003
@@ -1,6 +1,6 @@
# dcc.tcl --
#
-# $Id: dcc.tcl,v 1.24 2003/11/19 22:52:22 fireegl Exp $
+# $Id: dcc.tcl,v 1.25 2003/11/21 22:26:52 fireegl Exp $
#
# Copyright (C) 2003 FireEgl (Philip Moore) <address@hidden>
#
@@ -32,7 +32,7 @@
# Provide the users module:
variable version {0.2}
package provide tcldrop::dcc $version
- variable rcsid {$Id: dcc.tcl,v 1.24 2003/11/19 22:52:22 fireegl Exp $}
+ variable rcsid {$Id: dcc.tcl,v 1.25 2003/11/21 22:26:52 fireegl Exp $}
#checkmodule console
# Export all the commands that should be available to 3rd-party
scripters:
namespace export dcclist listen putdcc getchan setchan console echo
strip idx2hand hand2idx link bots islinked putbot putallbots sock2idx idx2sock
@@ -335,6 +335,7 @@
foreach {type flags mask count proc} $a {}
if {$line == {}} { break }
if {[string match -nocase $mask $line] &&
[matchattr $chatinfo(handle) $flags]} {
+ ::tcldrop::countbind $type $mask $proc
if {[catch { set line [$proc $idx
$line] } err]} {
putlog "Error in script: $proc:
$err"
puterrlog "$::errorInfo"
@@ -439,6 +440,8 @@
foreach {type flags mask count proc} $a {}
if {[string equal -nocase $cmd $mask] && [matchattr $handle
$flags]} {
incr retval
+ putloglev d * "tcl: dcc call: $proc $handle $idx $arg"
+ ::tcldrop::countbind $type $mask $proc
if {[catch { $proc $handle $idx $arg } err]} {
putlog "error in script: $proc: $err"
} elseif {[string equal $err {1}]} {
@@ -458,6 +461,7 @@
foreach {type flags mask count proc} $a {}
if {[string equal -nocase $cmd $mask] && [matchattr
$handle $flags]} {
incr retval
+ ::tcldrop::countbind $type $mask $proc
if {[catch { $proc $handle $idx $cmd $arg }
err]} {
putlog "error in script: $proc: $err"
} elseif {[string equal $err {1}]} {
@@ -476,6 +480,7 @@
foreach {type flags mask count proc} $a {}
if {[string equal -nocase $cmd $mask] && [matchattr
$handle $flags]} {
incr retval
+ ::tcldrop::countbind $type $mask $proc
if {[catch { $proc $handle $cmd $arg } err]} {
putlog "error in script: $proc: $err"
} elseif {[string equal $err {1}]} {
Index: tcldrop/modules/irc/irc.tcl
diff -u tcldrop/modules/irc/irc.tcl:1.21 tcldrop/modules/irc/irc.tcl:1.22
--- tcldrop/modules/irc/irc.tcl:1.21 Fri Nov 14 10:58:48 2003
+++ tcldrop/modules/irc/irc.tcl Fri Nov 21 17:28:03 2003
@@ -4,7 +4,7 @@
# * All IRC related commands.
# Depends: core, server, channels.
#
-# $Id: irc.tcl,v 1.21 2003/11/14 15:58:48 fireegl Exp $
+# $Id: irc.tcl,v 1.22 2003/11/21 22:28:03 fireegl Exp $
#
# Copyright (C) 2003 Tcldrop Development Team <Tcldrop-Devel>
#
@@ -30,7 +30,7 @@
namespace eval ::tcldrop::irc {
# Provide the users module:
variable version {0.2}
- variable rcsid {$Id: irc.tcl,v 1.21 2003/11/14 15:58:48 fireegl Exp $}
+ variable rcsid {$Id: irc.tcl,v 1.22 2003/11/21 22:28:03 fireegl Exp $}
package provide tcldrop::irc $version
# Initialize variables:
variable Nicks
@@ -59,6 +59,7 @@
foreach b [binds msgm] {
foreach {type flags mask count proc} $b {}
if {[string match -nocase $mask $text] && [matchattr $handle
$flags]} {
+ ::tcldrop::countbind $type $mask $proc
if {[catch { $proc $nick $uhost $handle $text } err]} {
putlog "Error in $proc: $err"
puterrlog "$::errorInfo"
@@ -71,6 +72,7 @@
foreach b [binds pubm] {
foreach {type flags mask count proc} $b {}
if {[string match -nocase $mask "$channel $text"] && [matchattr
$handle $flags $channel]} {
+ ::tcldrop::countbind $type $mask $proc
if {[catch { $proc $nick $uhost $handle $channel $text
} err]} {
putlog "Error in $proc: $err"
puterrlog "$::errorInfo"
@@ -84,6 +86,7 @@
foreach b [binds msg] {
foreach {type flags mask count proc} $b {}
if {[string equal -nocase $mask $command] && [matchattr $handle
$flags]} {
+ ::tcldrop::countbind $type $mask $proc
if {[catch { $proc $nick $uhost $handle $text } err]} {
putlog "Error in $proc: $err"
puterrlog "$::errorInfo"
@@ -103,6 +106,7 @@
foreach b [binds pub] {
foreach {type flags mask count proc} $b {}
if {[string equal -nocase $mask $command] && [matchattr $handle
$flags $channel]} {
+ ::tcldrop::countbind $type $mask $proc
if {[catch { $proc $nick $uhost $handle $channel $text
} err]} {
putlog "Error in $proc: $err"
puterrlog "$::errorInfo"
@@ -123,6 +127,7 @@
# FixMe: If $dest is a channel, make it do a matchattr for that
channel.
# It needs to distinguish between personal and channel
CTCPs anyway.
if {[string equal -nocase $mask $keyword] && [matchattr $handle
$flags]} {
+ ::tcldrop::countbind $type $mask $proc
if {[catch { $proc $nick $uhost $handle $dest $keyword
$text } err]} {
putlog "Error in $proc: $err"
puterrlog "$::errorInfo"
@@ -177,6 +182,7 @@
foreach b [binds mode] {
foreach {type flags mask count proc} $b {}
if {[string match -nocase $mask "$channel
$mc"]} {
+ ::tcldrop::countbind $type $mask $proc
if {[catch { $proc $nick $uhost $handle
$channel $mc $victim} err]} {
putlog "Error in $proc: $err"
puterrlog "$::errorInfo"
@@ -260,6 +266,7 @@
foreach b [binds join] {
foreach {type flags mask count proc} $b {}
if {[string match -nocase $mask "$channel $from"] && [matchattr
$handle $flags $channel]} {
+ ::tcldrop::countbind $type $mask $proc
if {[catch { $proc $nick $uhost $handle $channel }
err]} {
putlog "Error in $proc: $err"
puterrlog "$::errorInfo"
@@ -371,6 +378,7 @@
foreach b [binds topc] {
foreach {type flags mask count proc} $b {}
if {[string match -nocase $mask "$channel $topic"]} {
+ ::tcldrop::countbind $type $mask $proc
if {[catch { $proc $nick $uhost $handle $channel $topic
} err]} {
putlog "Error in $proc: $err"
puterrlog "$::errorInfo"
@@ -399,6 +407,7 @@
foreach {type flags mask count proc} $b {}
foreach channel [channels] {
if {[string match -nocase $mask "$channel $nick"] &&
[botonchan $channel] && ([onchan $oldnick $channel] || [onchan $nick $channel])
&& [matchattr $handle $flags $channel]} {
+ ::tcldrop::countbind $type $mask $proc
if {[catch { $proc $oldnick $uhost $handle
$channel $nick} err]} {
putlog "Error in $proc: $err"
puterrlog "$::errorInfo"
@@ -441,6 +450,7 @@
foreach {type flags mask count proc} $b {}
foreach channel [channels] {
if {[string match -nocase $mask "$channel $uhost"] &&
[matchattr $handle $flags $channel]} {
+ ::tcldrop::countbind $type $mask $proc
if {[catch { $proc $nick $uhost $handle
$channel $msg } err]} {
putlog "Error in $proc: $err"
puterrlog "$::errorInfo"
@@ -479,6 +489,7 @@
foreach {type flags mask count proc} $b {}
foreach channel [channels] {
if {[string match -nocase $mask "$channel $victim"]} {
+ ::tcldrop::countbind $type $mask $proc
if {[catch { $proc $nick $uhost $handle
$channel $victim $reason } err]} {
putlog "Error in $proc: $err"
puterrlog "$::errorInfo"
@@ -564,6 +575,7 @@
foreach b [binds part] {
foreach {type flags mask count proc} $b {}
if {[string match -nocase $mask "$channel $uhost"] &&
[matchattr $handle $flags $channel]} {
+ ::tcldrop::countbind $type $mask $proc
if {[catch { $proc $nick $uhost $handle $channel $msg }
err]} {
putlog "Error in $proc: $err"
puterrlog "$::errorInfo"
@@ -594,6 +606,7 @@
foreach {type flags mask count proc} $b {}
# I checked and though it doesn't say so in tcl-commands.txt
this bind ignores flags
if {[string match -nocase $mask "$text"]} {
+ ::tcldrop::countbind $type $mask $proc
if {[catch { $proc $nick $uhost $handle $text $dest }
err]} {
putlog "Error in $proc: $err"
puterrlog "$::errorInfo"
Index: tcldrop/modules/users/users.tcl
diff -u tcldrop/modules/users/users.tcl:1.13
tcldrop/modules/users/users.tcl:1.14
--- tcldrop/modules/users/users.tcl:1.13 Fri Nov 14 10:58:48 2003
+++ tcldrop/modules/users/users.tcl Fri Nov 21 17:27:39 2003
@@ -1,6 +1,6 @@
# users.tcl --
#
-# $Id: users.tcl,v 1.13 2003/11/14 15:58:48 fireegl Exp $
+# $Id: users.tcl,v 1.14 2003/11/21 22:27:39 fireegl Exp $
#
# Copyright (C) 2003 FireEgl (Philip Moore) <address@hidden>
#
@@ -71,6 +71,7 @@
puterrlog "$::errorInfo"
set val 0
}
+ ::tcldrop::countbind $type $mask $proc
return $val
}
return 0
@@ -81,6 +82,7 @@
proc ::tcldrop::users::validuser {handle} {
foreach a [binds validuser] {
foreach {type flags mask count proc} $a {}
+ ::tcldrop::countbind $type $mask $proc
if {[catch { $proc $handle } val]} {
putlog "Error in script: $proc: $val"
puterrlog "$::errorInfo"
@@ -102,6 +104,7 @@
puterrlog "$::errorInfo"
set val {*}
}
+ ::tcldrop::countbind $type $mask $proc
return $val
}
return {*}
@@ -111,6 +114,7 @@
proc ::tcldrop::users::matchattr {handle flags {channel {}}} {
foreach a [binds matchattr] {
foreach {type bindsflags mask count proc} $a {}
+ ::tcldrop::countbind $type $mask $proc
if {[catch { $proc $handle $flags $channel } val]} {
putlog "Error in script: $proc: $val"
puterrlog "$::errorInfo"
@@ -135,6 +139,7 @@
puterrlog "$::errorInfo"
set val [list]
}
+ ::tcldrop::countbind $type $mask $proc
return $val
}
list
@@ -148,6 +153,7 @@
puterrlog "$::errorInfo"
set val 0
}
+ ::tcldrop::countbind $type $mask $proc
return $val
}
return 0
@@ -157,6 +163,7 @@
proc ::tcldrop::users::getuser {handle {type {}} {xtra {}}} {
foreach a [binds getuser] {
foreach {bindtype flags mask count proc} $a {}
+ ::tcldrop::countbind $type $mask $proc
if {[catch { uplevel \#0 $proc $handle $type $xtra } val]} {
putlog "Error in script: $proc: $val"
puterrlog "$::errorInfo"
@@ -184,8 +191,7 @@
putlog "Error in script: $proc: $val"
puterrlog "$::errorInfo"
}
- putlog "lev: $lev"
- putlog "val: $val"
+ ::tcldrop::countbind $type $mask $proc
if {![info exists retval]} {
set retlev $lev
set retval $val
@@ -206,6 +212,7 @@
putlog "Error in script: $proc: $val"
puterrlog "$::errorInfo"
}
+ ::tcldrop::countbind $type $mask $proc
if {![info exists retval]} {
set retlev $lev
set retval $val
@@ -226,6 +233,7 @@
putlog "Error in script: $proc: $val"
puterrlog "$::errorInfo"
}
+ ::tcldrop::countbind $type $mask $proc
return -code $lev $val
}
return -code error {No user database module has been loaded.}
@@ -246,6 +254,7 @@
putlog "Error in script: $proc: $val"
puterrlog "$::errorInfo"
}
+ ::tcldrop::countbind $type $mask $proc
if {![info exists retval]} {
set retlev $lev
set retval $val
@@ -266,6 +275,7 @@
putlog "Error in script: $proc: $val"
puterrlog "$::errorInfo"
}
+ ::tcldrop::countbind $type $mask $proc
if {![info exists retval]} {
set retlev $lev
set retval $val
@@ -286,6 +296,7 @@
putlog "Error in script: $proc: $val"
puterrlog "$::errorInfo"
}
+ ::tcldrop::countbind $type $mask $proc
if {![info exists retval]} {
set retlev $lev
set retval $val
@@ -307,6 +318,7 @@
putlog "Error in script: $proc: $val"
puterrlog "$::errorInfo"
}
+ ::tcldrop::countbind $type $mask $proc
if {![info exists retval]} {
set retlev $lev
set retval $val
@@ -328,6 +340,7 @@
putlog "Error in script: $proc: $val"
puterrlog "$::errorInfo"
}
+ ::tcldrop::countbind $type $mask $proc
if {![info exists retval]} {
set retlev $lev
set retval $val
@@ -349,6 +362,7 @@
putlog "Error in script: $proc: $val"
puterrlog "$::errorInfo"
}
+ ::tcldrop::countbind $type $mask $proc
if {![info exists retval]} {
set retlev $lev
set retval $val
@@ -371,6 +385,7 @@
putlog "Error in script: $proc: $val"
puterrlog "$::errorInfo"
}
+ ::tcldrop::countbind $type $mask $proc
if {![info exists retval]} {
set retlev $lev
set retval $val
@@ -391,6 +406,7 @@
putlog "Error in script: $proc: $val"
puterrlog "$::errorInfo"
}
+ ::tcldrop::countbind $type $mask $proc
if {![info exists retval]} {
set retlev $lev
set retval $val
@@ -411,6 +427,7 @@
putlog "Error in script: $proc: $val"
puterrlog "$::errorInfo"
}
+ ::tcldrop::countbind $type $mask $proc
if {![info exists retval]} {
set retlev $lev
set retval $val
@@ -430,6 +447,7 @@
putlog "Error in script: $proc: $val"
puterrlog "$::errorInfo"
}
+ ::tcldrop::countbind $type $mask $proc
return -code $lev $val
}
return -code error {No user database module has been loaded.}
@@ -446,6 +464,7 @@
putlog "Error in script: $proc: $val"
puterrlog "$::errorInfo"
}
+ ::tcldrop::countbind $type $mask $proc
if {![info exists retval]} {
set retlev $lev
set retval $val
@@ -466,6 +485,7 @@
putlog "Error in script: $proc: $val"
puterrlog "$::errorInfo"
}
+ ::tcldrop::countbind $type $mask $proc
if {![info exists retval]} {
set retlev $lev
set retval $val
@@ -486,6 +506,7 @@
putlog "Error in script: $proc: $val"
puterrlog "$::errorInfo"
}
+ ::tcldrop::countbind $type $mask $proc
if {![info exists retval]} {
set retlev $lev
set retval $val
Index: tcldrop/modules/users/users_arraydb.tcl
diff -u tcldrop/modules/users/users_arraydb.tcl:1.9
tcldrop/modules/users/users_arraydb.tcl:1.10
--- tcldrop/modules/users/users_arraydb.tcl:1.9 Fri Nov 14 10:58:48 2003
+++ tcldrop/modules/users/users_arraydb.tcl Fri Nov 21 17:27:48 2003
@@ -1,6 +1,6 @@
# users_arraydb.tcl --
#
-# $Id: users_arraydb.tcl,v 1.9 2003/11/14 15:58:48 fireegl Exp $
+# $Id: users_arraydb.tcl,v 1.10 2003/11/21 22:27:48 fireegl Exp $
#
# Copyright (C) 2003 FireEgl (Philip Moore) <address@hidden>
#
@@ -333,6 +333,7 @@
foreach a [binds adduser] {
foreach {type flags mask count proc} $a {}
if {[string match -nocase $mask $handle]} {
+ ::tcldrop::countbind $type $mask $proc
if {[catch { $proc $handle } err]} {
putlog "Error in script: $proc: $err"
puterrlog "$::errorInfo"
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Tcldrop/CVS] tcldrop/modules core.tcl dcc.tcl users/users.tc...,
Philip Moore <=