30 |
# config-eval if it exists will be eval'd before searching for the config file. |
# config-eval if it exists will be eval'd before searching for the config file. |
31 |
# So if you set the config variable inside config-eval, the config file will be loaded after the eval on config-eval is done. |
# So if you set the config variable inside config-eval, the config file will be loaded after the eval on config-eval is done. |
32 |
|
|
33 |
# FixMe: $config should be loaded first if the variable exists, before |
# FixMe: $config should be loaded first if the variable exists, before we eval $config-eval. |
|
# we eval $config-eval. |
|
34 |
|
|
35 |
# We create a namespace under this one called tcldrop.. |
# We create a namespace under this one called tcldrop.. |
36 |
# All procs and vars that should not be visible to 3rd-party scripters |
# All procs and vars that should not be visible to 3rd-party scripters |
40 |
set ver {0.4.0} |
set ver {0.4.0} |
41 |
set numversion {00040000} |
set numversion {00040000} |
42 |
set version [list $ver $numversion] |
set version [list $ver $numversion] |
43 |
namespace eval tcldrop { |
namespace eval ::tcldrop { |
44 |
# In case this command doesn't already exist: |
variable rcsid {$Id$} |
45 |
if {[info commands Stdout] == {}} { proc Stdout {levels channel text} { puts "[clock format [clock seconds] -format {[%H:%M]}] $text" } } |
variable name {tcldrop} |
46 |
# Provide the users module: |
variable author {Tcldrop-Dev} |
47 |
variable version {0.4} |
variable version {0.4} |
48 |
|
variable description {Provides all the core components} |
49 |
|
# Provide the core module: |
50 |
package provide tcldrop::core $version |
package provide tcldrop::core $version |
|
variable rcsid {$Id$} |
|
51 |
# Initialize variables: |
# Initialize variables: |
52 |
variable Binds |
variable Binds |
53 |
variable Timers |
variable Timers |
56 |
array set Traffic {} |
array set Traffic {} |
57 |
# Export all the commands that should be available to 3rd-party scripters: |
# Export all the commands that should be available to 3rd-party scripters: |
58 |
namespace export bind unbind binds timer utimer killtimer killutimer timers utimers maskhost isbotnetnick logfile traffic |
namespace export bind unbind binds timer utimer killtimer killutimer timers utimers maskhost isbotnetnick logfile traffic |
59 |
|
# In case this command doesn't already exist: |
60 |
|
if {[info commands Stdout] == {}} { proc Stdout {levels channel text} { catch { puts "[clock format [clock seconds] -format {[%H:%M]}] $text" } } } |
61 |
} |
} |
62 |
|
|
63 |
# Add our modules directory to the package require search path: |
# Add our modules directory to the package require search path: |
77 |
|
|
78 |
# Sets global variables, being careful not to overwrite any that may already exist. |
# Sets global variables, being careful not to overwrite any that may already exist. |
79 |
# This is mainly used after loading the config file, to fill in the gaps that the config may leave. |
# This is mainly used after loading the config file, to fill in the gaps that the config may leave. |
80 |
proc ::tcldrop::SetDefault {var {value {}}} { global $var |
proc ::tcldrop::setdefault {var {value {}}} { global $var |
81 |
if {[info exists $var]} { set $var } else { set $var $value } |
if {[info exists $var]} { set $var } else { set $var $value } |
82 |
} |
} |
83 |
|
proc ::tcldrop::SetDefault {var {value {}}} { ::tcldrop::setdefault $var $value } |
84 |
|
|
85 |
# Initialize variables to internal defaults, being careful not to overwrite existing settings. |
# Initialize variables to internal defaults, being careful not to overwrite existing settings. |
|
::tcldrop::SetDefault console {ocmkbxs} |
|
86 |
::tcldrop::SetDefault config {} |
::tcldrop::SetDefault config {} |
|
::tcldrop::SetDefault my-hostname {} |
|
|
::tcldrop::SetDefault my-ip {} |
|
87 |
::tcldrop::SetDefault owner {} |
::tcldrop::SetDefault owner {} |
88 |
::tcldrop::SetDefault nick {Tcldrop} |
::tcldrop::SetDefault nick {Tcldrop} |
89 |
::tcldrop::SetDefault lang-path {language} |
::tcldrop::SetDefault lang-path {language} |
90 |
::tcldrop::SetDefault hourly-updates {00} |
::tcldrop::SetDefault hourly-updates {00} |
91 |
::tcldrop::SetDefault log-time {1} |
::tcldrop::SetDefault log-time {1} |
92 |
|
::tcldrop::SetDefault fuzz {1} |
93 |
|
::tcldrop::SetDefault console {ocmkbxs} |
94 |
|
|
95 |
|
|
96 |
|
proc debugproc {name arg body} { |
97 |
|
proc $name $arg " |
98 |
|
global proctrack |
99 |
|
if \{!\[info exists proctrack\($name\)\]\} \{ |
100 |
|
array set procinfo \[list count 0 clicks 0\] |
101 |
|
\} else \{ |
102 |
|
array set procinfo \$proctrack\($name\) |
103 |
|
\} |
104 |
|
incr procinfo\(count\) |
105 |
|
set StartTime \[clock clicks\] |
106 |
|
set RetVal \[catch \{ $body \} Return\] |
107 |
|
incr procinfo\(clicks\) \[expr \{ \[clock clicks\] - \$StartTime \}\] |
108 |
|
set proctrack\($name\) \[array get procinfo\] |
109 |
|
return -code \$RetVal \$Return |
110 |
|
" |
111 |
|
} |
112 |
|
|
113 |
proc unixtime {} { clock seconds } |
proc unixtime {} { clock seconds } |
114 |
|
|
115 |
proc rand {maxint} { expr { int(rand()*$maxint) } } |
proc rand {maxint} { expr { int(rand()*$maxint) } } |
116 |
|
|
117 |
|
proc fuzz {number {percent {100}}} { expr { int(rand() * $percent / 100.0 * $number) + $number } } |
118 |
|
|
119 |
proc strftime {format {time {}}} { |
proc strftime {format {time {}}} { |
120 |
if {$time == {}} { set time [clock seconds] } |
if {$time == {}} { set time [clock seconds] } |
121 |
clock format $time -format $format |
clock format $time -format $format |
231 |
foreach {type flags mask count proc} $b {} |
foreach {type flags mask count proc} $b {} |
232 |
if {[::tcldrop::CheckFlags $flags $levels] && [string match -nocase $mask $channel]} { |
if {[::tcldrop::CheckFlags $flags $levels] && [string match -nocase $mask $channel]} { |
233 |
if {[catch { $proc $levels $channel $text } err]} { |
if {[catch { $proc $levels $channel $text } err]} { |
234 |
putlog "Error in $proc: $err" |
# Note: We log to Stdout, because it avoids recursive put*log errors.. |
235 |
puterrlog "$::errorInfo" |
::tcldrop::Stdout e - "LOG ERROR: $err\n$::errorInfo" |
236 |
|
# But we still try to log the error using put*log, and if it fails we exit with an errorcode! |
237 |
|
if {[catch { putlog "Error in $proc: $err" ; puterrlog "$::errorInfo" }]} { |
238 |
|
# put*log errors are considered fatal errors, so we really should exit: |
239 |
|
exit 1 |
240 |
|
} |
241 |
} |
} |
242 |
::tcldrop::countbind $type $mask $proc |
::tcldrop::countbind $type $mask $proc |
243 |
} |
} |
250 |
proc puterrlog {text {channel {-}}} { putloglev e $channel $text } |
proc puterrlog {text {channel {-}}} { putloglev e $channel $text } |
251 |
proc putdebuglog {text {channel {-}}} { putloglev d $channel $text } |
proc putdebuglog {text {channel {-}}} { putloglev d $channel $text } |
252 |
|
|
253 |
proc bgerror {args} { |
proc bgerror {args} { ::tcldrop::Stdout e - "(bgerror) $args\n$::errorInfo" } |
|
::tcldrop::Stdout - - "(bgerror) $args" |
|
|
::tcldrop::Stdout - - $::errorInfo |
|
|
} |
|
254 |
|
|
255 |
# Flag handling, returns 1 if there's a match, 0 if there's not. |
# Flag handling, returns 1 if there's a match, 0 if there's not. |
256 |
# $flags2's flags should match at least one of the flags in $flags1: |
# $flags2's flags should match at least one of the flags in $flags1: |
257 |
# Example: CheckFlags ab|c&d|fgh zcxd |
# Example: CheckFlags ab|c&d|fgh zcxd |
258 |
# Returns: 1 |
# Returns: 1 |
259 |
proc ::tcldrop::CheckFlags {flags1 flags2} { |
proc ::tcldrop::checkflags {flags1 flags2} { |
260 |
switch -- $flags1 { |
switch -- $flags1 { |
261 |
{+} - {*} - {} - {+|+} - {*|*} - {-} { return 1 } |
{+} - {*} - {} - {+|+} - {*|*} - {-} { return 1 } |
262 |
{default} { |
{default} { |
278 |
} |
} |
279 |
} |
} |
280 |
} |
} |
281 |
|
proc ::tcldrop::CheckFlags {flags1 flags2} { checkflags $flags1 $flags2 } |
282 |
|
|
283 |
|
|
284 |
# Merge $flags1 with $flags2 |
# Merge $flags1 with $flags2 |
285 |
# $flags1 should be (eg): +ofv-nm |
# $flags1 should be (eg): +ofv-nm |
286 |
# $flags2 should be (eg): nfmjxvp |
# $flags2 should be (eg): nfmjxvp |
287 |
# It Returns what you would expect, (eg): ofjvxp |
# It Returns what you would expect, (eg): ofjvxp |
288 |
proc ::tcldrop::MergeFlags {flags1 flags2} { set add 1 |
proc ::tcldrop::mergeflags {flags1 flags2} { set add 1 |
289 |
foreach f [split $flags1 {}] { |
foreach f [split $flags1 {}] { |
290 |
switch -- $f { |
switch -- $f { |
291 |
{+} { set add 1 } |
{+} { set add 1 } |
307 |
} |
} |
308 |
set flags2 |
set flags2 |
309 |
} |
} |
310 |
|
proc ::tcldrop::MergeFlags {flags1 flags2} { mergeflags $flags1 $flags2 } |
311 |
|
|
312 |
# Used to define bind's, works just like Eggdrop's bind command. |
# Used to define bind's, works just like Eggdrop's bind command. |
313 |
# Tcldrop also allows these extra (optional) options in $args: |
# Tcldrop also allows these extra (optional) options in $args: |
344 |
array set bind $Binds($b) |
array set bind $Binds($b) |
345 |
lappend matchbinds [list $bind(type) $bind(flags) $bind(mask) $bind(count) $bind(proc)] |
lappend matchbinds [list $bind(type) $bind(flags) $bind(mask) $bind(count) $bind(proc)] |
346 |
} |
} |
347 |
if {[llength $matchbinds] == 0} { |
# FixMe: Searching for masks this way is WAY too slow: |
348 |
# If none were found by type, we search by mask: |
#if {[llength $matchbinds] == 0} { |
349 |
# FixMe: This is too slow! |
# # If none were found by type, we search by mask: |
350 |
foreach b [lsort -dictionary [array names Binds]] { |
# # FixMe: This is too slow! |
351 |
array set bind $Binds($b) |
# foreach b [lsort -dictionary [array names Binds]] { |
352 |
if {[string equal -nocase $typemask $bind(mask)]} { |
# array set bind $Binds($b) |
353 |
lappend matchbinds [list $bind(type) $bind(flags) $bind(mask) $bind(count) $bind(proc)] |
# if {[string equal -nocase $typemask $bind(mask)]} { |
354 |
} |
# lappend matchbinds [list $bind(type) $bind(flags) $bind(mask) $bind(count) $bind(proc)] |
355 |
} |
# } |
356 |
} |
# } |
357 |
if {[info exists matchbinds]} { return $matchbinds } else { list } |
#} |
358 |
|
#if {[info exists matchbinds]} { return $matchbinds } else { list } |
359 |
|
set matchbinds |
360 |
} |
} |
361 |
|
|
362 |
# Counts how many times a bind has been triggered: |
# Counts how many times a bind has been triggered: |
363 |
proc ::tcldrop::countbind {type mask proc {priority {*}}} { |
proc ::tcldrop::countbind {type mask proc {priority {*}}} { |
364 |
|
# FixMe: Returning here, so I can speed test some other stuff. |
365 |
|
return 0 |
366 |
variable Binds |
variable Binds |
367 |
foreach name [array names Binds $type,$priority,$proc,$mask] { |
foreach name [array names Binds $type,$priority,$proc,$mask] { |
368 |
array set bind $Binds($name) |
array set bind $Binds($name) |
474 |
# often should use the timer command and its -1 (repeat forever) option. |
# often should use the timer command and its -1 (repeat forever) option. |
475 |
proc ::tcldrop::calltime {} { |
proc ::tcldrop::calltime {} { |
476 |
foreach {minute hour day month year} [set current [clock format [clock seconds] -format {%M %H %e %m %Y}]] {} |
foreach {minute hour day month year} [set current [clock format [clock seconds] -format {%M %H %e %m %Y}]] {} |
477 |
foreach b [binds time] { update |
foreach b [binds time] { |
478 |
foreach {type flags mask count proc} $b {} |
foreach {type flags mask count proc} $b {} |
479 |
if {[string match $mask $current]} { |
if {[string match $mask $current]} { |
|
countbind $type $mask $proc |
|
480 |
if {[catch { $proc $minute $hour $day $month $year } err]} { |
if {[catch { $proc $minute $hour $day $month $year } err]} { |
481 |
putlog "Error in $proc: $err" |
putlog "Error in $proc: $err" |
482 |
puterrlog "$::errorInfo" |
puterrlog "$::errorInfo" |
483 |
} |
} |
484 |
|
countbind $type $mask $proc |
485 |
} |
} |
486 |
|
# Call update so other events can be triggered.. This is one place where it should be safe to call [update] without the worry of having events being triggered out of order. |
487 |
|
update |
488 |
} |
} |
489 |
} |
} |
490 |
|
|
494 |
# This proc is from Papillon@EFNet |
# This proc is from Papillon@EFNet |
495 |
# (Papillon) -> I've enabeled this to apply to ipv6 hosts aswell, it does not mask them yet, but I'll look into it |
# (Papillon) -> I've enabeled this to apply to ipv6 hosts aswell, it does not mask them yet, but I'll look into it |
496 |
# Note: This is untested and unmodified. |
# Note: This is untested and unmodified. |
497 |
|
# FixMe: I'd rather this not use regexp's if possible.. regexp is slow, and therefore evil. =P |
498 |
proc ::tcldrop::maskhost {x} { |
proc ::tcldrop::maskhost {x} { |
499 |
if {[string match "*\**" [lindex [split $x @] 1]]} { return $x } |
if {[string match "*\**" [lindex [split $x @] 1]]} { return $x } |
500 |
if {![regexp ".*@.*" $x]} { set x "*@${x}" } |
if {![regexp ".*@.*" $x]} { set x "*@${x}" } |
525 |
array set info $Traffic($type) |
array set info $Traffic($type) |
526 |
} else { |
} else { |
527 |
# Initialize the counts. |
# Initialize the counts. |
528 |
array set info [list total-in 0 total-out 0 daily-in 0 daily-out 0 restart [unixtime]] |
array set info [list total-in 0 total-out 0 daily-in 0 daily-out 0 restart [clock seconds]] |
529 |
} |
} |
530 |
# Increase the counters: |
# Increase the counters: |
531 |
if {$bytes} { |
if {$bytes} { |
533 |
incr info(daily-$direction) $bytes |
incr info(daily-$direction) $bytes |
534 |
} |
} |
535 |
# See if 24 hours have elapsed, and if it has then clear the daily counts. |
# See if 24 hours have elapsed, and if it has then clear the daily counts. |
536 |
if {[expr { [unixtime] - $info(restart) > 86400 }]} { |
if {[expr { [clock seconds] - $info(restart) > 86400 }]} { |
537 |
array set info [list daily-in 0 daily-out 0 restart [unixtime]] |
array set info [list daily-in 0 daily-out 0 restart [clock seconds]] |
538 |
} |
} |
539 |
# Write the new counts back to the Traffic variable: |
# Write the new counts back to the Traffic variable: |
540 |
set Traffic($type) [array get info] |
set Traffic($type) [array get info] |
556 |
incr total(daily-out) $info(daily-out) |
incr total(daily-out) $info(daily-out) |
557 |
incr total(daily-in) $info(daily-in) |
incr total(daily-in) $info(daily-in) |
558 |
} |
} |
559 |
list Total $total(daily-in) $total(total-in) $total(daily-out) $total(total-out) |
lappend out [list total $total(daily-in) $total(total-in) $total(daily-out) $total(total-out)] |
560 |
} |
} |
561 |
} |
} |
562 |
|
|
574 |
# FixMe: We need to keep up with what modules are loaded, and their versions. |
# FixMe: We need to keep up with what modules are loaded, and their versions. |
575 |
proc loadmodule {module {version {}}} { |
proc loadmodule {module {version {}}} { |
576 |
if {(($version != {}) && ([catch { package require "tcldrop::${module}" $version } err])) || ([catch { package require "tcldrop::$module" } err])} { |
if {(($version != {}) && ([catch { package require "tcldrop::${module}" $version } err])) || ([catch { package require "tcldrop::$module" } err])} { |
577 |
putlog "[format $::tcldrop::lang(0x209)] $module $version: $err" |
putlog "[format $::tcldrop::lang(0x209)] $module $version: $err\n$::errorInfo" |
578 |
puterrlog "$::errorInfo" |
puterrlog "$::errorInfo" |
579 |
} else { |
} else { |
580 |
variable Modules |
variable Modules |
581 |
if {[info exists "::tcldrop::${module}::version"]} { set modver [set "::tcldrop::${module}::version"] } else { set modver {0.0} } |
if {[info exists "::tcldrop::${module}::version"]} { set modver [set "::tcldrop::${module}::version"] } else { set modver {0.0} } |
582 |
set Modules($module) $modver |
set Modules($module) $modver |
583 |
# Import the commands... |
# Import the commands... (Note, We could use -force here, but we need to see conflicts when they show up and fix them...) |
|
# This imports them into the tcldrop namespace: |
|
|
# Note, We could use -force here, but we need to see conflicts when they show up and fix them... |
|
|
if {[catch { namespace eval tcldrop "namespace import ${module}::*" } err]} { puterrlog $err } |
|
584 |
if {[catch { namespace import "::tcldrop::${module}::*" } err]} { puterrlog $err } |
if {[catch { namespace import "::tcldrop::${module}::*" } err]} { puterrlog $err } |
|
# Note, the reason for importing the commands to both the tcldrop |
|
|
# and the global namespace is so that in case we're not running |
|
|
# in our own interp we won't disturb what's already there. |
|
|
|
|
585 |
# Load the corresponding .lang file: |
# Load the corresponding .lang file: |
586 |
if {[addlang $::lang $module]} { |
if {[addlang $::lang $module]} { |
587 |
putlog "[format $::tcldrop::lang(0x20f) $module]" |
putlog "[format $::tcldrop::lang(0x20f) $module]" |
615 |
foreach {type flags mask count proc} $b {} |
foreach {type flags mask count proc} $b {} |
616 |
if {[string match -nocase $mask $module]} { |
if {[string match -nocase $mask $module]} { |
617 |
if {[catch { $proc $module } err]} { |
if {[catch { $proc $module } err]} { |
618 |
putlog "Error in $proc: $err" |
putlog "Error in $proc $module: $err" |
619 |
puterrlog "$::errorInfo" |
puterrlog "$::errorInfo" |
620 |
} |
} |
621 |
::tcldrop::countbind $type $mask $proc |
::tcldrop::countbind $type $mask $proc |
631 |
foreach b [binds evnt] { |
foreach b [binds evnt] { |
632 |
foreach {type flags mask count proc} $b {} |
foreach {type flags mask count proc} $b {} |
633 |
if {[string equal -nocase $event $mask]} { |
if {[string equal -nocase $event $mask]} { |
|
::tcldrop::countbind $type $mask $proc |
|
634 |
if {[catch { $proc $event } err]} { |
if {[catch { $proc $event } err]} { |
635 |
putlog "error running $proc $event:\n$::errorInfo" |
putlog "Error in $proc $event: $err" |
636 |
|
puterrlog "$::errorInfo" |
637 |
} |
} |
638 |
|
::tcldrop::countbind $type $mask $proc |
639 |
} |
} |
640 |
} |
} |
641 |
} |
} |
705 |
putlog "--- Loading Tcldrop v$::ver ([clock format [clock seconds] -format {%a %b %e %Y}])" |
putlog "--- Loading Tcldrop v$::ver ([clock format [clock seconds] -format {%a %b %e %Y}])" |
706 |
# Load the required modules (the order here is important): |
# Load the required modules (the order here is important): |
707 |
loadmodule users |
loadmodule users |
708 |
loadmodule idx |
#loadmodule idx |
709 |
# FixMe: These packages should probably load on demand instead.. |
# FixMe: These packages should probably load on demand instead.. |
710 |
package require ident |
package require ident |
711 |
# package require proxy::https |
# package require proxy::https |
712 |
|
loadmodule conn |
713 |
|
loadmodule idx |
714 |
loadmodule dcc |
loadmodule dcc |
715 |
|
loadmodule telnetparty |
716 |
|
loadmodule partyline |
717 |
|
loadmodule bots |
718 |
|
loadmodule bots::oldbotnet |
719 |
# Rehash, (re)loads the config file (which in turn should load the optional modules): |
# Rehash, (re)loads the config file (which in turn should load the optional modules): |
720 |
rehash $type |
rehash $type |
721 |
# Do like Eggdrop, and set botnet-nick to $nick (if it's not already set of course): |
# Do like Eggdrop, and set botnet-nick to $nick (if it's not already set of course): |
760 |
close stdin |
close stdin |
761 |
} |
} |
762 |
} |
} |
763 |
} |
} |
|
|
|