/[tcldrop]/tcldrop/modules/core.tcl
ViewVC logotype

Diff of /tcldrop/modules/core.tcl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.32 by fireegl, Wed Dec 3 03:39:41 2003 UTC revision 1.33 by uid66278, Wed Dec 24 06:11:07 2003 UTC
# Line 30  Line 30 
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
# Line 41  Line 40 
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
# Line 56  namespace eval tcldrop { Line 56  namespace eval tcldrop {
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:
# Line 75  if {[info exists mod-path] && [file isdi Line 77  if {[info exists mod-path] && [file isdi
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
# Line 209  proc putloglev {levels channel text} { Line 231  proc putloglev {levels channel text} {
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                  }                  }
# Line 223  proc putxferlog {text {channel {-}}} { p Line 250  proc putxferlog {text {channel {-}}} { p
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} {
# Line 254  proc ::tcldrop::CheckFlags {flags1 flags Line 278  proc ::tcldrop::CheckFlags {flags1 flags
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 }
# Line 281  proc ::tcldrop::MergeFlags {flags1 flags Line 307  proc ::tcldrop::MergeFlags {flags1 flags
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:
# Line 317  proc ::tcldrop::binds {{typemask {*}} {m Line 344  proc ::tcldrop::binds {{typemask {*}} {m
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)
# Line 443  proc ::tcldrop::killutimer {timerid} { k Line 474  proc ::tcldrop::killutimer {timerid} { k
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    
# Line 461  proc ::tcldrop::calltime {} { Line 494  proc ::tcldrop::calltime {} {
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}" }
# Line 491  proc ::tcldrop::traffic {{type {*}} {dir Line 525  proc ::tcldrop::traffic {{type {*}} {dir
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} {
# Line 499  proc ::tcldrop::traffic {{type {*}} {dir Line 533  proc ::tcldrop::traffic {{type {*}} {dir
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]
# Line 522  proc ::tcldrop::traffic {{type {*}} {dir Line 556  proc ::tcldrop::traffic {{type {*}} {dir
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    
# Line 540  proc ::tcldrop::HourlyUpdates {minute ho Line 574  proc ::tcldrop::HourlyUpdates {minute ho
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]"
# Line 588  proc unloadmodule {module} { set out {} Line 615  proc unloadmodule {module} { set out {}
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
# Line 604  proc callevent {event} { Line 631  proc callevent {event} {
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  }  }
# Line 677  proc restart {{type {restart}}} { Line 705  proc restart {{type {restart}}} {
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):
# Line 726  if {[catch { restart {start} }]} { Line 760  if {[catch { restart {start} }]} {
760                          close stdin                          close stdin
761                  }                  }
762          }          }
763  }  }
   

Legend:
Removed from v.1.32  
changed lines
  Added in v.1.33

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26